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

-- | 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.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
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

-- | 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
-> 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
    -- 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

  (BlockInfo
deps,[LinkableUnit]
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
    [LinkableUnit]
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
    BlockInfo
deps <- HasDebugCallStack => Module -> [LinkableUnit] -> G BlockInfo
Module -> [LinkableUnit] -> G BlockInfo
genDependencyData Module
this_mod [LinkableUnit]
lus
    (BlockInfo, [LinkableUnit]) -> G (BlockInfo, [LinkableUnit])
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockInfo
deps,[LinkableUnit]
lus)

  -- Doc to dump when -ddump-js is enabled
  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 -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_js FilePath
"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 (JStat -> SDoc
forall a. JsToDoc a => a -> SDoc
jsToDoc (JStat -> SDoc) -> (LinkableUnit -> JStat) -> LinkableUnit -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjBlock -> JStat
oiStat (ObjBlock -> JStat)
-> (LinkableUnit -> ObjBlock) -> LinkableUnit -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkableUnit -> ObjBlock
luObjBlock) [LinkableUnit]
lus)

  -- Write the object file
  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) -- a bit less than 4kB
  BinHandle -> ModuleName -> BlockInfo -> [ObjBlock] -> IO ()
Object.putObject BinHandle
bh (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) BlockInfo
deps ((LinkableUnit -> ObjBlock) -> [LinkableUnit] -> [ObjBlock]
forall a b. (a -> b) -> [a] -> [b]
map LinkableUnit -> ObjBlock
luObjBlock [LinkableUnit]
lus)

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)
  BinHandle -> FilePath -> IO ()
writeBinMem BinHandle
bh FilePath
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     <- G LinkableUnit
HasDebugCallStack => G LinkableUnit
generateGlobalBlock
    LinkableUnit
exports <- G LinkableUnit
HasDebugCallStack => G LinkableUnit
generateExportsBlock
    [LinkableUnit]
others  <- Int -> [CgStgTopBinding] -> G [LinkableUnit]
HasDebugCallStack => 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                 -- 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
        []     -> [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 <- HasDebugCallStack =>
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
CgStgTopBinding -> Int -> G (Maybe LinkableUnit)
generateBlock CgStgTopBinding
x Int
n
          [LinkableUnit]
lus <- Int -> [CgStgTopBinding] -> G [LinkableUnit]
HasDebugCallStack => 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)

      --   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
        [JStgStat]
glbl <- (GenState -> [JStgStat]) -> StateT GenState IO [JStgStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> [JStgStat]
gsGlobal
        JStgStat
staticInit <-
          [SptEntry] -> G JStgStat
initStaticPtrs [SptEntry]
spt_entries
        let stat :: JStat
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
opt_stat = JStat -> JStat
jsOptimize JStat
stat
        let syms :: [FastString]
syms = [Module -> FastString
moduleGlobalSymbol Module
m]
        let oi :: ObjBlock
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
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  = []
                  }
        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 :: 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

      --   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
            [(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
              [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 ids :: [Id]
ids = [Id
bnd]
              [FastString]
syms <- (\(Ident -> FastString
identFS -> 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 :: ObjBlock
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
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  = []
                        }
              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]
_ -> FilePath -> G (Maybe LinkableUnit)
forall a. HasCallStack => FilePath -> a
panic FilePath
"generateBlock: invalid size"

        StgTopLifted GenStgBinding 'CodeGen
decl -> do
          JStgStat
tl        <- GenStgBinding 'CodeGen -> G JStgStat
genToplevel GenStgBinding 'CodeGen
decl
          [JStgStat]
extraTl   <- (GenState -> [JStgStat]) -> StateT GenState IO [JStgStat]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [JStgStat]
ggsToplevelStats (GenGroupState -> [JStgStat])
-> (GenState -> GenGroupState) -> GenState -> [JStgStat]
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     = 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
opt_stat = JStat -> JStat
jsOptimize JStat
stat
          [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 (\(Ident -> FastString
identFS -> 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 :: ObjBlock
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
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
                    }
          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

-- | variable prefix for the nth block in module

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
  JStgStat
s1 <- G JStgStat -> G JStgStat
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelConEntry Id
i GenStgRhs 'CodeGen
rhs)
  JStgStat
s2 <- G JStgStat -> G JStgStat
forall a. G a -> G a
resetSlots (Id -> GenStgRhs 'CodeGen -> G JStgStat
genToplevelRhs Id
i GenStgRhs 'CodeGen
rhs)
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
s1 JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
s2)

genToplevelConEntry :: Id -> CgStgRhs -> G JStgStat
genToplevelConEntry :: Id -> GenStgRhs 'CodeGen -> G JStgStat
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 -> LiveVars -> G JStgStat
Id -> DataCon -> LiveVars -> G JStgStat
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 Type
_typ
     | Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
i
       -> HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStgStat
Id -> DataCon -> LiveVars -> G JStgStat
genSetConInfo Id
i DataCon
dc (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs) -- srt
   GenStgRhs 'CodeGen
_ -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty

genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStgStat
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStgStat
genSetConInfo Id
i DataCon
d LiveVars
l {- srt -} = 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 -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV])
                                (FilePath -> FastString
mkFastString (FilePath -> FastString) -> FilePath -> FastString
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
defaultSDocContext (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
d))
                                ([JSRep] -> CILayout
fixedLayout ([JSRep] -> CILayout) -> [JSRep] -> CILayout
forall a b. (a -> b) -> a -> b
$ (Type -> JSRep) -> [Type] -> [JSRep]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> JSRep
Type -> JSRep
unaryTypeJSRep [Type]
fields)
                                (Int -> CIType
CICon (Int -> CIType) -> Int -> CIType
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
d)
                                CIStatic
sr
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> JStgStat
mkDataEntry Ident
ei)
    where
      -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
      fields :: [Type]
