{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
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
-> [CgStgTopBinding]
-> HpcInfo
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
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 {
; 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) =
if stgToCmmObjectDeterminism cfg
then detRenameCmmGroup rnm0 cmm
else (rnm0, removeDeterm cmm)
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
; let do_tycon TyCon
tycon = do
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)
(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
; 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
; 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)
}
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)
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 ())
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)
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
$
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
mkModuleInit
:: CollectedCCs
-> 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
}
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 ()
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)
= 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
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 [] $
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)]
}
}