{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------
--
-- Stg to C-- code generation
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm ( codeGen ) where

import GHC.Prelude as Prelude

import GHC.Cmm.UniqueRenamer
import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Bind
import GHC.StgToCmm.DataCon
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Types (ModuleLFInfos)
import GHC.StgToCmm.CgUtils (CgStream)

import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Cmm.Graph

import GHC.Stg.Syntax

import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.HpcInfo
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.RepType
import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Name.Env

import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Multiplicity

import GHC.Unit.Module

import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Logger

import GHC.Utils.TmpFs

import GHC.Data.Stream
import GHC.Data.OrdList

import Control.Monad (when,void, forM_)
import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
import Data.IORef
import GHC.Utils.Panic

codeGen :: Logger
        -> TmpFs
        -> StgToCmmConfig
        -> InfoTableProvMap
        -> [TyCon]
        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
        -> [CgStgTopBinding]           -- Bindings to convert
        -> HpcInfo
        -> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the CG] on CgStream
                                       -- Output as a stream, so codegen can
                                       -- be interleaved with output

codeGen :: Logger
-> TmpFs
-> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
codeGen Logger
logger TmpFs
tmpfs StgToCmmConfig
cfg (InfoTableProvMap DCMap
denv ClosureMap
_ InfoTableToSourceLocationMap
_) [TyCon]
data_tycons
        CollectedCCs
cost_centre_info [CgStgTopBinding]
stg_binds HpcInfo
hpc_info
  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
              -- Using an IORef to store the state is a bit crude, but otherwise
              -- we would need to add a state monad layer which regresses
              -- allocations by 0.5-2%.
        ; cgref <- IO (IORef CgState) -> Stream (UniqDSMT IO) CmmGroup (IORef CgState)
forall a. IO a -> Stream (UniqDSMT IO) CmmGroup a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef CgState)
 -> Stream (UniqDSMT IO) CmmGroup (IORef CgState))
-> IO (IORef CgState)
-> Stream (UniqDSMT IO) CmmGroup (IORef CgState)
forall a b. (a -> b) -> a -> b
$ IO CgState
initC IO CgState -> (CgState -> IO (IORef CgState)) -> IO (IORef CgState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CgState
s -> CgState -> IO (IORef CgState)
forall a. a -> IO (IORef a)
newIORef CgState
s
        ; uniqRnRef <- liftIO $ newIORef emptyDetUFM
        ; let fstate = Platform -> FCodeState
initFCodeState (Platform -> FCodeState) -> Platform -> FCodeState
forall a b. (a -> b) -> a -> b
$ StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
        ; let cg :: FCode a -> CgStream CmmGroup a
              cg FCode a
fcode = do
                (a, cmm) <- IO (a, CmmGroup) -> Stream (UniqDSMT IO) CmmGroup (a, CmmGroup)
forall a. IO a -> Stream (UniqDSMT IO) CmmGroup a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, CmmGroup) -> Stream (UniqDSMT IO) CmmGroup (a, CmmGroup))
-> (IO (a, CmmGroup) -> IO (a, CmmGroup))
-> IO (a, CmmGroup)
-> Stream (UniqDSMT IO) CmmGroup (a, CmmGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> SDoc
-> ((a, CmmGroup) -> ())
-> IO (a, CmmGroup)
-> IO (a, CmmGroup)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"STG -> Cmm") ((a, CmmGroup) -> () -> ()
forall a b. a -> b -> b
`seq` ()) (IO (a, CmmGroup) -> Stream (UniqDSMT IO) CmmGroup (a, CmmGroup))
-> IO (a, CmmGroup) -> Stream (UniqDSMT IO) CmmGroup (a, CmmGroup)
forall a b. (a -> b) -> a -> b
$ do
                         st <- IORef CgState -> IO CgState
