{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

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

module GHC.StgToCmm ( codeGen ) where

#include "HsVersions.h"

import GHC.Prelude as Prelude

import GHC.Driver.Backend
import GHC.Driver.Session

import GHC.StgToCmm.Prof (initInfoTableProv, 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.Hpc
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Types (ModuleLFInfos)

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.FM
import GHC.Types.Name.Env
import GHC.Types.ForeignStubs

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.Panic
import GHC.Utils.Logger

import GHC.Utils.TmpFs

import GHC.Data.Stream
import GHC.Data.OrdList
import GHC.Types.Unique.Map

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

data CodeGenState = CodeGenState { CodeGenState -> OrdList CmmInfoTable
codegen_used_info :: !(OrdList CmmInfoTable)
                                 , CodeGenState -> CgState
codegen_state :: !CgState }


codeGen :: Logger
        -> TmpFs
        -> DynFlags
        -> Module
        -> InfoTableProvMap
        -> [TyCon]
        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
        -> [CgStgTopBinding]           -- Bindings to convert
        -> HpcInfo
        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can
                                       -- be interleaved with output

codeGen :: Logger
-> TmpFs
-> DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
codeGen Logger
logger TmpFs
tmpfs DynFlags
dflags Module
this_mod ip_map :: InfoTableProvMap
ip_map@(InfoTableProvMap (UniqMap UniqFM
  DataCon (DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))
denv) ClosureMap
_) [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%.
        ; IORef CodeGenState
cgref <- IO (IORef CodeGenState) -> Stream IO CmmGroup (IORef CodeGenState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef CodeGenState)
 -> Stream IO CmmGroup (IORef CodeGenState))
-> IO (IORef CodeGenState)
-> Stream IO CmmGroup (IORef CodeGenState)
forall a b. (a -> b) -> a -> b
$ IO CgState
initC IO CgState
-> (CgState -> IO (IORef CodeGenState)) -> IO (IORef CodeGenState)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CgState
s -> CodeGenState -> IO (IORef CodeGenState)
forall a. a -> IO (IORef a)
newIORef (OrdList CmmInfoTable -> CgState -> CodeGenState
CodeGenState OrdList CmmInfoTable
forall a. Monoid a => a
mempty CgState
s)
        ; let cg :: FCode a -> Stream IO CmmGroup a
              cg :: forall a. FCode a -> Stream IO CmmGroup a
cg FCode a
fcode = do
                (a
a, CmmGroup
cmm) <- IO (a, CmmGroup) -> Stream IO CmmGroup (a, CmmGroup)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, CmmGroup) -> Stream IO CmmGroup (a, CmmGroup))
-> (IO (a, CmmGroup) -> IO (a, CmmGroup))
-> IO (a, CmmGroup)
-> Stream IO CmmGroup (a, CmmGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> DynFlags
-> SDoc
-> ((a, CmmGroup) -> ())
-> IO (a, CmmGroup)
-> IO (a, CmmGroup)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger DynFlags
dflags (String -> SDoc
text String
"STG -> Cmm") ((a, CmmGroup) -> () -> ()
`seq` ()) (IO (a, CmmGroup) -> Stream IO CmmGroup (a, CmmGroup))
-> IO (a, CmmGroup) -> Stream IO CmmGroup (a, CmmGroup)
forall a b. (a -> b) -> a -> b
$ do
                         CodeGenState OrdList CmmInfoTable
ts CgState
st <- IORef CodeGenState -> IO CodeGenState
forall a. IORef a -> IO a
readIORef IORef CodeGenState
cgref
                         let ((a, CmmGroup)
a,CgState
st') = DynFlags
-> Module
-> CgState
-> FCode (a, CmmGroup)
-> ((a, CmmGroup), CgState)
forall a. DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
this_mod CgState
st (FCode a -> FCode (a, CmmGroup)
forall a. FCode a -> FCode (a, CmmGroup)
getCmm FCode a
fcode)

                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
                         -- a big space leak.  DO NOT REMOVE!
                         -- This is observed by the #3294 test
                         let !used_info :: OrdList CmmInfoTable
used_info
                                | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags = [CmmInfoTable] -> OrdList CmmInfoTable
forall a. [a] -> OrdList a
toOL ((GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode)
 -> Maybe CmmInfoTable)
-> CmmGroup -> [CmmInfoTable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode)
-> Maybe CmmInfoTable
forall a (n :: Extensibility -> Extensibility -> *).
GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable ((a, CmmGroup) -> CmmGroup
forall a b. (a, b) -> b
snd (a, CmmGroup)
a)) OrdList CmmInfoTable
-> OrdList CmmInfoTable -> OrdList CmmInfoTable
forall a. Monoid a => a -> a -> a
`mappend` OrdList CmmInfoTable
ts
                                | Bool
otherwise = OrdList CmmInfoTable
forall a. Monoid a => a
mempty
                         IORef CodeGenState -> CodeGenState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CodeGenState
cgref (CodeGenState -> IO ()) -> CodeGenState -> IO ()
forall a b. (a -> b) -> a -> b
$!
                                    OrdList CmmInfoTable -> CgState -> CodeGenState
CodeGenState OrdList CmmInfoTable
used_info
                                      (CgState
st'{ cgs_tops :: OrdList (GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode))
cgs_tops = OrdList (GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode))
forall a. OrdList a
nilOL,
                                            cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop
                                          })

                         (a, CmmGroup) -> IO (a, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (a, CmmGroup)
a
                CmmGroup -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
yield CmmGroup
cmm
                a -> Stream IO CmmGroup a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

               -- Note [codegen-split-init] the cmm_init block must come
               -- FIRST.  This is because when -split-objs is on we need to
               -- combine this block with its initialisation routines; see
               -- Note [pipeline-split-init].
        ; FCode () -> Stream IO CmmGroup ()
forall a. FCode a -> Stream IO CmmGroup a
cg (CollectedCCs -> Module -> HpcInfo -> FCode ()
mkModuleInit CollectedCCs
cost_centre_info Module
this_mod HpcInfo
hpc_info)

        ; (CgStgTopBinding -> Stream IO CmmGroup ())
-> [CgStgTopBinding] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FCode () -> Stream IO CmmGroup ()
forall a. FCode a -> Stream IO CmmGroup a
cg (FCode () -> Stream IO CmmGroup ())
-> (CgStgTopBinding -> FCode ())
-> CgStgTopBinding
-> Stream IO CmmGroup ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding Logger
logger TmpFs
tmpfs DynFlags
dflags) [CgStgTopBinding]
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 -> Stream IO CmmGroup ()
do_tycon TyCon
tycon = do
                -- Generate a table of static closures for an
                -- enumeration type Note that the closure pointers are
                -- tagged.
                 Bool -> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isEnumerationTyCon TyCon
