{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.StgToJS.CodeGen
( stgToJS
)
where
import GHC.Prelude
import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js, Opt_D_dump_stg_from_js_sinker))
import GHC.JS.Ppr
import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.JS.Transform
import GHC.JS.Optimizer
import GHC.StgToJS.Arg
import GHC.StgToJS.Sinker.Sinker
import GHC.StgToJS.Types
import qualified GHC.StgToJS.Object as Object
import GHC.StgToJS.Utils
import GHC.StgToJS.Deps
import GHC.StgToJS.Expr
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.StaticPtr
import GHC.StgToJS.Symbols
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids
import GHC.Stg.Syntax
import GHC.Core.DataCon
import GHC.Core.TyCo.Rep (scaledThing)
import GHC.Unit.Module
import GHC.Linker.Types (SptEntry (..))
import GHC.Types.CostCentre
import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub)
import GHC.Types.RepType
import GHC.Types.Id
import GHC.Types.Unique
import GHC.Data.FastString
import GHC.Utils.Encoding
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Binary
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Utils.Outputable hiding ((<>))
import qualified Data.Set as S
import Data.Monoid
import Control.Monad
import System.Directory
import System.FilePath
stgToJS
:: Logger
-> StgToJSConfig
-> [CgStgTopBinding]
-> Module
-> [SptEntry]
-> ForeignStubs
-> CollectedCCs
-> FilePath
-> IO ()
stgToJS :: Logger
-> StgToJSConfig
-> [CgStgTopBinding]
-> Module
-> [SptEntry]
-> ForeignStubs
-> CollectedCCs
-> FilePath
-> IO ()
stgToJS Logger
logger StgToJSConfig
config [CgStgTopBinding]
stg_binds0 Module
this_mod [SptEntry]
spt_entries ForeignStubs
foreign_stubs CollectedCCs
cccs FilePath
output_fn = do
let (UniqFM Id CgStgExpr
unfloated_binds, [CgStgTopBinding]
stg_binds) = Module
-> [CgStgTopBinding] -> (UniqFM Id CgStgExpr, [CgStgTopBinding])
sinkPgm Module
this_mod [CgStgTopBinding]
stg_binds0
Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_from_js_sinker FilePath
"STG Optimized JS Sinker:" DumpFormat
FormatSTG
(StgPprOpts -> [CgStgTopBinding] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings (Bool -> StgPprOpts
StgPprOpts Bool
False) [CgStgTopBinding]
stg_binds)
(deps,lus) <- StgToJSConfig
-> Module
-> UniqFM Id CgStgExpr
-> G (BlockInfo, [LinkableUnit])
-> IO (BlockInfo, [LinkableUnit])
forall a.
StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
runG StgToJSConfig
config Module
this_mod UniqFM Id CgStgExpr
unfloated_binds (G (BlockInfo, [LinkableUnit]) -> IO (BlockInfo, [LinkableUnit]))
-> G (BlockInfo, [LinkableUnit]) -> IO (BlockInfo, [LinkableUnit])
forall a b. (a -> b) -> a -> b
$ do
G () -> G ()
forall m. Monoid m => G m -> G m
ifProfilingM (G () -> G ()) -> G () -> G ()
forall a b. (a -> b) -> a -> b
$ CollectedCCs -> G ()
initCostCentres CollectedCCs
cccs
lus <- HasDebugCallStack =>
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits Module
this_mod [CgStgTopBinding]
stg_binds [SptEntry]
spt_entries ForeignStubs
foreign_stubs
deps <- genDependencyData this_mod lus
pure (deps,lus)
when (logHasDumpFlag logger Opt_D_dump_js) $ do
putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
$ vcat (fmap (jsToDoc . oiStat . luObjBlock) lus)
bh <- openBinMem (4 * 1000)
Object.putObject bh (moduleName this_mod) deps (map luObjBlock lus)
createDirectoryIfMissing True (takeDirectory output_fn)
writeBinMem bh output_fn
genUnits :: HasDebugCallStack
=> Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits :: HasDebugCallStack =>
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits Module
m [CgStgTopBinding]
ss [SptEntry]
spt_entries ForeignStubs
foreign_stubs = do
gbl <- G LinkableUnit
HasDebugCallStack => G LinkableUnit
generateGlobalBlock
exports <- generateExportsBlock
others <- go 2 ss
pure (gbl:exports:others)
where
go :: HasDebugCallStack
=> Int
-> [CgStgTopBinding]
-> G [LinkableUnit]
go :: HasDebugCallStack => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go !Int
n = \case
[] -> [LinkableUnit] -> G [LinkableUnit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
(CgStgTopBinding
x:[CgStgTopBinding]
xs) -> do
mlu <- HasDebugCallStack =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
x Int
n
lus <- go (n+1) xs
return (maybe lus (:lus) mlu)
generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
generateGlobalBlock = do
glbl <- (GenState -> [JStgStat]) -> StateT GenState IO [JStgStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> [JStgStat]
gsGlobal
staticInit <-
initStaticPtrs spt_entries
let stat = ( JStgStat -> JStat
jStgStatToJS
(JStgStat -> JStat) -> JStgStat -> JStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> [JStgStat]
forall a. [a] -> [a]
reverse [JStgStat]
glbl) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
staticInit)
let opt_stat = JStat -> JStat
jsOptimize JStat
stat
let syms = [Module -> FastString
moduleGlobalSymbol Module
m]
let oi = ObjBlock
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = []
, oiStatic :: [StaticInfo]
oiStatic = []
, oiStat :: JStat
oiStat = JStat
opt_stat
, oiRaw :: ByteString
oiRaw = ByteString
forall a. Monoid a => a
mempty
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = []
}
let lu = LinkableUnit
{ luObjBlock :: ObjBlock
luObjBlock = ObjBlock
oi
, luIdExports :: [Id]
luIdExports = []
, luOtherExports :: [FastString]
luOtherExports = [FastString]
syms
, luIdDeps :: [Id]
luIdDeps = []
, luPseudoIdDeps :: [Unique]
luPseudoIdDeps = []
, luOtherDeps :: [OtherSymb]
luOtherDeps = []
, luRequired :: Bool
luRequired = Bool
False
, luForeignRefs :: [ForeignJSRef]
luForeignRefs = []
}
pure lu
generateExportsBlock :: HasDebugCallStack => G LinkableUnit
generateExportsBlock :: HasDebugCallStack => G LinkableUnit
generateExportsBlock = do
let (SDoc
f_hdr, SDoc
f_c) = case ForeignStubs
foreign_stubs of
ForeignStubs
NoStubs -> (SDoc
forall doc. IsOutput doc => doc
empty, SDoc
forall doc. IsOutput doc => doc
empty)
ForeignStubs CHeader
hdr CStub
c -> (CHeader -> SDoc
getCHeader CHeader
hdr, CStub -> SDoc
getCStub CStub
c)
unique_deps :: [Unique]
unique_deps = (FilePath -> Unique) -> [FilePath] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Unique
mkUniqueDep (FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
defaultSDocContext SDoc
f_hdr)
mkUniqueDep :: FilePath -> Unique
mkUniqueDep (Char
tag:FilePath
xs) = Char -> Word64 -> Unique
mkUnique Char
tag (FilePath -> Word64
forall a. Read a => FilePath -> a
read FilePath
xs)
mkUniqueDep [] = FilePath -> Unique
forall a. HasCallStack => FilePath -> a
panic FilePath
"mkUniqueDep"
let syms :: [FastString]
syms = [Module -> FastString
moduleExportsSymbol Module
m]
let raw :: ByteString
raw = FilePath -> ByteString
utf8EncodeByteString (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
defaultSDocContext SDoc
f_c
let oi :: ObjBlock
oi = ObjBlock
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = []
, oiStatic :: [StaticInfo]
oiStatic = []
, oiStat :: JStat
oiStat = JStat
forall a. Monoid a => a
mempty
, oiRaw :: ByteString
oiRaw = ByteString
raw
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = []
}
let lu :: LinkableUnit
lu = LinkableUnit
{ luObjBlock :: ObjBlock
luObjBlock = ObjBlock
oi
, luIdExports :: [Id]
luIdExports = []
, luOtherExports :: [FastString]
luOtherExports = [FastString]
syms
, luIdDeps :: [Id]
luIdDeps = []
, luPseudoIdDeps :: [Unique]
luPseudoIdDeps = [Unique]
unique_deps
, luOtherDeps :: [OtherSymb]
luOtherDeps = []
, luRequired :: Bool
luRequired = Bool
True
, luForeignRefs :: [ForeignJSRef]
luForeignRefs = []
}
LinkableUnit -> G LinkableUnit
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkableUnit
lu
generateBlock :: HasDebugCallStack
=> CgStgTopBinding
-> Int
-> G (Maybe LinkableUnit)
generateBlock :: HasDebugCallStack =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
top_bind Int
_n = case CgStgTopBinding
top_bind of
StgTopStringLit Id
bnd ByteString
str -> do
bids <- Id -> G [Ident]
identsForId Id
bnd
case bids of
[(Ident -> FastString
identFS -> FastString
b1t),(Ident -> FastString
identFS -> FastString
b2t)] -> do
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
b1t (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedString ByteString
str)) Maybe Ident
forall a. Maybe a
Nothing
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
b2t (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedStringOffset ByteString
str)) Maybe Ident
forall a. Maybe a
Nothing
si <- (GenState -> [StaticInfo]) -> StateT GenState IO [StaticInfo]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [StaticInfo]
ggsStatic (GenGroupState -> [StaticInfo])
-> (GenState -> GenGroupState) -> GenState -> [StaticInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
let ids = [Id
bnd]
syms <- (\(Ident -> FastString
identFS -> FastString
i) -> [FastString
i]) <$> identForId bnd
let oi = ObjBlock
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = []
, oiStatic :: [StaticInfo]
oiStatic = [StaticInfo]
si
, oiStat :: JStat
oiStat = JStat
forall a. Monoid a => a
mempty
, oiRaw :: ByteString
oiRaw = ByteString
""
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = []
}
let lu = LinkableUnit
{ luObjBlock :: ObjBlock
luObjBlock = ObjBlock
oi
, luIdExports :: [Id]
luIdExports = [Id]
ids
, luOtherExports :: [FastString]
luOtherExports = []
, luIdDeps :: [Id]
luIdDeps = []
, luPseudoIdDeps :: [Unique]
luPseudoIdDeps = []
, luOtherDeps :: [OtherSymb]
luOtherDeps = []
, luRequired :: Bool
luRequired = Bool
False
, luForeignRefs :: [ForeignJSRef]
luForeignRefs = []
}
pure (Just lu)
[Ident]
_ -> FilePath -> G (Maybe LinkableUnit)
forall a. HasCallStack => FilePath -> a
panic FilePath
"generateBlock: invalid size"
StgTopLifted GenStgBinding 'CodeGen
decl -> do
tl <- GenStgBinding 'CodeGen -> G JStgStat
genToplevel GenStgBinding 'CodeGen
decl
extraTl <- State.gets (ggsToplevelStats . gsGroup)
ci <- State.gets (ggsClosureInfo . gsGroup)
si <- State.gets (ggsStatic . gsGroup)
unf <- State.gets gsUnfloated
extraDeps <- State.gets (ggsExtraDeps . gsGroup)
fRefs <- State.gets (ggsForeignRefs . gsGroup)
resetGroup
let allDeps = UniqFM Id CgStgExpr -> GenStgBinding 'CodeGen -> [Id]
collectIds UniqFM Id CgStgExpr
unf GenStgBinding 'CodeGen
decl
topDeps = GenStgBinding 'CodeGen -> [Id]
collectTopIds GenStgBinding 'CodeGen
decl
required = GenStgBinding 'CodeGen -> Bool
hasExport GenStgBinding 'CodeGen
decl
stat = JStgStat -> JStat
jStgStatToJS
(JStgStat -> JStat) -> JStgStat -> JStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> [JStgStat]
forall a. [a] -> [a]
reverse [JStgStat]
extraTl) JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
tl
let opt_stat = JStat -> JStat
jsOptimize JStat
stat
syms <- mapM (fmap (\(Ident -> FastString
identFS -> FastString
i) -> FastString
i) . identForId) topDeps
let oi = ObjBlock
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = [ClosureInfo]
ci
, oiStatic :: [StaticInfo]
oiStatic = [StaticInfo]
si
, oiStat :: JStat
oiStat = JStat
opt_stat
, oiRaw :: ByteString
oiRaw = ByteString
""
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = [ForeignJSRef]
fRefs
}
let lu = LinkableUnit
{ luObjBlock :: ObjBlock
luObjBlock = ObjBlock
oi
, luIdExports :: [Id]
luIdExports = [Id]
topDeps
, luOtherExports :: [FastString]
luOtherExports = []
, luIdDeps :: [Id]
luIdDeps = [Id]
allDeps
, luPseudoIdDeps :: [Unique]
luPseudoIdDeps = []
, luOtherDeps :: [OtherSymb]
luOtherDeps = Set OtherSymb -> [OtherSymb]
forall a. Set a -> [a]
S.toList Set OtherSymb
extraDeps
, luRequired :: Bool
luRequired = Bool
required
, luForeignRefs :: [ForeignJSRef]
luForeignRefs = [ForeignJSRef]
fRefs
}
pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu
genToplevel :: CgStgBinding -> G JStgStat
genToplevel :: GenStgBinding 'CodeGen -> G JStgStat
genToplevel (StgNonRec BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs) = Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelDecl Id
BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs
genToplevel (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs) =
[JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'CodeGen) -> G JStgStat)
-> [(Id, GenStgRhs 'CodeGen)] -> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Id
bndr, GenStgRhs 'CodeGen
rhs) -> Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelDecl Id
bndr GenStgRhs 'CodeGen
rhs) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
genToplevelDecl :: Id -> CgStgRhs -> G JStgStat
genToplevelDecl :: Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelDecl Id
i GenStgRhs 'CodeGen
rhs = do
G () -> G ()
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G ()
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs)
G JStgStat -> G JStgStat
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs)
genToplevelConEntry :: Id -> CgStgRhs -> G ()
genToplevelConEntry :: Id -> GenStgRhs 'CodeGen -> G ()
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs = case GenStgRhs 'CodeGen
rhs of
StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
_mu [StgTickish]
_ts [StgArg]
_args Type
_typ
| Id -> Bool
isDataConWorkId Id
i
-> HasDebugCallStack => Id -> DataCon -> DIdSet -> G ()
Id -> DataCon -> DIdSet -> G ()
genSetConInfo Id
i DataCon
con (GenStgRhs 'CodeGen -> DIdSet
stgRhsLive GenStgRhs 'CodeGen
rhs)
StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
_args CgStgExpr
_body Type
_typ
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
i
-> HasDebugCallStack => Id -> DataCon -> DIdSet -> G ()
Id -> DataCon -> DIdSet -> G ()
genSetConInfo Id
i DataCon
dc (GenStgRhs 'CodeGen -> DIdSet
stgRhsLive GenStgRhs 'CodeGen
rhs)
GenStgRhs 'CodeGen
_ -> () -> G ()
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G ()
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> DIdSet -> G ()
genSetConInfo Id
i DataCon
d DIdSet
l = do
ei <- Id -> StateT GenState IO Ident
identForDataConEntryId Id
i
sr <- genStaticRefs l
let fields = (Scaled Type -> [JSRep]) -> [Scaled Type] -> [JSRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasDebugCallStack => Type -> [JSRep]
Type -> [JSRep]
typeJSRep (Type -> [JSRep])
-> (Scaled Type -> Type) -> Scaled Type -> [JSRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
unwrapType (Type -> Type) -> (Scaled Type -> Type) -> Scaled Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Type -> Type
forall a. Scaled a -> a
scaledThing)
(DataCon -> [Scaled Type]
dataConRepArgTys DataCon
d)
emitClosureInfo $ ClosureInfo
{ ciVar = ei
, ciRegs = CIRegs 0 [PtrV]
, ciName = mkFastString $ renderWithContext defaultSDocContext (ppr d)
, ciLayout = fixedLayout fields
, ciType = CICon $ dataConTag d
, ciStatic = sr
}
emitToplevel (mkDataEntry ei)
mkDataEntry :: Ident -> JStgStat
mkDataEntry :: Ident -> JStgStat
mkDataEntry Ident
i = Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
i [] JStgStat
returnStack
genToplevelRhs :: Id -> CgStgRhs -> G JStgStat
genToplevelRhs :: Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs = case GenStgRhs 'CodeGen
rhs of
StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [StgTickish]
_tys [StgArg]
args Type
_typ -> do
ii <- Id -> StateT GenState IO Ident
identForId Id
i
allocConStatic ii cc con args
return mempty
StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
args CgStgExpr
body Type
typ -> do
eid <- Id -> StateT GenState IO Ident
identForEntryId Id
i
idt <- identFS <$> identForId i
body <- genBody (initExprCtx i) R2 args body typ
global_occs <- globalOccs body
let eidt = Ident -> FastString
identFS Ident
eid
let lidents = (GlobalOcc -> Ident) -> [GlobalOcc] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Ident
global_ident [GlobalOcc]
global_occs
let lids = (GlobalOcc -> Id) -> [GlobalOcc] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Id
global_id [GlobalOcc]
global_occs
let lidents' = (Ident -> FastString) -> [Ident] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> FastString
identFS [Ident]
lidents
CIStaticRefs sr0 <- genStaticRefsRhs rhs
let sri = (FastString -> Bool) -> [FastString] -> [FastString]
forall a. (a -> Bool) -> [a] -> [a]
filter (FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FastString]
lidents') [FastString]
sr0
sr = [FastString] -> CIStatic
CIStaticRefs [FastString]
sri
et <- genEntryType args
ll <- loadLiveFun lids
(static, regs, upd) <-
if et == CIThunk
then do
r <- updateThunk
pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
else return (StaticFun eidt (map StaticObjArg lidents'),
(if null lidents then CIRegs 1 (concatMap idJSRep args)
else CIRegs 0 (PtrV : concatMap idJSRep args))
, mempty)
setcc <- ifProfiling $
if et == CIThunk
then enterCostCentreThunk
else enterCostCentreFun cc
emitClosureInfo $ ClosureInfo
{ ciVar = eid
, ciRegs = regs
, ciName = idt
, ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) lids
, ciType = et
, ciStatic = sr
}
ccId <- costCentreStackLbl cc
emitStatic idt static ccId
return $ (FuncStat eid [] (ll <> upd <> setcc <> body))