{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
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
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup (CStub, ModuleLFInfos)
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 {
; IORef CodeGenState
cgref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO CgState
initC forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CgState
s -> forall a. a -> IO (IORef a)
newIORef (OrdList CmmInfoTable -> CgState -> CodeGenState
CodeGenState 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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger DynFlags
dflags (String -> SDoc
text String
"STG -> Cmm") (seq :: forall a b. a -> b -> b
`seq` ()) forall a b. (a -> b) -> a -> b
$ do
CodeGenState OrdList CmmInfoTable
ts CgState
st <- forall a. IORef a -> IO a
readIORef IORef CodeGenState
cgref
let ((a, CmmGroup)
a,CgState
st') = forall a. DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
this_mod CgState
st (forall a. FCode a -> FCode (a, CmmGroup)
getCmm FCode a
fcode)
let !used_info :: OrdList CmmInfoTable
used_info
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags = forall a. [a] -> OrdList a
toOL (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a (n :: Extensibility -> Extensibility -> *).
GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (forall a b. (a, b) -> b
snd (a, CmmGroup)
a)) forall a. Monoid a => a -> a -> a
`mappend` OrdList CmmInfoTable
ts
| Bool
otherwise = forall a. Monoid a => a
mempty
forall a. IORef a -> a -> IO ()
writeIORef IORef CodeGenState
cgref forall a b. (a -> b) -> a -> b
$!
OrdList CmmInfoTable -> CgState -> CodeGenState
CodeGenState OrdList CmmInfoTable
used_info
(CgState
st'{ cgs_tops :: OrdList CmmDecl
cgs_tops = forall a. OrdList a
nilOL,
cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop
})
forall (m :: * -> *) a. Monad m => a -> m a
return (a, CmmGroup)
a
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
yield CmmGroup
cmm
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
; forall a. FCode a -> Stream IO CmmGroup a
cg (CollectedCCs -> Module -> HpcInfo -> FCode ()
mkModuleInit CollectedCCs
cost_centre_info Module
this_mod HpcInfo
hpc_info)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. FCode a -> Stream IO CmmGroup a
cg 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
; let do_tycon :: TyCon -> Stream IO CmmGroup ()
do_tycon TyCon
tycon = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isEnumerationTyCon TyCon
tycon) forall a b. (a -> b) -> a -> b
$ forall a. FCode a -> Stream IO CmmGroup a
cg (TyCon -> FCode ()
cgEnumerationTyCon TyCon
tycon)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. FCode a -> Stream IO CmmGroup a
cg forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon ConInfoTableLocation
DefinitionSite) (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)
; 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
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(DataCon
dc, NonEmpty (WordOff, Maybe (RealSrcSpan, String))
ns) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (WordOff, Maybe (RealSrcSpan, String))
ns forall a b. (a -> b) -> a -> b
$ \(WordOff
k, Maybe (RealSrcSpan, String)
_ss) -> forall a. FCode a -> Stream IO CmmGroup a
cg (ConInfoTableLocation -> DataCon -> FCode ()
cgDataCon (Module -> WordOff -> ConInfoTableLocation
UsageSite Module
this_mod WordOff
k) DataCon
dc)) (forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM
DataCon (DataCon, NonEmpty (WordOff, Maybe (RealSrcSpan, String)))
denv)
; CodeGenState
final_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef CodeGenState
cgref)
; let cg_id_infos :: CgBindings
cg_id_infos = CgState -> CgBindings
cgs_binds forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenState -> CgState
codegen_state forall a b. (a -> b) -> a -> b
$ CodeGenState
final_state
used_info :: [CmmInfoTable]
used_info = forall a. OrdList a -> [a]
fromOL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenState -> OrdList CmmInfoTable
codegen_used_info forall a b. (a -> b) -> a -> b
$ CodeGenState
final_state
; !CStub
foreign_stub <- forall a. FCode a -> Stream IO CmmGroup a
cg ([CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub
initInfoTableProv [CmmInfoTable]
used_info InfoTableProvMap
ip_map Module
this_mod)
; 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
= forall a. NameEnv a
emptyNameEnv
| Bool
otherwise
= forall a. [(Name, a)] -> NameEnv a
mkNameEnv (forall a b. (a -> b) -> [a] -> [b]
Prelude.map CgIdInfo -> (Name, LambdaFormInfo)
extractInfo (forall key elt. UniqFM key elt -> [elt]
eltsUFM CgBindings
cg_id_infos))
; forall (m :: * -> *) a. Monad m => a -> m a
return (CStub
foreign_stub, ModuleLFInfos
generatedInfo)
}
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 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
let pairs' :: [(Id, GenStgRhs 'CodeGen)]
pairs' = forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs [GenStgRhs 'CodeGen]
rhss
r :: [(CgIdInfo, FCode ())]
r = 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode ())]
r
[CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
infos
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)
let isNCG :: Bool
isNCG = DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
NCG
isSmall :: Bool
isSmall = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> WordOff
BS.length ByteString
str) forall a. Ord a => a -> a -> Bool
<= DynFlags -> Word
binBlobThreshold DynFlags
dflags
asString :: Bool
asString = DynFlags -> Word
binBlobThreshold DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Word
0 Bool -> Bool -> Bool
|| Bool
isSmall
(CmmLit
lit,CmmDecl
decl) = if Bool -> Bool
not Bool
isNCG Bool -> Bool -> Bool
|| Bool
asString
then forall (raw :: Bool) info stmt.
CLabel
-> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit CLabel
label ByteString
str
else forall (raw :: Bool) info stmt.
CLabel
-> String -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkFileEmbedLit CLabel
label forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO 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
forall (m :: * -> *) a. Monad m => a -> m a
return String
bFile
CmmDecl -> FCode ()
emitDecl CmmDecl
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 ())
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)
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)
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 [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
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 ()
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,
WordOff
ptr_wds)
= Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
mkVirtConstrSizes Profile
profile [NonVoid PrimRep]
arg_reps
nonptr_wds :: WordOff
nonptr_wds = WordOff
tot_wds 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
arg_reps :: [NonVoid PrimRep]
arg_reps :: [NonVoid PrimRep]
arg_reps = [ 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]
typePrimRep (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 [] forall a b. (a -> b) -> a -> b
$
do { FCode ()
tickyEnterDynCon
; CmmExpr -> FCode ()
ldvEnter (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg)
; WordOff -> FCode ()
tickyReturnOldCon (forall (t :: * -> *) a. Foldable t => t a -> WordOff
length [NonVoid PrimRep]
arg_reps)
; forall (f :: * -> *) a. Functor f => f a -> f ()
void 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)]
}
}