tycon) (Stream IO CmmGroup () -> Stream IO CmmGroup ())
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall a b. (a -> b) -> a -> b
$ FCode () -> Stream IO CmmGroup ()
forall a. FCode a -> Stream IO CmmGroup a
cg (TyCon -> FCode ()
cgEnumerationTyCon TyCon
tycon)
                 -- Emit normal info_tables, for data constructors defined in this module.
                 (DataCon -> Stream IO CmmGroup ())
-> [DataCon] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FCode () -> Stream IO CmmGroup ()
forall a. FCode a -> Stream IO CmmGroup a
cg (FCode () -> Stream IO CmmGroup ())
-> (DataCon -> FCode ()) -> DataCon -> Stream IO CmmGroup ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon ConInfoTableLocation
DefinitionSite) (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)

        ; (TyCon -> Stream IO CmmGroup ())
-> [TyCon] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TyCon -> Stream IO CmmGroup ()
do_tycon [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.
        ; ((DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))
 -> Stream IO CmmGroup ())
-> [(DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))]
-> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(DataCon
dc, NonEmpty (WordOff, Maybe (RealSrcSpan, String))
ns) -> NonEmpty (WordOff, Maybe (RealSrcSpan, String))
-> ((WordOff, Maybe (RealSrcSpan, String))
    -> Stream IO CmmGroup ())
-> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (WordOff, Maybe (RealSrcSpan, String))
ns (((WordOff, Maybe (RealSrcSpan, String)) -> Stream IO CmmGroup ())
 -> Stream IO CmmGroup ())
-> ((WordOff, Maybe (RealSrcSpan, String))
    -> Stream IO CmmGroup ())