forall a. IORef a -> IO a
readIORef IORef CgState
cgref

                         rnm0 <- readIORef uniqRnRef

                         let
                           ((a, cmm), st') = runC cfg fstate st (getCmm fcode)
                           (rnm1, cmm_renamed) =
                             -- Enable deterministic object code generation by
                             -- renaming uniques deterministically.
                             -- See Note [Object determinism]
                             if stgToCmmObjectDeterminism cfg
                                then detRenameCmmGroup rnm0 cmm -- The yielded cmm will already be renamed.
                                else (rnm0, removeDeterm cmm)

                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
                         -- a big space leak.  DO NOT REMOVE!
                         -- This is observed by the #3294 test
                         writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
                         writeIORef uniqRnRef $! rnm1

                         return (a, cmm_renamed)
                yield cmm
                return a

        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)

        ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
                -- Put datatype_stuff after code_stuff, because the
                -- datatype closure table (for enumeration types) to
                -- (say) PrelBase_True_closure, which is defined in
                -- code_stuff
        ; let do_tycon TyCon
tycon = do
                -- Generate a table of static closures for an
                -- enumeration type Note that the closure pointers are
                -- tagged.
                 Bool
-> Stream (UniqDSMT IO) CmmGroup ()
-> Stream (UniqDSMT IO) CmmGroup ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isEnumerationTyCon TyCon
tycon) (Stream (UniqDSMT IO) CmmGroup ()
 -> Stream (UniqDSMT IO) CmmGroup ())
-> Stream (UniqDSMT IO) CmmGroup ()
-> Stream (UniqDSMT IO) CmmGroup ()
forall a b. (a -> b) -> a -> b
$ FCode () -> Stream (UniqDSMT IO) CmmGroup ()
forall a. FCode a -> CgStream CmmGroup a
cg (TyCon -> FCode ()
cgEnumerationTyCon TyCon
tycon)
                 -- Emit normal info_tables, for data constructors defined in this module.
                 (DataCon -> Stream (UniqDSMT IO) CmmGroup ())
-> [DataCon] -> Stream (UniqDSMT IO) CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FCode () -> Stream (UniqDSMT IO) CmmGroup ()
forall a. FCode a -> CgStream CmmGroup a
cg (FCode () -> Stream (UniqDSMT IO) CmmGroup ())
-> (DataCon -> FCode ())
-> DataCon
-> Stream (UniqDSMT IO) CmmGroup ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon ConInfoTableLocation
DefinitionSite) (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)

        ; mapM_ do_tycon data_tycons

        -- Emit special info tables for everything used in this module
        -- This will only do something if  `-fdistinct-info-tables` is turned on.
        ; mapM_ (\(DataCon
dc, NonEmpty (WordOff, Maybe IpeSourceLocation)
ns) -> NonEmpty (WordOff, Maybe IpeSourceLocation)
-> ((WordOff, Maybe IpeSourceLocation)
    -> Stream (UniqDSMT IO) CmmGroup ())
-> Stream (UniqDSMT IO) CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (WordOff, Maybe IpeSourceLocation)
ns (((WordOff, Maybe IpeSourceLocation)
  -> Stream (UniqDSMT IO) CmmGroup ())
 -> Stream (UniqDSMT IO) CmmGroup ())
-> ((WordOff, Maybe IpeSourceLocation)
    -> Stream (UniqDSMT IO) CmmGroup ())
-> Stream (UniqDSMT IO) CmmGroup ()
forall a b. (a -> b) -> a -> b
$ \(WordOff
k, Maybe IpeSourceLocation
_ss) -> FCode () -> Stream (UniqDSMT IO) CmmGroup ()
forall a. FCode a -> CgStream CmmGroup a
cg (ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon (Module -> WordOff -> ConInfoTableLocation
UsageSite (StgToCmmConfig -> Module
stgToCmmThisModule StgToCmmConfig
cfg) WordOff
k) DataCon
dc)) (eltsUDFM denv)

        ; final_state <- liftIO (readIORef cgref)
        ; let cg_id_infos = CgState -> CgBindings
