never executed always true always false

    1 
    2 {-# LANGUAGE ScopedTypeVariables #-}
    3 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    4 --
    5 --  (c) The University of Glasgow 2002-2006
    6 --
    7 
    8 -- | Generate infotables for interpreter-made bytecodes
    9 module GHC.ByteCode.InfoTable ( mkITbls ) where
   10 
   11 import GHC.Prelude
   12 
   13 import GHC.Driver.Session
   14 
   15 import GHC.Platform
   16 import GHC.Platform.Profile
   17 
   18 import GHC.ByteCode.Types
   19 import GHC.Runtime.Interpreter
   20 
   21 import GHC.Types.Name       ( Name, getName )
   22 import GHC.Types.Name.Env
   23 import GHC.Types.RepType
   24 
   25 import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )
   26 import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
   27 import GHC.Core.Multiplicity     ( scaledThing )
   28 
   29 import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
   30 import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
   31 
   32 import GHC.Utils.Misc
   33 import GHC.Utils.Panic
   34 
   35 {-
   36   Manufacturing of info tables for DataCons
   37 -}
   38 
   39 -- Make info tables for the data decls in this module
   40 mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
   41 mkITbls interp profile tcs =
   42   foldr plusNameEnv emptyNameEnv <$>
   43     mapM mkITbl (filter isDataTyCon tcs)
   44  where
   45   mkITbl :: TyCon -> IO ItblEnv
   46   mkITbl tc
   47     | dcs `lengthIs` n -- paranoia; this is an assertion.
   48     = make_constr_itbls interp profile dcs
   49        where
   50           dcs = tyConDataCons tc
   51           n   = tyConFamilySize tc
   52   mkITbl _ = panic "mkITbl"
   53 
   54 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
   55 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
   56 
   57 -- Assumes constructors are numbered from zero, not one
   58 make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
   59 make_constr_itbls interp profile cons =
   60   -- TODO: the profile should be bundled with the interpreter: the rts ways are
   61   -- fixed for an interpreter
   62   mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
   63  where
   64   mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
   65   mk_itbl dcon conNo = do
   66      let rep_args = [ NonVoid prim_rep
   67                     | arg <- dataConRepArgTys dcon
   68                     , prim_rep <- typePrimRep (scaledThing arg) ]
   69 
   70          (tot_wds, ptr_wds) =
   71              mkVirtConstrSizes profile rep_args
   72 
   73          ptrs'  = ptr_wds
   74          nptrs' = tot_wds - ptr_wds
   75          nptrs_really
   76             | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'
   77             | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'
   78 
   79          descr = dataConIdentity dcon
   80 
   81          platform = profilePlatform profile
   82          constants = platformConstants platform
   83          tables_next_to_code = platformTablesNextToCode platform
   84 
   85      r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really
   86                               conNo (tagForCon platform dcon) descr)
   87      return (getName dcon, ItblPtr r)