-> Stream IO CmmGroup ()
forall a b. (a -> b) -> a -> b
$ \(WordOff
k, Maybe (RealSrcSpan, String)
_ss) -> FCode () -> Stream IO CmmGroup ()
forall a. FCode a -> Stream IO CmmGroup a
cg (ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon (Module -> WordOff -> ConInfoTableLocation
UsageSite Module
this_mod WordOff
k) DataCon
dc)) (UniqFM
  DataCon (DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))
-> [(DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM
  DataCon (DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))
denv)

        ; CodeGenState
final_state <- IO CodeGenState -> Stream IO CmmGroup CodeGenState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef CodeGenState -> IO CodeGenState
forall a. IORef a -> IO a
readIORef IORef CodeGenState
cgref)
        ; let cg_id_infos :: CgBindings
cg_id_infos = CgState -> CgBindings
cgs_binds (CgState -> CgBindings)
-> (CodeGenState -> CgState) -> CodeGenState -> CgBindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenState -> CgState
codegen_state (CodeGenState -> CgBindings) -> CodeGenState -> CgBindings
forall a b. (a -> b) -> a -> b
$ CodeGenState
final_state
              used_info :: [CmmInfoTable]
used_info = OrdList CmmInfoTable -> [CmmInfoTable]
forall a. OrdList a -> [a]
fromOL (OrdList CmmInfoTable -> [CmmInfoTable])
-> (CodeGenState -> OrdList CmmInfoTable)
-> CodeGenState
-> [CmmInfoTable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenState -> OrdList CmmInfoTable
codegen_used_info (CodeGenState -> [CmmInfoTable]) -> CodeGenState -> [CmmInfoTable]
forall a b. (a -> b) -> a -> b
$ CodeGenState
final_state

        ; !CStub
foreign_stub <- FCode CStub -> Stream IO CmmGroup CStub
forall a. FCode a -> Stream IO CmmGroup a
cg ([CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub
initInfoTableProv [CmmInfoTable]
used_info InfoTableProvMap
ip_map Module
this_mod)

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

              !generatedInfo :: ModuleLFInfos
generatedInfo
                | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags
                = 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 key elt. UniqFM key elt -> [elt]
eltsUFM CgBindings
cg_id_infos))

        ; (CStub, ModuleLFInfos) -> Stream IO CmmGroup (CStub, ModuleLFInfos)
forall (m :: * -> *) a. Monad m => a -> m a
return (CStub
foreign_stub, ModuleLFInfos
generatedInfo)
        }

---------------------------------------------------------------
--      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 -> DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding Logger
logger TmpFs
tmpfs DynFlags
dflags = \case
    StgTopLifted (StgNonRec BinderP 'CodeGen
id GenStgRhs 'CodeGen
rhs) -> do
        let (CgIdInfo
info, FCode ()
fcode) = DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs DynFlags
dflags RecFlag
NonRecursive Id
BinderP 'CodeGen
id GenStgRhs 'CodeGen
rhs
        FCode ()
fcode
        CgIdInfo -> FCode ()
addBindC CgIdInfo
info

    StgTopLifted (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs) -> do
        let ([Id]
bndrs, [GenStgRhs 'CodeGen]
rhss) = [(Id, GenStgRhs 'CodeGen)] -> ([Id], [GenStgRhs 'CodeGen])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
        let pairs' :: [(Id, GenStgRhs 'CodeGen)]
pairs' = [Id] -> [GenStgRhs 'CodeGen] -> [(Id, GenStgRhs 'CodeGen)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs [GenStgRhs 'CodeGen]
rhss
            r :: [(CgIdInfo, FCode ())]
r = (Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ()))
-> [(Id, GenStgRhs 'CodeGen)] -> [(CgIdInfo, FCode ())]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs DynFlags
dflags RecFlag
Recursive) [(Id, 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 Id
id ByteString
str -> do
        let label :: CLabel
label = Name -> CLabel
mkBytesLabel (Id -> Name
idName Id
id)
        -- emit either a CmmString literal or dump the string in a file and emit a
        -- CmmFileEmbed literal.
        -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
        let isNCG :: Bool
isNCG    = DynFlags -> Backend
backend DynFlags
dflags Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
NCG
            isSmall :: Bool
isSmall  = 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
<= DynFlags -> Word
binBlobThreshold DynFlags
dflags
            asString :: Bool
asString = DynFlags -> Word
binBlobThreshold DynFlags
dflags Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 Bool -> Bool -> Bool
|| Bool
isSmall

            (CmmLit
lit,GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode)
decl) = if Bool -> Bool
not Bool
isNCG Bool -> Bool -> Bool
|| Bool
asString
              then CLabel
-> ByteString
-> (CmmLit, GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode))
forall (raw :: Bool) info stmt.
CLabel
-> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit CLabel
label ByteString
str
              else CLabel
-> String
-> (CmmLit, GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode))
forall (raw :: Bool) info stmt.
CLabel
-> String -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkFileEmbedLit CLabel
label (String
 -> (CmmLit,
     GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode)))
