{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
module GHC.StgToJS.CodeGen
( stgToJS
)
where
import GHC.Prelude
import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js))
import GHC.JS.Ppr
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.JS.Transform
import GHC.StgToJS.Arg
import GHC.StgToJS.Sinker
import GHC.StgToJS.Types
import qualified GHC.StgToJS.Object as Object
import GHC.StgToJS.StgUtils
import GHC.StgToJS.CoreUtils
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
-> [Char]
-> IO ()
stgToJS Logger
logger StgToJSConfig
config [CgStgTopBinding]
stg_binds0 Module
this_mod [SptEntry]
spt_entries ForeignStubs
foreign_stubs CollectedCCs
cccs [Char]
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
(Deps
deps,[LinkableUnit]
lus) <- StgToJSConfig
-> Module
-> UniqFM Id CgStgExpr
-> G (Deps, [LinkableUnit])
-> IO (Deps, [LinkableUnit])
forall a.
StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
runG StgToJSConfig
config Module
this_mod UniqFM Id CgStgExpr
unfloated_binds (G (Deps, [LinkableUnit]) -> IO (Deps, [LinkableUnit]))
-> G (Deps, [LinkableUnit]) -> IO (Deps, [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
[LinkableUnit]
lus <- (() :: Constraint) =>
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
deps <- (() :: Constraint) => Module -> [LinkableUnit] -> G Deps
Module -> [LinkableUnit] -> G Deps
genDependencyData Module
this_mod [LinkableUnit]
lus
(Deps, [LinkableUnit]) -> G (Deps, [LinkableUnit])
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Deps
deps,[LinkableUnit]
lus)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_js) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_js [Char]
"JavaScript code" DumpFormat
FormatJS
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((LinkableUnit -> SDoc) -> [LinkableUnit] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> SDoc
docToSDoc (Doc -> SDoc) -> (LinkableUnit -> Doc) -> LinkableUnit -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStat -> Doc
forall a. JsToDoc a => a -> Doc
jsToDoc (JStat -> Doc) -> (LinkableUnit -> JStat) -> LinkableUnit -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjUnit -> JStat
oiStat (ObjUnit -> JStat)
-> (LinkableUnit -> ObjUnit) -> LinkableUnit -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkableUnit -> ObjUnit
luObjUnit) [LinkableUnit]
lus)
BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
BinHandle -> ModuleName -> Deps -> [ObjUnit] -> IO ()
Object.putObject BinHandle
bh (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) Deps
deps ((LinkableUnit -> ObjUnit) -> [LinkableUnit] -> [ObjUnit]
forall a b. (a -> b) -> [a] -> [b]
map LinkableUnit -> ObjUnit
luObjUnit [LinkableUnit]
lus)
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
output_fn)
BinHandle -> [Char] -> IO ()
writeBinMem BinHandle
bh [Char]
output_fn
genUnits :: HasDebugCallStack
=> Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits :: (() :: Constraint) =>
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits Module
m [CgStgTopBinding]
ss [SptEntry]
spt_entries ForeignStubs
foreign_stubs = do
LinkableUnit
gbl <- G LinkableUnit
(() :: Constraint) => G LinkableUnit
generateGlobalBlock
LinkableUnit
exports <- G LinkableUnit
(() :: Constraint) => G LinkableUnit
generateExportsBlock
[LinkableUnit]
others <- Int -> [CgStgTopBinding] -> G [LinkableUnit]
(() :: Constraint) => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go Int
2 [CgStgTopBinding]
ss
[LinkableUnit] -> G [LinkableUnit]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LinkableUnit
gblLinkableUnit -> [LinkableUnit] -> [LinkableUnit]
forall a. a -> [a] -> [a]
:LinkableUnit
exportsLinkableUnit -> [LinkableUnit] -> [LinkableUnit]
forall a. a -> [a] -> [a]
:[LinkableUnit]
others)
where
go :: HasDebugCallStack
=> Int
-> [CgStgTopBinding]
-> G [LinkableUnit]
go :: (() :: Constraint) => 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
Maybe LinkableUnit
mlu <- (() :: Constraint) =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
x Int
n
[LinkableUnit]
lus <- Int -> [CgStgTopBinding] -> G [LinkableUnit]
(() :: Constraint) => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [CgStgTopBinding]
xs
[LinkableUnit] -> G [LinkableUnit]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LinkableUnit]
-> (LinkableUnit -> [LinkableUnit])
-> Maybe LinkableUnit
-> [LinkableUnit]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [LinkableUnit]
lus (LinkableUnit -> [LinkableUnit] -> [LinkableUnit]
forall a. a -> [a] -> [a]
:[LinkableUnit]
lus) Maybe LinkableUnit
mlu)
generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
generateGlobalBlock :: (() :: Constraint) => G LinkableUnit
generateGlobalBlock = do
[JStat]
glbl <- (GenState -> [JStat]) -> StateT GenState IO [JStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> [JStat]
gsGlobal
JStat
staticInit <-
[SptEntry] -> G JStat
initStaticPtrs [SptEntry]
spt_entries
let stat :: JStat
stat = (
Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ Module -> Int -> FastString
modulePrefix Module
m Int
1)
(JStat -> JStat) -> JStat -> JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> [JStat]
forall a. [a] -> [a]
reverse [JStat]
glbl) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
staticInit)
let syms :: [FastString]
syms = [Module -> FastString
moduleGlobalSymbol Module
m]
let oi :: ObjUnit
oi = ObjUnit
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = []
, oiStatic :: [StaticInfo]
oiStatic = []
, oiStat :: JStat
oiStat = JStat
stat
, oiRaw :: ByteString
oiRaw = ByteString
forall a. Monoid a => a
mempty
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = []
}
let lu :: LinkableUnit
lu = LinkableUnit
{ luObjUnit :: ObjUnit
luObjUnit = ObjUnit
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 = []
}
LinkableUnit -> G LinkableUnit
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkableUnit
lu
generateExportsBlock :: HasDebugCallStack => G LinkableUnit
generateExportsBlock :: (() :: Constraint) => 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 = ([Char] -> Unique) -> [[Char]] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Unique
mkUniqueDep ([Char] -> [[Char]]
lines ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext SDoc
f_hdr)
mkUniqueDep :: [Char] -> Unique
mkUniqueDep (Char
tag:[Char]
xs) = Char -> Int -> Unique
mkUnique Char
tag ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
xs)
mkUniqueDep [] = [Char] -> Unique
forall a. HasCallStack => [Char] -> a
panic [Char]
"mkUniqueDep"
let syms :: [FastString]
syms = [Module -> FastString
moduleExportsSymbol Module
m]
let raw :: ByteString
raw = [Char] -> ByteString
utf8EncodeByteString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext SDoc
f_c
let oi :: ObjUnit
oi = ObjUnit
{ 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
{ luObjUnit :: ObjUnit
luObjUnit = ObjUnit
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 :: (() :: Constraint) =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
top_bind Int
n = case CgStgTopBinding
top_bind of
StgTopStringLit Id
bnd ByteString
str -> do
[Ident]
bids <- Id -> G [Ident]
identsForId Id
bnd
case [Ident]
bids of
[(TxtI FastString
b1t),(TxtI 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
[JStat]
_extraTl <- (GenState -> [JStat]) -> StateT GenState IO [JStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [JStat]
ggsToplevelStats (GenGroupState -> [JStat])
-> (GenState -> GenGroupState) -> GenState -> [JStat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
[StaticInfo]
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 body :: JStat
body = JStat
forall a. Monoid a => a
mempty
let stat :: JStat
stat = Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ Module -> Int -> FastString
modulePrefix Module
m Int
n) JStat
body
let ids :: [Id]
ids = [Id
bnd]
[FastString]
syms <- (\(TxtI FastString
i) -> [FastString
i]) (Ident -> [FastString])
-> StateT GenState IO Ident -> StateT GenState IO [FastString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
bnd
let oi :: ObjUnit
oi = ObjUnit
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = []
, oiStatic :: [StaticInfo]
oiStatic = [StaticInfo]
si
, oiStat :: JStat
oiStat = JStat
stat
, oiRaw :: ByteString
oiRaw = ByteString
""
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = []
}
let lu :: LinkableUnit
lu = LinkableUnit
{ luObjUnit :: ObjUnit
luObjUnit = ObjUnit
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 = []
}
Maybe LinkableUnit -> G (Maybe LinkableUnit)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LinkableUnit -> Maybe LinkableUnit
forall a. a -> Maybe a
Just LinkableUnit
lu)
[Ident]
_ -> [Char] -> G (Maybe LinkableUnit)
forall a. HasCallStack => [Char] -> a
panic [Char]
"generateBlock: invalid size"
StgTopLifted GenStgBinding 'CodeGen
decl -> do
JStat
tl <- GenStgBinding 'CodeGen -> G JStat
genToplevel GenStgBinding 'CodeGen
decl
[JStat]
extraTl <- (GenState -> [JStat]) -> StateT GenState IO [JStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [JStat]
ggsToplevelStats (GenGroupState -> [JStat])
-> (GenState -> GenGroupState) -> GenState -> [JStat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
[ClosureInfo]
ci <- (GenState -> [ClosureInfo]) -> StateT GenState IO [ClosureInfo]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [ClosureInfo]
ggsClosureInfo (GenGroupState -> [ClosureInfo])
-> (GenState -> GenGroupState) -> GenState -> [ClosureInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
[StaticInfo]
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)
UniqFM Id CgStgExpr
unf <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
Set OtherSymb
extraDeps <- (GenState -> Set OtherSymb) -> StateT GenState IO (Set OtherSymb)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> Set OtherSymb
ggsExtraDeps (GenGroupState -> Set OtherSymb)
-> (GenState -> GenGroupState) -> GenState -> Set OtherSymb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
[ForeignJSRef]
fRefs <- (GenState -> [ForeignJSRef]) -> StateT GenState IO [ForeignJSRef]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [ForeignJSRef]
ggsForeignRefs (GenGroupState -> [ForeignJSRef])
-> (GenState -> GenGroupState) -> GenState -> [ForeignJSRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
G ()
resetGroup
let allDeps :: [Id]
allDeps = UniqFM Id CgStgExpr -> GenStgBinding 'CodeGen -> [Id]
collectIds UniqFM Id CgStgExpr
unf GenStgBinding 'CodeGen
decl
topDeps :: [Id]
topDeps = GenStgBinding 'CodeGen -> [Id]
collectTopIds GenStgBinding 'CodeGen
decl
required :: Bool
required = GenStgBinding 'CodeGen -> Bool
hasExport GenStgBinding 'CodeGen
decl
stat :: JStat
stat =
Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ Module -> Int -> FastString
modulePrefix Module
m Int
n)
(JStat -> JStat) -> JStat -> JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> [JStat]
forall a. [a] -> [a]
reverse [JStat]
extraTl) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
tl
[FastString]
syms <- (Id -> StateT GenState IO FastString)
-> [Id] -> StateT GenState IO [FastString]
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 ((Ident -> FastString)
-> StateT GenState IO Ident -> StateT GenState IO FastString
forall a b.
(a -> b) -> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TxtI FastString
i) -> FastString
i) (StateT GenState IO Ident -> StateT GenState IO FastString)
-> (Id -> StateT GenState IO Ident)
-> Id
-> StateT GenState IO FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> StateT GenState IO Ident
identForId) [Id]
topDeps
let oi :: ObjUnit
oi = ObjUnit
{ oiSymbols :: [FastString]
oiSymbols = [FastString]
syms
, oiClInfo :: [ClosureInfo]
oiClInfo = [ClosureInfo]
ci
, oiStatic :: [StaticInfo]
oiStatic = [StaticInfo]
si
, oiStat :: JStat
oiStat = JStat
stat
, oiRaw :: ByteString
oiRaw = ByteString
""
, oiFExports :: [ExpFun]
oiFExports = []
, oiFImports :: [ForeignJSRef]
oiFImports = [ForeignJSRef]
fRefs
}
let lu :: LinkableUnit
lu = LinkableUnit
{ luObjUnit :: ObjUnit
luObjUnit = ObjUnit
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
}
Maybe LinkableUnit -> G (Maybe LinkableUnit)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LinkableUnit -> G (Maybe LinkableUnit))
-> Maybe LinkableUnit -> G (Maybe LinkableUnit)
forall a b. (a -> b) -> a -> b
$! [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
topDeps (Any -> Any) -> Maybe LinkableUnit -> Maybe LinkableUnit
forall a b. a -> b -> b
`seq` [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
allDeps (Any -> Any) -> Maybe LinkableUnit -> Maybe LinkableUnit
forall a b. a -> b -> b
`seq` LinkableUnit -> Maybe LinkableUnit
forall a. a -> Maybe a
Just LinkableUnit
lu
modulePrefix :: Module -> Int -> FastString
modulePrefix :: Module -> Int -> FastString
modulePrefix Module
m Int
n =
let encMod :: [Char]
encMod = [Char] -> [Char]
zEncodeString ([Char] -> [Char]) -> (Module -> [Char]) -> Module -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString (ModuleName -> [Char])
-> (Module -> ModuleName) -> Module -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> [Char]) -> Module -> [Char]
forall a b. (a -> b) -> a -> b
$ Module
m
in [Char] -> FastString
mkFastString ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ [Char]
"h$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
encMod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_id_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
genToplevel :: CgStgBinding -> G JStat
genToplevel :: GenStgBinding 'CodeGen -> G JStat
genToplevel (StgNonRec BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs) = Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelDecl Id
BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs
genToplevel (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs) =
[JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'CodeGen) -> G JStat)
-> [(Id, GenStgRhs 'CodeGen)] -> StateT GenState IO [JStat]
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 JStat
genToplevelDecl Id
bndr GenStgRhs 'CodeGen
rhs) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
genToplevelDecl :: Id -> CgStgRhs -> G JStat
genToplevelDecl :: Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelDecl Id
i GenStgRhs 'CodeGen
rhs = do
JStat
s1 <- G JStat -> G JStat
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs)
JStat
s2 <- G JStat -> G JStat
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs)
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s1 JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
s2)
genToplevelConEntry :: Id -> CgStgRhs -> G JStat
genToplevelConEntry :: Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs = case GenStgRhs 'CodeGen
rhs of
StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
_mu [StgTickish]
_ts [StgArg]
_args
| Id -> Bool
isDataConWorkId Id
i
-> (() :: Constraint) => Id -> DataCon -> LiveVars -> G JStat
Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
con (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)
StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
_args CgStgExpr
_body
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
i
-> (() :: Constraint) => Id -> DataCon -> LiveVars -> G JStat
Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
dc (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)
GenStgRhs 'CodeGen
_ -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo :: (() :: Constraint) => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
d LiveVars
l = do
Ident
ei <- Id -> StateT GenState IO Ident
identForDataConEntryId Id
i
CIStatic
sr <- LiveVars -> G CIStatic
genStaticRefs LiveVars
l
ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$ Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
(Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV])
([Char] -> FastString
mkFastString ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
d))
([VarType] -> CILayout
fixedLayout ([VarType] -> CILayout) -> [VarType] -> CILayout
forall a b. (a -> b) -> a -> b
$ (UnaryType -> VarType) -> [UnaryType] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => UnaryType -> VarType
UnaryType -> VarType
uTypeVt [UnaryType]
fields)
(Int -> CIType
CICon (Int -> CIType) -> Int -> CIType
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
d)
CIStatic
sr
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ei Ident -> JExpr -> JStat
||= JExpr
mkDataEntry)
where
fields :: [UnaryType]
fields = (Scaled UnaryType -> [UnaryType])
-> [Scaled UnaryType] -> [UnaryType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PrimRep -> UnaryType) -> [PrimRep] -> [UnaryType]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> UnaryType
primRepToType ([PrimRep] -> [UnaryType])
-> (Scaled UnaryType -> [PrimRep])
-> Scaled UnaryType
-> [UnaryType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => UnaryType -> [PrimRep]
UnaryType -> [PrimRep]
typePrimRep (UnaryType -> [PrimRep])
-> (Scaled UnaryType -> UnaryType) -> Scaled UnaryType -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnaryType -> UnaryType
unwrapType (UnaryType -> UnaryType)
-> (Scaled UnaryType -> UnaryType) -> Scaled UnaryType -> UnaryType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled UnaryType -> UnaryType
forall a. Scaled a -> a
scaledThing)
(DataCon -> [Scaled UnaryType]
dataConRepArgTys DataCon
d)
mkDataEntry :: JExpr
mkDataEntry :: JExpr
mkDataEntry = JVal -> JExpr
ValExpr (JVal -> JExpr) -> JVal -> JExpr
forall a b. (a -> b) -> a -> b
$ [Ident] -> JStat -> JVal
JFunc [] JStat
returnStack
genToplevelRhs :: Id -> CgStgRhs -> G JStat
genToplevelRhs :: Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs = case GenStgRhs 'CodeGen
rhs of
StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [StgTickish]
_tys [StgArg]
args -> do
Ident
ii <- Id -> StateT GenState IO Ident
identForId Id
i
(() :: Constraint) =>
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic Ident
ii CostCentreStack
cc DataCon
con [StgArg]
args
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
args CgStgExpr
body -> do
eid :: Ident
eid@(TxtI FastString
eidt) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
(TxtI FastString
idt) <- Id -> StateT GenState IO Ident
identForId Id
i
JStat
body <- (() :: Constraint) =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody (Id -> ExprCtx
initExprCtx Id
i) Id
i StgReg
R2 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body
[GlobalOcc]
global_occs <- JStat -> G [GlobalOcc]
globalOccs (Maybe FastString -> JStat -> JStat
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
"ghcjs_tmp_sat_") JStat
body)
let lidents :: [Ident]
lidents = (GlobalOcc -> Ident) -> [GlobalOcc] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Ident
global_ident [GlobalOcc]
global_occs
let lids :: [Id]
lids = (GlobalOcc -> Id) -> [GlobalOcc] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Id
global_id [GlobalOcc]
global_occs
let lidents' :: [FastString]
lidents' = (Ident -> FastString) -> [Ident] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> FastString
identFS [Ident]
lidents
CIStaticRefs [FastString]
sr0 <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
let sri :: [FastString]
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 :: CIStatic
sr = [FastString] -> CIStatic
CIStaticRefs [FastString]
sri
CIType
et <- [Id] -> G CIType
(() :: Constraint) => [Id] -> G CIType
genEntryType [Id]
[BinderP 'CodeGen]
args
JStat
ll <- [Id] -> G JStat
loadLiveFun [Id]
lids
(StaticVal
static, CIRegs
regs, JStat
upd) <-
if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
then do
JStat
r <- G JStat
updateThunk
(StaticVal, CIRegs, JStat)
-> StateT GenState IO (StaticVal, CIRegs, JStat)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FastString, [StaticArg]) -> StaticVal
StaticThunk ((FastString, [StaticArg]) -> Maybe (FastString, [StaticArg])
forall a. a -> Maybe a
Just (FastString
eidt, (FastString -> StaticArg) -> [FastString] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> StaticArg
StaticObjArg [FastString]
lidents')), Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV],JStat
r)
else (StaticVal, CIRegs, JStat)
-> StateT GenState IO (StaticVal, CIRegs, JStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> [StaticArg] -> StaticVal
StaticFun FastString
eidt ((FastString -> StaticArg) -> [FastString] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> StaticArg
StaticObjArg [FastString]
lidents'),
(if [Ident] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
lidents then Int -> [VarType] -> CIRegs
CIRegs Int
1 ((Id -> [VarType]) -> [Id] -> [VarType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt [Id]
[BinderP 'CodeGen]
args)
else Int -> [VarType] -> CIRegs
CIRegs Int
0 (VarType
PtrV VarType -> [VarType] -> [VarType]
forall a. a -> [a] -> [a]
: (Id -> [VarType]) -> [Id] -> [VarType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt [Id]
[BinderP 'CodeGen]
args))
, JStat
forall a. Monoid a => a
mempty)
JStat
setcc <- JStat -> G JStat
forall m. Monoid m => m -> G m
ifProfiling (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$
if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
then JStat
enterCostCentreThunk
else CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
cc
ClosureInfo -> G ()
emitClosureInfo (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
eid
CIRegs
regs
FastString
idt
([VarType] -> CILayout
fixedLayout ([VarType] -> CILayout) -> [VarType] -> CILayout
forall a b. (a -> b) -> a -> b
$ (Id -> VarType) -> [Id] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => UnaryType -> VarType
UnaryType -> VarType
uTypeVt (UnaryType -> VarType) -> (Id -> UnaryType) -> Id -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> UnaryType
idType) [Id]
lids)
CIType
et
CIStatic
sr)
Maybe Ident
ccId <- CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
cc
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
idt StaticVal
static Maybe Ident
ccId
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ (Ident
eid Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] (JStat
ll JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
upd JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
setcc JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
body)))