cgs_binds CgState
final_state

          -- See Note [Conveying CAF-info and LFInfo between modules] in
          -- GHC.StgToCmm.Types
        ; let extractInfo CgIdInfo
info = (Name
name, LambdaFormInfo
lf)
                where
                  !name :: Name
name = Var -> Name
idName (CgIdInfo -> Var
cg_id CgIdInfo
info)
                  !lf :: LambdaFormInfo
lf = CgIdInfo -> LambdaFormInfo
cg_lf CgIdInfo
info

              !generatedInfo
                | StgToCmmConfig -> Bool
stgToCmmOmitIfPragmas StgToCmmConfig
cfg
                = ModuleLFInfos
forall a. NameEnv a
emptyNameEnv
                | Bool
otherwise
                = [(Name, LambdaFormInfo)] -> ModuleLFInfos
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ((CgIdInfo -> (Name, LambdaFormInfo))
-> [CgIdInfo] -> [(Name, LambdaFormInfo)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map CgIdInfo -> (Name, LambdaFormInfo)
extractInfo (CgBindings -> [CgIdInfo]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM CgBindings
cg_id_infos))

        ; rn_mapping <- liftIO (readIORef uniqRnRef)
        ; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)

        ; return (generatedInfo, rn_mapping)
        }

{-
Note [Object determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~
Object determinism means that GHC, for the same exact input, produces,
deterministically, byte-for-byte identical objects (.o files, executables,
libraries...) on separate multi-threaded runs.

Deterministic objects are critical, for instance, for reproducible software
packaging and distribution, or build systems with content-sensitive
recompilation avoidance.

The main cause of non-determinism in objects comes from the non-deterministic
uniques leaking into the generated code. Apart from uniques previously affecting
determinism both directly by showing up in symbol labels and indirectly, e.g. in
the CLabel Ord instance, GHC already did a lot deterministically (modulo bugs)
by the time we set out to achieve full object determinism:

* The Simplifier is deterministic in the optimisations it applies (c.f. #25170)

* Interface files are deterministic (which depends on the previous bullet)

* The Cmm/NCG pipeline processes sections in a deterministic order, so the final
  object sections, closures, data, etc., are already always outputted in the
  same order for the same module.

Beyond fixing small bugs in the above bullets and other smaller non-determinism
leaks like the Ord instance of CLabels, we must ensure that/do the following to
make GHC produce fully deterministic objects:

* In STG -> Cmm, deterministically /rename/ all non-external uniques in the Cmm
  chunk, deterministically, before yielding. See Note [Renaming uniques deterministically]
  in GHC.Cmm.UniqueRenamer. This pass is necessary for object determinism but
  is currently guarded by -fobject-determinism.

* Multiple Cmm passes work with non-deterministic @LabelMap@s -- that doesn't
  change since they are both important for performance and do not affect the
  determinism of the end result. As after the renaming pass the uniques are all
  produced deterministically, the orderings observable by the map are also going
  to be deterministic. In the brief period before a CmmGroup has been renamed,
  a list instead of LabelMap is used to preserve the ordering.
  See Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] in GHC.Cmm.

* In the code generation pipeline from Cmm onwards, when new uniques need to be
  created for a given pass, use @UniqDSM@ instead of the previously used @UniqSM@.
  @UniqDSM@ supplies uniques iteratively, guaranteeing uniques produced by the
  backend are deterministic accross runs.
  See Note [Deterministic Uniques in the CG] in GHC.Types.Unique.DSM.

Also, c.f. Note [Unique Determinism]
-}


---------------------------------------------------------------
--      Top-level bindings
---------------------------------------------------------------

{- 'cgTopBinding' is only used for top-level bindings, since they need
to be allocated statically (not in the heap) and need to be labelled.
No unboxed bindings can happen at top level.

In the code below, the static bindings are accumulated in the
@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable. -}

cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()
cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()
cgTopBinding Logger
logger TmpFs
tmpfs StgToCmmConfig
cfg = \case
    StgTopLifted (StgNonRec BinderP 'CodeGen
id GenStgRhs 'CodeGen
rhs) -> do
        let (CgIdInfo
info, FCode ()
fcode) = StgToCmmConfig
-> RecFlag -> Var -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs StgToCmmConfig
cfg RecFlag
NonRecursive Var
BinderP 'CodeGen
id GenStgRhs 'CodeGen
rhs
        FCode ()
fcode
        CgIdInfo -> FCode ()
addBindC CgIdInfo
info

    StgTopLifted (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs) -> do
        let ([Var]
bndrs, [GenStgRhs 'CodeGen]
rhss) = [(Var, GenStgRhs 'CodeGen)] -> ([Var], [GenStgRhs 'CodeGen])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
        let pairs' :: [(Var, GenStgRhs 'CodeGen)]
