module GHC.StgToCmm ( codeGen ) where
#include "HsVersions.h"
import GHC.Prelude as Prelude
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.Hpc
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Types (ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Stg.Syntax
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Driver.Types
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Data.Stream
import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
import GHC.SysTools.FileCleanup
import GHC.Types.Unique.FM
import GHC.Types.Name.Env
import GHC.Data.OrdList
import GHC.Cmm.Graph
import Data.IORef
import Control.Monad (when,void)
import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
codeGen :: DynFlags
-> Module
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ModuleLFInfos
codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
= do {
; cgref <- liftIO $ newIORef =<< initC
; let cg :: FCode () -> Stream IO CmmGroup ()
cg fcode = do
cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode)
writeIORef cgref $! st'{ cgs_tops = nilOL,
cgs_stmts = mkNop }
return a
yield cmm
; cg (mkModuleInit cost_centre_info this_mod hpc_info)
; mapM_ (cg . cgTopBinding dflags) stg_binds
; let do_tycon tycon = do
when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
mapM_ (cg . cgDataCon) (tyConDataCons tycon)
; mapM_ do_tycon data_tycons
; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
; let extractInfo info = (name, lf)
where
!name = idName (cg_id info)
!lf = cg_lf info
!generatedInfo
| gopt Opt_OmitInterfacePragmas dflags
= emptyNameEnv
| otherwise
= mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))
; return generatedInfo
}
cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
= do { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs
; fcode
; addBindC info
}
cgTopBinding dflags (StgTopLifted (StgRec pairs))
= do { let (bndrs, rhss) = unzip pairs
; let pairs' = zip bndrs rhss
r = unzipWith (cgTopRhs dflags Recursive) pairs'
(infos, fcodes) = unzip r
; addBindsC infos
; sequence_ fcodes
}
cgTopBinding dflags (StgTopStringLit id str) = do
let label = mkBytesLabel (idName id)
let isNCG = hscTarget dflags == HscAsm
isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags
asString = binBlobThreshold dflags == 0 || isSmall
(lit,decl) = if not isNCG || asString
then mkByteStringCLit label str
else mkFileEmbedLit label $ unsafePerformIO $ do
bFile <- newTempName dflags TFL_CurrentModule ".dat"
BS.writeFile bFile str
return bFile
emitDecl decl
addBindC (litIdInfo dflags id mkLFStringLit lit)
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
= ASSERT(isEmptyDVarSet fvs)
cgTopRhsClosure dflags rec bndr cc upd_flag args body
mkModuleInit
:: CollectedCCs
-> Module
-> HpcInfo
-> FCode ()
mkModuleInit cost_centre_info this_mod hpc_info
= do { initHpc this_mod hpc_info
; initCostCentres cost_centre_info
}
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon tycon
= do dflags <- getDynFlags
emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
(tagForCon dflags con)
| con <- tyConDataCons tycon]
cgDataCon :: DataCon -> FCode ()
cgDataCon data_con
= do { dflags <- getDynFlags
; platform <- getPlatform
; let
(tot_wds,
ptr_wds)
= mkVirtConstrSizes dflags arg_reps
nonptr_wds = tot_wds ptr_wds
dyn_info_tbl =
mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
arg_reps :: [NonVoid PrimRep]
arg_reps = [ NonVoid rep_ty
| ty <- dataConRepArgTys data_con
, rep_ty <- typePrimRep (scaledThing ty)
, not (isVoidRep rep_ty) ]
; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
do { tickyEnterDynCon
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_reps)
; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)]
}
}