never executed always true always false
    1 
    2 {-# LANGUAGE DataKinds #-}
    3 {-# LANGUAGE BangPatterns #-}
    4 {-# LANGUAGE LambdaCase #-}
    5 
    6 -----------------------------------------------------------------------------
    7 --
    8 -- Stg to C-- code generation
    9 --
   10 -- (c) The University of Glasgow 2004-2006
   11 --
   12 -----------------------------------------------------------------------------
   13 
   14 module GHC.StgToCmm ( codeGen ) where
   15 
   16 import GHC.Prelude as Prelude
   17 
   18 import GHC.Driver.Backend
   19 import GHC.Driver.Session
   20 
   21 import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
   22 import GHC.StgToCmm.Monad
   23 import GHC.StgToCmm.Env
   24 import GHC.StgToCmm.Bind
   25 import GHC.StgToCmm.DataCon
   26 import GHC.StgToCmm.Layout
   27 import GHC.StgToCmm.Utils
   28 import GHC.StgToCmm.Closure
   29 import GHC.StgToCmm.Hpc
   30 import GHC.StgToCmm.Ticky
   31 import GHC.StgToCmm.Types (ModuleLFInfos)
   32 
   33 import GHC.Cmm
   34 import GHC.Cmm.Utils
   35 import GHC.Cmm.CLabel
   36 import GHC.Cmm.Graph
   37 
   38 import GHC.Stg.Syntax
   39 
   40 import GHC.Types.CostCentre
   41 import GHC.Types.IPE
   42 import GHC.Types.HpcInfo
   43 import GHC.Types.Id
   44 import GHC.Types.Id.Info
   45 import GHC.Types.RepType
   46 import GHC.Types.Basic
   47 import GHC.Types.Var.Set ( isEmptyDVarSet )
   48 import GHC.Types.Unique.FM
   49 import GHC.Types.Name.Env
   50 
   51 import GHC.Core.DataCon
   52 import GHC.Core.TyCon
   53 import GHC.Core.Multiplicity
   54 
   55 import GHC.Unit.Module
   56 
   57 import GHC.Utils.Error
   58 import GHC.Utils.Outputable
   59 import GHC.Utils.Panic.Plain
   60 import GHC.Utils.Logger
   61 
   62 import GHC.Utils.TmpFs
   63 
   64 import GHC.Data.Stream
   65 import GHC.Data.OrdList
   66 import GHC.Types.Unique.Map
   67 
   68 import Control.Monad (when,void, forM_)
   69 import GHC.Utils.Misc
   70 import System.IO.Unsafe
   71 import qualified Data.ByteString as BS
   72 import Data.IORef
   73 
   74 codeGen :: Logger
   75         -> TmpFs
   76         -> DynFlags
   77         -> Module
   78         -> InfoTableProvMap
   79         -> [TyCon]
   80         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
   81         -> [CgStgTopBinding]           -- Bindings to convert
   82         -> HpcInfo
   83         -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can
   84                                        -- be interleaved with output
   85 
   86 codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons
   87         cost_centre_info stg_binds hpc_info
   88   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
   89               -- Using an IORef to store the state is a bit crude, but otherwise
   90               -- we would need to add a state monad layer which regresses
   91               -- allocations by 0.5-2%.
   92         ; cgref <- liftIO $ initC >>= \s -> newIORef s
   93         ; let cg :: FCode a -> Stream IO CmmGroup a
   94               cg fcode = do
   95                 (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
   96                          st <- readIORef cgref
   97                          let (a,st') = runC dflags this_mod st (getCmm fcode)
   98 
   99                          -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
  100                          -- a big space leak.  DO NOT REMOVE!
  101                          -- This is observed by the #3294 test
  102                          writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
  103                          return a
  104                 yield cmm
  105                 return a
  106 
  107                -- Note [codegen-split-init] the cmm_init block must come
  108                -- FIRST.  This is because when -split-objs is on we need to
  109                -- combine this block with its initialisation routines; see
  110                -- Note [pipeline-split-init].
  111         ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
  112 
  113         ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds
  114                 -- Put datatype_stuff after code_stuff, because the
  115                 -- datatype closure table (for enumeration types) to
  116                 -- (say) PrelBase_True_closure, which is defined in
  117                 -- code_stuff
  118         ; let do_tycon tycon = do
  119                 -- Generate a table of static closures for an
  120                 -- enumeration type Note that the closure pointers are
  121                 -- tagged.
  122                  when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
  123                  -- Emit normal info_tables, for data constructors defined in this module.
  124                  mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
  125 
  126         ; mapM_ do_tycon data_tycons
  127 
  128         -- Emit special info tables for everything used in this module
  129         -- This will only do something if  `-fdistinct-info-tables` is turned on.
  130         ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)
  131 
  132         ; final_state <- liftIO (readIORef cgref)
  133         ; let cg_id_infos = cgs_binds final_state
  134 
  135           -- See Note [Conveying CAF-info and LFInfo between modules] in
  136           -- GHC.StgToCmm.Types
  137         ; let extractInfo info = (name, lf)
  138                 where
  139                   !name = idName (cg_id info)
  140                   !lf = cg_lf info
  141 
  142               !generatedInfo
  143                 | gopt Opt_OmitInterfacePragmas dflags
  144                 = emptyNameEnv
  145                 | otherwise
  146                 = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
  147 
  148         ; return generatedInfo
  149         }
  150 
  151 ---------------------------------------------------------------
  152 --      Top-level bindings
  153 ---------------------------------------------------------------
  154 
  155 {- 'cgTopBinding' is only used for top-level bindings, since they need
  156 to be allocated statically (not in the heap) and need to be labelled.
  157 No unboxed bindings can happen at top level.
  158 
  159 In the code below, the static bindings are accumulated in the
  160 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
  161 This is so that we can write the top level processing in a compositional
  162 style, with the increasing static environment being plumbed as a state
  163 variable. -}
  164 
  165 cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()
  166 cgTopBinding logger tmpfs dflags = \case
  167     StgTopLifted (StgNonRec id rhs) -> do
  168         let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
  169         fcode
  170         addBindC info
  171 
  172     StgTopLifted (StgRec pairs) -> do
  173         let (bndrs, rhss) = unzip pairs
  174         let pairs' = zip bndrs rhss
  175             r = unzipWith (cgTopRhs dflags Recursive) pairs'
  176             (infos, fcodes) = unzip r
  177         addBindsC infos
  178         sequence_ fcodes
  179 
  180     StgTopStringLit id str -> do
  181         let label = mkBytesLabel (idName id)
  182         -- emit either a CmmString literal or dump the string in a file and emit a
  183         -- CmmFileEmbed literal.
  184         -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
  185         let isNCG    = backend dflags == NCG
  186             isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags
  187             asString = binBlobThreshold dflags == 0 || isSmall
  188 
  189             (lit,decl) = if not isNCG || asString
  190               then mkByteStringCLit label str
  191               else mkFileEmbedLit label $ unsafePerformIO $ do
  192                      bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat"
  193                      BS.writeFile bFile str
  194                      return bFile
  195         emitDecl decl
  196         addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)
  197 
  198 
  199 cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
  200         -- The Id is passed along for setting up a binding...
  201 
  202 cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
  203   = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
  204       -- con args are always non-void,
  205       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
  206 
  207 cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
  208   = assert (isEmptyDVarSet fvs)    -- There should be no free variables
  209     cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body
  210 
  211 
  212 ---------------------------------------------------------------
  213 --      Module initialisation code
  214 ---------------------------------------------------------------
  215 
  216 mkModuleInit
  217         :: CollectedCCs         -- cost centre info
  218         -> Module
  219         -> HpcInfo
  220         -> FCode ()
  221 
  222 mkModuleInit cost_centre_info this_mod hpc_info
  223   = do  { initHpc this_mod hpc_info
  224         ; initCostCentres cost_centre_info
  225         }
  226 
  227 
  228 ---------------------------------------------------------------
  229 --      Generating static stuff for algebraic data types
  230 ---------------------------------------------------------------
  231 
  232 
  233 cgEnumerationTyCon :: TyCon -> FCode ()
  234 cgEnumerationTyCon tycon
  235   = do platform <- getPlatform
  236        emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
  237              [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
  238                            (tagForCon platform con)
  239              | con <- tyConDataCons tycon]
  240 
  241 
  242 cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
  243 -- Generate the entry code, info tables, and (for niladic constructor)
  244 -- the static closure, for a constructor.
  245 cgDataCon mn data_con
  246   = do  { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))
  247         ; profile <- getProfile
  248         ; platform <- getPlatform
  249         ; let
  250             (tot_wds, --  #ptr_wds + #nonptr_wds
  251              ptr_wds) --  #ptr_wds
  252               = mkVirtConstrSizes profile arg_reps
  253 
  254             nonptr_wds   = tot_wds - ptr_wds
  255 
  256             dyn_info_tbl =
  257               mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds
  258 
  259             -- We're generating info tables, so we don't know and care about
  260             -- what the actual arguments are. Using () here as the place holder.
  261             arg_reps :: [NonVoid PrimRep]
  262             arg_reps = [ NonVoid rep_ty
  263                        | ty <- dataConRepArgTys data_con
  264                        , rep_ty <- typePrimRep (scaledThing ty)
  265                        , not (isVoidRep rep_ty) ]
  266 
  267         ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
  268             -- NB: the closure pointer is assumed *untagged* on
  269             -- entry to a constructor.  If the pointer is tagged,
  270             -- then we should not be entering it.  This assumption
  271             -- is used in ldvEnter and when tagging the pointer to
  272             -- return it.
  273             -- NB 2: We don't set CC when entering data (WDP 94/06)
  274             do { tickyEnterDynCon
  275                ; ldvEnter (CmmReg nodeReg)
  276                ; tickyReturnOldCon (length arg_reps)
  277                ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]
  278                }
  279                     -- The case continuation code expects a tagged pointer
  280         }