fields = (Scaled Type -> [Type]) -> [Scaled Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PrimRep -> Type) -> [PrimRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType ([PrimRep] -> [Type])
-> (Scaled Type -> [PrimRep]) -> Scaled Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep])
-> (Scaled Type -> Type) -> Scaled Type -> [PrimRep]
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)
        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)

mkDataEntry :: Ident -> JStgStat
mkDataEntry :: Ident -> JStgStat
mkDataEntry Ident
i = Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
i [] JStgStat
returnStack

genToplevelRhs :: Id -> CgStgRhs -> G JStgStat
-- general cases:
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
    Ident
ii <- Id -> StateT GenState IO Ident
identForId Id
i
    HasDebugCallStack =>
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic Ident
ii CostCentreStack
cc DataCon
con [StgArg]
args
    JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
  StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag {- srt -} [BinderP 'CodeGen]
args CgStgExpr
body Type
typ -> 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
    -}
    Ident
eid  <- Id -> StateT GenState IO Ident
identForEntryId Id
i
    FastString
idt  <- Ident -> FastString
identFS (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
i
    JStgStat
body <- HasDebugCallStack =>
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
genBody (Id -> ExprCtx
initExprCtx Id
i) StgReg
R2 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body Type
typ
    [GlobalOcc]
global_occs <- JStgStat -> G [GlobalOcc]
globalOccs JStgStat
body
    let eidt :: FastString
eidt = Ident -> FastString
identFS Ident
eid
    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
HasDebugCallStack => [Id] -> G CIType
genEntryType [Id]
[BinderP 'CodeGen]
args
    JStgStat
ll <- [Id] -> G JStgStat
loadLiveFun [Id]
lids
    (StaticVal
static, CIRegs
regs, JStgStat
upd) <-
      if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
        then do
          JStgStat
r <- G JStgStat
updateThunk
          (StaticVal, CIRegs, JStgStat)
-> StateT GenState IO (StaticVal, CIRegs, JStgStat)
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 -> [JSRep] -> CIRegs
CIRegs Int
0 [JSRep
PtrV],JStgStat
r)
        else (StaticVal, CIRegs, JStgStat)
-> StateT GenState IO (StaticVal, CIRegs, JStgStat)
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 -> [JSRep] -> CIRegs
CIRegs Int
1 ((Id -> [JSRep]) -> [Id] -> [JSRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep [Id]
[BinderP 'CodeGen]
args)
                                     else Int -> [JSRep] -> CIRegs
CIRegs Int
0 (JSRep
PtrV JSRep -> [JSRep] -> [JSRep]
forall a. a -> [a] -> [a]
: (Id -> [JSRep]) -> [Id] -> [JSRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep [Id]
[BinderP 'CodeGen]
args))
                      , JStgStat
forall a. Monoid a => a
mempty)
    JStgStat
setcc <- JStgStat -> G JStgStat
forall m. Monoid m => m -> G m
ifProfiling (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$
               if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
                 then JStgStat
enterCostCentreThunk
                 else CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
cc
    ClosureInfo -> G ()
emitClosureInfo (Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
eid
                                 CIRegs
regs
                                 FastString
idt
                                 ([JSRep] -> CILayout
fixedLayout ([JSRep] -> CILayout) -> [JSRep] -> CILayout
forall a b. (a -> b) -> a -> b
$ (Id -> JSRep) -> [Id] -> [JSRep]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Type -> JSRep
Type -> JSRep
unaryTypeJSRep (Type -> JSRep) -> (Id -> Type) -> Id -> JSRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
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
    JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ (Ident -> [Ident] -> JStgStat -> JStgStat
FuncStat Ident
eid [] (JStgStat
ll JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
upd JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
setcc JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
body))