{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

-- | JavaScript code generator
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

-- | Code generator for JavaScript
stgToJS
  :: Logger
  -> StgToJSConfig
  -> [CgStgTopBinding]
  -> Module
  -> [SptEntry]
  -> ForeignStubs
  -> CollectedCCs
  -> FilePath -- ^ Output file name
  -> 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
    -- TODO: avoid top level lifting in core-2-core when the JS backend is
    -- enabled instead of undoing it here

    -- TODO: add dump pass for optimized STG ast for JS

  (Deps
deps,[LinkableUnit]
lus) <- forall a.
StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
runG StgToJSConfig
config Module
this_mod UniqFM Id CgStgExpr
unfloated_binds forall a b. (a -> b) -> a -> b
$ do
    forall m. Monoid m => G m -> G m
ifProfilingM forall a b. (a -> b) -> a -> b
$ CollectedCCs -> G ()
initCostCentres CollectedCCs
cccs
    [LinkableUnit]
lus  <- HasDebugCallStack =>
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits Module
this_mod [CgStgTopBinding]
stg_binds [SptEntry]
spt_entries ForeignStubs
foreign_stubs
    Deps
deps <- HasDebugCallStack => Module -> [LinkableUnit] -> G Deps
genDependencyData Module
this_mod [LinkableUnit]
lus
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Deps
deps,[LinkableUnit]
lus)

  -- Doc to dump when -ddump-js is enabled
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_js) 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
      forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> SDoc
docToSDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. JsToDoc a => a -> Doc
jsToDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjUnit -> JStat
oiStat forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkableUnit -> ObjUnit
luObjUnit) [LinkableUnit]
lus)

  -- Write the object file
  BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
4 forall a. Num a => a -> a -> a
* Int
1024 forall a. Num a => a -> a -> a
* Int
1000) -- a bit less than 4kB
  BinHandle -> ModuleName -> Deps -> [ObjUnit] -> IO ()
Object.putObject BinHandle
bh (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) Deps
deps (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



-- | Generate the ingredients for the linkable units for this module
genUnits :: HasDebugCallStack
         => Module
         -> [CgStgTopBinding]
         -> [SptEntry]
         -> ForeignStubs
         -> G [LinkableUnit] -- ^ the linkable units
genUnits :: HasDebugCallStack =>
Module
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
-> G [LinkableUnit]
genUnits Module
m [CgStgTopBinding]
ss [SptEntry]
spt_entries ForeignStubs
foreign_stubs = do
    LinkableUnit
gbl     <- HasDebugCallStack => G LinkableUnit
generateGlobalBlock
    LinkableUnit
exports <- HasDebugCallStack => G LinkableUnit
generateExportsBlock
    [LinkableUnit]
others  <- HasDebugCallStack => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go Int
2 [CgStgTopBinding]
ss
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (LinkableUnit
gblforall a. a -> [a] -> [a]
:LinkableUnit
exportsforall a. a -> [a] -> [a]
:[LinkableUnit]
others)
    where
      go :: HasDebugCallStack
         => Int                 -- the block we're generating (block 0 is the global unit for the module)
         -> [CgStgTopBinding]
         -> G [LinkableUnit]
      go :: HasDebugCallStack => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go !Int
n = \case
        []     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        (CgStgTopBinding
x:[CgStgTopBinding]
xs) -> do
          Maybe LinkableUnit
mlu <- HasDebugCallStack =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
x Int
n
          [LinkableUnit]
lus <- HasDebugCallStack => Int -> [CgStgTopBinding] -> G [LinkableUnit]
go (Int
nforall a. Num a => a -> a -> a
+Int
1) [CgStgTopBinding]
xs
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [LinkableUnit]
lus (forall a. a -> [a] -> [a]
:[LinkableUnit]
lus) Maybe LinkableUnit
mlu)

      --   Generate the global unit that all other blocks in the module depend on
      --   used for cost centres and static initializers
      --   the global unit has no dependencies, exports the moduleGlobalSymbol
      generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
      generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
generateGlobalBlock = do
        [JStat]
glbl <- 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 = ( -- O.optimize .
                     forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Module -> Int -> FastString
modulePrefix Module
m Int
1)
                   forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [JStat]