pairs' = [Var] -> [GenStgRhs 'CodeGen] -> [(Var, GenStgRhs 'CodeGen)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
bndrs [GenStgRhs 'CodeGen]
rhss
            r :: [(CgIdInfo, FCode ())]
r = (Var -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ()))
-> [(Var, GenStgRhs 'CodeGen)] -> [(CgIdInfo, FCode ())]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (StgToCmmConfig
-> RecFlag -> Var -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs StgToCmmConfig
cfg RecFlag
Recursive) [(Var, GenStgRhs 'CodeGen)]
pairs'
            ([CgIdInfo]
infos, [FCode ()]
fcodes) = [(CgIdInfo, FCode ())] -> ([CgIdInfo], [FCode ()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode ())]
r
        [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
infos
        [FCode ()] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [FCode ()]
fcodes

    StgTopStringLit Var
id ByteString
str -> do
        let label :: CLabel
label = Name -> CLabel
mkBytesLabel (Var -> Name
idName Var
id)
        -- emit either a CmmString literal or dump the string in a file and emit a
        -- CmmFileEmbed literal.  If binary blobs aren't supported,
        -- the threshold in `cfg` will be 0.
        -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
        let asString :: Bool
asString = case StgToCmmConfig -> Maybe Word
stgToCmmBinBlobThresh StgToCmmConfig
cfg of
              Just Word
bin_blob_threshold -> WordOff -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> WordOff
BS.length ByteString
str) Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
bin_blob_threshold
              Maybe Word
Nothing                -> Bool
True

            (CmmLit
lit,DCmmDecl
decl) = if Bool
asString
              then CLabel -> ByteString -> (CmmLit, DCmmDecl)
forall (raw :: Bool) info stmt.
CLabel
-> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit CLabel
label ByteString
str
              else IO (CmmLit, DCmmDecl) -> (CmmLit, DCmmDecl)
forall a. IO a -> a
unsafePerformIO (IO (CmmLit, DCmmDecl) -> (CmmLit, DCmmDecl))
-> IO (CmmLit, DCmmDecl) -> (CmmLit, DCmmDecl)
forall a b. (a -> b) -> a -> b
$ do
                     bFile <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (StgToCmmConfig -> TempDir
stgToCmmTmpDir StgToCmmConfig
cfg) TempFileLifetime
TFL_CurrentModule String
".dat"
                     BS.writeFile bFile str
                     return $ mkFileEmbedLit label bFile (BS.length str)
        DCmmDecl -> FCode ()
emitDecl DCmmDecl
decl
        CgIdInfo -> FCode ()
addBindC (Platform -> Var -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo (StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg) Var
id LambdaFormInfo
mkLFStringLit CmmLit
lit)


cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
        -- The Id is passed along for setting up a binding...

cgTopRhs :: StgToCmmConfig
-> RecFlag -> Var -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs StgToCmmConfig
cfg RecFlag
_rec Var
bndr (StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
mn [StgTickish]
_ts [StgArg]
args Type
_typ)
  = StgToCmmConfig
-> Var
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon StgToCmmConfig
cfg Var
bndr DataCon
con ConstructorNumber
mn ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
      -- con args are always non-void,
      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise

cgTopRhs StgToCmmConfig
cfg RecFlag
rec Var
bndr (StgRhsClosure XRhsClosure 'CodeGen
fvs CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body Type
_typ)
  = Bool -> SDoc -> (CgIdInfo, FCode ()) -> (CgIdInfo, FCode ())
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (DIdSet -> Bool
isEmptyDVarSet DIdSet
XRhsClosure 'CodeGen
fvs) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DIdSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr DIdSet
XRhsClosure 'CodeGen
fvs) ((CgIdInfo, FCode ()) -> (CgIdInfo, FCode ()))
-> (CgIdInfo, FCode ()) -> (CgIdInfo, FCode ())
forall a b. (a -> b) -> a -> b
$   -- There should be no free variables
    Platform
-> RecFlag
-> Var
-> CostCentreStack
-> UpdateFlag
-> [Var]
-> GenStgExpr 'CodeGen
-> (CgIdInfo, FCode ())
cgTopRhsClosure (StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg) RecFlag
rec Var
bndr CostCentreStack
cc UpdateFlag
upd_flag [Var]
[BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body


---------------------------------------------------------------
--      Module initialisation code
---------------------------------------------------------------

mkModuleInit
        :: CollectedCCs         -- cost centre info
        -> Module
        -> HpcInfo
        -> FCode ()

mkModuleInit :: CollectedCCs -> Module -> HpcInfo -> FCode ()
mkModuleInit CollectedCCs
cost_centre_info Module
this_mod HpcInfo
hpc_info
  = do  { Module -> HpcInfo -> FCode ()
initHpc Module
this_mod HpcInfo
hpc_info
        ; CollectedCCs -> FCode ()
initCostCentres CollectedCCs
cost_centre_info
        }


---------------------------------------------------------------
--      Generating static stuff for algebraic data types
---------------------------------------------------------------


cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon TyCon
tycon
  = do platform <- FCode Platform
getPlatform
       emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)
             [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)
                           (tagForCon platform con)
             | con <- tyConDataCons tycon]


cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
-- the static closure, for a constructor.
cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon ConInfoTableLocation
mn DataCon
data_con
  = do  { Bool -> FCode ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
data_con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
data_con))
        ; profile <- FCode Profile
getProfile
        ; platform <- getPlatform
        ; let
            (tot_wds, --  #ptr_wds + #nonptr_wds
             ptr_wds) --  #ptr_wds
              = mkVirtConstrSizes profile arg_reps

            nonptr_wds   = WordOff
tot_wds WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
ptr_wds

            dyn_info_tbl =
              Profile
-> DataCon
-> ConInfoTableLocation
-> Bool
-> WordOff
-> WordOff
-> CmmInfoTable
mkDataConInfoTable Profile
profile DataCon
data_con ConInfoTableLocation
mn Bool
False WordOff
ptr_wds WordOff
nonptr_wds

            -- We're generating info tables, so we don't know and care about
            -- what the actual arguments are. Using () here as the place holder.
            arg_reps :: [PrimRep]
            arg_reps = [ PrimRep
rep_ty
                       | Scaled Type
ty <- DataCon -> [Scaled Type]
dataConRepArgTys DataCon
data_con
                       , PrimRep
rep_ty <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty)
                       ]

        ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
            -- NB: the closure pointer is assumed *untagged* on
            -- entry to a constructor.  If the pointer is tagged,
            -- then we should not be entering it.  This assumption
            -- is used in ldvEnter and when tagging the pointer to
            -- return it.
            -- NB 2: We don't set CC when entering data (WDP 94/06)
            do { tickyEnterDynCon
               ; let node = CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> CmmReg
nodeReg Platform
platform
               ; ldvEnter node
               ; tickyReturnOldCon (length arg_reps)
               ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)]
               }
                    -- The case continuation code expects a tagged pointer
        }