-> String
-> (CmmLit, GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode))
forall a b. (a -> b) -> a -> b
$ IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
                     String
bFile <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
".dat"
                     String -> ByteString -> IO ()
BS.writeFile String
bFile ByteString
str
                     String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
bFile
        GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode) -> FCode ()
emitDecl GenCmmDecl CmmStatics CmmTopInfo (GenCmmGraph CmmNode)
decl
        CgIdInfo -> FCode ()
addBindC (Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo (DynFlags -> Platform
targetPlatform DynFlags
dflags) Id
id LambdaFormInfo
mkLFStringLit CmmLit
lit)


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

cgTopRhs :: DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs DynFlags
dflags RecFlag
_rec Id
bndr (StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
mn [StgTickish]
_ts [StgArg]
args)
  = DynFlags
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon DynFlags
dflags Id
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 DynFlags
dflags RecFlag
rec Id
bndr (StgRhsClosure XRhsClosure 'CodeGen
fvs CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body)
  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
    Platform
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> GenStgExpr 'CodeGen
-> (CgIdInfo, FCode ())
cgTopRhsClosure (DynFlags -> Platform
targetPlatform DynFlags
dflags) RecFlag
rec Id
bndr CostCentreStack
cc UpdateFlag
upd_flag [Id]
[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
platform <- FCode Platform
getPlatform
       CLabel -> [CmmLit] -> FCode ()
emitRODataLits (Name -> CafInfo -> CLabel
mkLocalClosureTableLabel (TyCon -> Name
tyConName TyCon
tycon) CafInfo
NoCafRefs)
             [ CLabel -> WordOff -> CmmLit
CmmLabelOff (Name -> CafInfo -> CLabel
mkLocalClosureLabel (DataCon -> Name
dataConName DataCon
con) CafInfo
NoCafRefs)
                           (Platform -> DataCon -> WordOff
tagForCon Platform
platform DataCon
con)
             | DataCon
con <- TyCon -> [DataCon]
tyConDataCons TyCon
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  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )
        ; Profile
profile <- FCode Profile
getProfile
        ; Platform
platform <- FCode Platform
getPlatform
        ; let
            (WordOff
tot_wds, --  #ptr_wds + #nonptr_wds
             WordOff
ptr_wds) --  #ptr_wds
              = Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
mkVirtConstrSizes Profile
profile [NonVoid PrimRep]
arg_reps

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

            dyn_info_tbl :: CmmInfoTable
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 :: [NonVoid PrimRep]
            arg_reps :: [NonVoid PrimRep]
arg_reps = [ PrimRep -> NonVoid PrimRep
forall a. a -> NonVoid a
NonVoid 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)
                       , Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
rep_ty) ]

        ; Platform
-> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable Platform
platform CmmInfoTable
dyn_info_tbl Convention
NativeDirectCall [] (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
            -- 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 { FCode ()
tickyEnterDynCon
               ; CmmExpr -> FCode ()
ldvEnter (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg)
               ; WordOff -> FCode ()
tickyReturnOldCon ([NonVoid PrimRep] -> WordOff
forall (t :: * -> *) a. Foldable t => t a -> WordOff
length [NonVoid PrimRep]
arg_reps)
               ; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ [CmmExpr] -> FCode ReturnKind
emitReturn [Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg) (Platform -> DataCon -> WordOff
tagForCon Platform
platform DataCon
data_con)]
               }
                    -- The case continuation code expects a tagged pointer
        }