glbl) 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      = 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  = []
                  }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkableUnit
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            -> (forall doc. IsOutput doc => doc
empty, 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 = forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Unique
mkUniqueDep ([Char] -> [[Char]]
lines 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 (forall a. Read a => [Char] -> a
read [Char]
xs)
            mkUniqueDep []       = forall a. HasCallStack => [Char] -> a
panic [Char]
"mkUniqueDep"

        let syms :: [FastString]
syms = [Module -> FastString
moduleExportsSymbol Module
m]
        let raw :: ByteString
raw  = [Char] -> ByteString
utf8EncodeByteString 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     = 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  = []
                  }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkableUnit
lu

      --   Generate the linkable unit for one binding or group of
      --   mutually recursive bindings
      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
          [Ident]
bids <- Id -> G [Ident]
identsForId Id
bnd
          case [Ident]
bids of
            [(TxtI FastString
b1t),(TxtI FastString
b2t)] -> do
              -- [e1,e2] <- genLit (MachStr str)
              FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
b1t (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedString ByteString
str)) forall a. Maybe a
Nothing
              FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
b2t (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedStringOffset ByteString
str)) forall a. Maybe a
Nothing
              [JStat]
_extraTl   <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [JStat]
ggsToplevelStats forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
              [StaticInfo]
si        <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [StaticInfo]
ggsStatic forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
              let body :: JStat
body = forall a. Monoid a => a
mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
              let stat :: JStat
stat = forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (forall a. a -> Maybe a
Just 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]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G 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  = []
                        }
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just LinkableUnit
lu)
            [Ident]
_ -> 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   <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [JStat]
ggsToplevelStats forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
          [ClosureInfo]
ci        <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [ClosureInfo]
ggsClosureInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
          [StaticInfo]
si        <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [StaticInfo]
ggsStatic forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
          UniqFM Id CgStgExpr
unf       <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
          Set OtherSymb
extraDeps <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> Set OtherSymb
ggsExtraDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)
          [ForeignJSRef]
fRefs     <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [ForeignJSRef]
ggsForeignRefs 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     = -- Opt.optimize .
                         forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Module -> Int -> FastString
modulePrefix Module
m Int
n)
                       forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [JStat]
extraTl) forall a. Semigroup a => a -> a -> a
<> JStat
tl
          [FastString]
syms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TxtI FastString
i) -> FastString
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> G 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    = forall a. Set a -> [a]
S.toList Set OtherSymb
extraDeps
                    , luRequired :: Bool
luRequired     = Bool
required
                    , luForeignRefs :: [ForeignJSRef]
luForeignRefs  = [ForeignJSRef]
fRefs
                    }
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a b. [a] -> b -> b
seqList [Id]
topDeps seq :: forall a b. a -> b -> b
`seq` forall a b. [a] -> b -> b
seqList [Id]
allDeps seq :: forall a b. a -> b -> b
`seq` forall a. a -> Maybe a
Just LinkableUnit
lu

-- | variable prefix for the nth block in module
modulePrefix :: Module -> Int -> FastString
modulePrefix :: Module -> Int -> FastString
modulePrefix Module
m Int
n =
  let encMod :: [Char]
encMod = [Char] -> [Char]
zEncodeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ Module
m
  in  [Char] -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ [Char]
"h$" forall a. [a] -> [a] -> [a]
++ [Char]
encMod forall a. [a] -> [a] -> [a]
++ [Char]
"_id_" forall a. [a] -> [a] -> [a]
++ 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 BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs
genToplevel (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs)          =
  forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Id
bndr, GenStgRhs 'CodeGen
rhs) -> Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelDecl Id
bndr GenStgRhs 'CodeGen
rhs) [(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 <- forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs)
  JStat
s2 <- forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs)
  forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s1 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
       -> HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
con (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs) -- NoSRT
   StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
_args CgStgExpr
_body
     | Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
i
       -> HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
dc (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs) -- srt
   GenStgRhs 'CodeGen
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo Id
i DataCon
d LiveVars
l {- srt -} = do
  Ident
ei <- Id -> G Ident
identForDataConEntryId Id
i
  CIStatic
sr <- LiveVars -> G CIStatic
genStaticRefs LiveVars
l
  ClosureInfo -> G ()
