module GHC.StgToCmm ( codeGen ) where
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.Config
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.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.Plain
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.IORef
import GHC.Utils.Panic (assertPpr)
codeGen :: Logger
-> TmpFs
-> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ModuleLFInfos
codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
cost_centre_info stg_binds hpc_info
= do {
; cgref <- liftIO $ initC >>= \s -> newIORef s
; let cg :: FCode a -> Stream IO CmmGroup a
cg fcode = do
(a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
let fstate = initFCodeState $ stgToCmmPlatform cfg
let (a,st') = runC cfg fstate st (getCmm fcode)
writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
return a
yield cmm
return a
; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)
; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
; let do_tycon tycon = do
when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
; mapM_ do_tycon data_tycons
; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)
; final_state <- liftIO (readIORef cgref)
; let cg_id_infos = cgs_binds final_state
; let extractInfo info = (name, lf)
where
!name = idName (cg_id info)
!lf = cg_lf info
!generatedInfo
| stgToCmmOmitIfPragmas cfg
= emptyNameEnv
| otherwise
= mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
; return generatedInfo
}
cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()
cgTopBinding logger tmpfs cfg = \case
StgTopLifted (StgNonRec id rhs) -> do
let (info, fcode) = cgTopRhs cfg NonRecursive id rhs
fcode
addBindC info
StgTopLifted (StgRec pairs) -> do
let (bndrs, rhss) = unzip pairs
let pairs' = zip bndrs rhss
r = unzipWith (cgTopRhs cfg Recursive) pairs'
(infos, fcodes) = unzip r
addBindsC infos
sequence_ fcodes
StgTopStringLit id str -> do
let label = mkBytesLabel (idName id)
let asString = case stgToCmmBinBlobThresh cfg of
Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold
Nothing -> True
(lit,decl) = if asString
then mkByteStringCLit label str
else mkFileEmbedLit label $ unsafePerformIO $ do
bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat"
BS.writeFile bFile str
return bFile
emitDecl decl
addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit)
cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args)
= cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args)
cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)
= assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $
cgTopRhsClosure (stgToCmmPlatform cfg) 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 platform <- getPlatform
emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)
(tagForCon platform con)
| con <- tyConDataCons tycon]
cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon mn data_con
= do { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))
; profile <- getProfile
; platform <- getPlatform
; let
(tot_wds,
ptr_wds)
= mkVirtConstrSizes profile arg_reps
nonptr_wds = tot_wds ptr_wds
dyn_info_tbl =
mkDataConInfoTable profile data_con mn 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 platform dyn_info_tbl NativeDirectCall [] $
do { tickyEnterDynCon
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_reps)
; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]
}
}