emitClosureInfo 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 forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr DataCon
d))
                                ([VarType] -> CILayout
fixedLayout forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => UnaryType -> VarType
uTypeVt [UnaryType]
fields)
                                (Int -> CIType
CICon forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
d)
                                CIStatic
sr
  forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ei Ident -> JExpr -> JStat
||= JExpr
mkDataEntry)
    where
      -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
      fields :: [UnaryType]
fields = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> UnaryType
primRepToType forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => UnaryType -> [PrimRep]
typePrimRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnaryType -> UnaryType
unwrapType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Scaled a -> a
scaledThing)
                         (DataCon -> [Scaled UnaryType]
dataConRepArgTys DataCon
d)
        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)

mkDataEntry :: JExpr
mkDataEntry :: JExpr
mkDataEntry = JVal -> JExpr
ValExpr forall a b. (a -> b) -> a -> b
$ [Ident] -> JStat -> JVal
JFunc [] JStat
returnStack

genToplevelRhs :: Id -> CgStgRhs -> G JStat
-- general cases:
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 -> G Ident
identForId Id
i
    HasDebugCallStack =>
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic Ident
ii CostCentreStack
cc DataCon
con [StgArg]
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag {- srt -} [BinderP 'CodeGen]
args CgStgExpr
body -> do
    {-
      algorithm:
       - collect all Id refs that are in the global id cache
       - count usage in body for each ref
       - order by increasing use
       - prepend loading lives var to body: body can stay the same
    -}
    eid :: Ident
eid@(TxtI FastString
eidt) <- Id -> G Ident
identForEntryId Id
i
    (TxtI FastString
idt)   <- Id -> G Ident
identForId Id
i
    JStat
body <- HasDebugCallStack =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody (Id -> ExprCtx
initExprCtx Id
i) Id
i StgReg
R2 [BinderP 'CodeGen]
args CgStgExpr
body
    [GlobalOcc]
global_occs <- JStat -> G [GlobalOcc]
globalOccs (forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (forall a. a -> Maybe a
Just FastString
"ghcjs_tmp_sat_") JStat
body)
    let lidents :: [Ident]
lidents = forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Ident
global_ident [GlobalOcc]
global_occs
    let lids :: [Id]
lids    = forall a b. (a -> b) -> [a] -> [b]
map GlobalOcc -> Id
global_id    [GlobalOcc]
global_occs
    let lidents' :: [FastString]
lidents' = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (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 <- HasDebugCallStack => [Id] -> G CIType
genEntryType [BinderP 'CodeGen]
args
    JStat
ll <- [Id] -> G JStat
loadLiveFun [Id]
lids
    (StaticVal
static, CIRegs
regs, JStat
upd) <-
      if CIType
et forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
        then do
          JStat
r <- G JStat
updateThunk
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FastString, [StaticArg]) -> StaticVal
StaticThunk (forall a. a -> Maybe a
Just (FastString
eidt, forall a b. (a -> b) -> [a] -> [b]
map FastString -> StaticArg
StaticObjArg [FastString]
lidents')), Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType
PtrV],JStat
r)
        else forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> [StaticArg] -> StaticVal
StaticFun FastString
eidt (forall a b. (a -> b) -> [a] -> [b]
map FastString -> StaticArg
StaticObjArg [FastString]
lidents'),
                    (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
lidents then Int -> [VarType] -> CIRegs
CIRegs Int
1 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [VarType]
idVt [BinderP 'CodeGen]
args)
                                     else Int -> [VarType] -> CIRegs
CIRegs Int
0 (VarType
PtrV forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [VarType]
idVt [BinderP 'CodeGen]
args))
                      , forall a. Monoid a => a
mempty)
    JStat
setcc <- forall m. Monoid m => m -> G m
ifProfiling forall a b. (a -> b) -> a -> b
$
               if CIType
et 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => UnaryType -> VarType
uTypeVt 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Ident
eid Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] (JStat
ll forall a. Semigroup a => a -> a -> a
<> JStat
upd forall a. Semigroup a => a -> a -> a
<> JStat
setcc forall a. Semigroup a => a -> a -> a
<> JStat
body)))