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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Linker.Linker
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
-- GHCJS linker, collects dependencies from the object files
-- which contain linkable units with dependency information
--
-----------------------------------------------------------------------------

module GHC.StgToJS.Linker.Linker
  ( jsLinkBinary
  , jsLink
  , embedJsFile
  , staticInitStat
  , staticDeclStat
  , mkExportedFuns
  , mkExportedModFuns
  , computeLinkDependencies
  , LinkSpec (..)
  , LinkPlan (..)
  , emptyLinkPlan
  , incrementLinkPlan
  , ArchiveCache
  , newArchiveCache
  )
where

import GHC.Prelude

import GHC.Platform.Host (hostPlatformArchOS)

import GHC.JS.Make
import GHC.JS.Optimizer
import GHC.JS.Ident
import GHC.JS.JStg.Syntax
import GHC.JS.JStg.Monad
import qualified GHC.JS.Syntax as JS
import GHC.JS.Transform

import GHC.Driver.DynFlags (DynFlags(..))
import Language.Haskell.Syntax.Module.Name
import GHC.SysTools.Cpp
import GHC.SysTools

import GHC.Linker.Static.Utils (exeFileName)
import GHC.Linker.Types (Unlinked(..), linkableUnlinked)
import GHC.Linker.External

import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Utils
import GHC.StgToJS.Linker.Opt
import GHC.StgToJS.Rts.Rts
import GHC.StgToJS.Object
import GHC.StgToJS.Types hiding (LinkableUnit)
import GHC.StgToJS.Symbols
import GHC.StgToJS.Arg
import GHC.StgToJS.Closure

import GHC.Unit.State
import GHC.Unit.Env
import GHC.Unit.Home.ModInfo
import GHC.Unit.Types
import GHC.Unit.Module (moduleStableString)

import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.BufHandle
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Logger (Logger, logVerbAtLeast)
import GHC.Utils.Binary
import qualified GHC.Utils.Ppr as Ppr
import GHC.Utils.TmpFs

import GHC.Types.Unique.Set

import qualified GHC.SysTools.Ar          as Ar

import qualified GHC.Data.ShortText as ST
import GHC.Data.FastString

import Control.Monad

import Data.Array
import qualified Data.ByteString          as B
import qualified Data.ByteString.Char8    as BC
import qualified Data.ByteString.Lazy     as BL
import qualified Data.ByteString          as BS
import Data.Function            (on)
import qualified Data.IntSet              as IS
import Data.IORef
import Data.List  ( nub, intercalate, groupBy, intersperse, sortBy)
import Data.Map.Strict          (Map)
import qualified Data.Map.Strict          as M
import Data.Maybe
import Data.Set                 (Set)
import qualified Data.Set                 as S
import Data.Word
import Data.Monoid

import System.IO
import System.FilePath ((<.>), (</>), dropExtension, takeDirectory)
import System.Directory ( createDirectoryIfMissing
                        , doesFileExist
                        , getCurrentDirectory
                        , Permissions(..)
                        , setPermissions
                        , getPermissions
                        )

import GHC.Unit.Finder.Types
import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule)
import GHC.Driver.Config.Finder (initFinderOpts)

data LinkerStats = LinkerStats
  { LinkerStats -> Map Module Word64
bytesPerModule     :: !(Map Module Word64) -- ^ number of bytes linked per module
  , LinkerStats -> Word64
packedMetaDataSize :: !Word64              -- ^ number of bytes for metadata
  }

newtype ArchiveCache = ArchiveCache { ArchiveCache -> IORef (Map FilePath Archive)
loadedArchives :: IORef (Map FilePath Ar.Archive) }

newArchiveCache :: IO ArchiveCache
newArchiveCache :: IO ArchiveCache
newArchiveCache = IORef (Map FilePath Archive) -> ArchiveCache
ArchiveCache (IORef (Map FilePath Archive) -> ArchiveCache)
-> IO (IORef (Map FilePath Archive)) -> IO ArchiveCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FilePath Archive -> IO (IORef (Map FilePath Archive))
forall a. a -> IO (IORef a)
newIORef Map FilePath Archive
forall k a. Map k a
M.empty

defaultJsContext :: SDocContext
defaultJsContext :: SDocContext
defaultJsContext = SDocContext
defaultSDocContext{sdocStyle = PprCode}

jsLinkBinary
  :: FinderCache
  -> JSLinkConfig
  -> StgToJSConfig
  -> Logger
  -> TmpFs
  -> DynFlags
  -> UnitEnv
  -> [FilePath]
  -> [UnitId]
  -> IO ()
jsLinkBinary :: FinderCache
-> JSLinkConfig
-> StgToJSConfig
-> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
jsLinkBinary FinderCache
finder_cache JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
hs_objs [UnitId]
dep_units
  | JSLinkConfig -> Bool
lcNoJSExecutables JSLinkConfig
lc_cfg = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do

    -- additional objects to link are passed as FileOption ldInputs...
    let cmdline_objs :: [FilePath]
cmdline_objs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]

    -- cmdline objects: discriminate between the 3 kinds of objects we have
    let disc :: [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [FilePath]
hss [FilePath]
jss [FilePath]
ccs = \case
          []     -> ([FilePath], [FilePath], [FilePath])
-> IO ([FilePath], [FilePath], [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath]
hss, [FilePath]
jss, [FilePath]
ccs)
          (FilePath
o:[FilePath]
os) -> FilePath -> IO (Maybe ObjectKind)
getObjectKind FilePath
o IO (Maybe ObjectKind)
-> (Maybe ObjectKind -> IO ([FilePath], [FilePath], [FilePath]))
-> IO ([FilePath], [FilePath], [FilePath])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just ObjectKind
ObjHs -> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc (FilePath
oFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
hss) [FilePath]
jss [FilePath]
ccs [FilePath]
os
            Just ObjectKind
ObjJs -> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [FilePath]
hss (FilePath
oFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
jss) [FilePath]
ccs [FilePath]
os
            Just ObjectKind
ObjCc -> [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [FilePath]
hss [FilePath]
jss (FilePath
oFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
ccs) [FilePath]
os
            Maybe ObjectKind
Nothing    -> do
              Logger -> SDoc -> IO ()
logInfo Logger
logger ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Ignoring unexpected command-line object: ", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
o])
              [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [FilePath]
hss [FilePath]
jss [FilePath]
ccs [FilePath]
os
    ([FilePath]
cmdline_hs_objs, [FilePath]
cmdline_js_objs, [FilePath]
cmdline_cc_objs) <- [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [] [] [] [FilePath]
cmdline_objs

    let
        exe :: FilePath
exe         = DynFlags -> FilePath
jsExeFileName DynFlags
dflags
        all_hs_objs :: [FilePath]
all_hs_objs = [FilePath]
hs_objs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_hs_objs
        all_js_objs :: [FilePath]
all_js_objs = [FilePath]
cmdline_js_objs
        all_cc_objs :: [FilePath]
all_cc_objs = [FilePath]
cmdline_cc_objs
        is_root :: p -> Bool
is_root p
_   = Bool
True
                      -- FIXME: we shouldn't consider every function as a root,
                      -- but only the program entry point (main), either the
                      -- generated one or coming from an object

    -- compute dependencies
    let link_spec :: LinkSpec
link_spec = LinkSpec
          { lks_unit_ids :: [UnitId]
lks_unit_ids        = [UnitId]
dep_units
          , lks_obj_root_filter :: ExportedFun -> Bool
lks_obj_root_filter = ExportedFun -> Bool
forall {p}. p -> Bool
is_root
          , lks_extra_roots :: Set ExportedFun
lks_extra_roots     = Set ExportedFun
forall a. Monoid a => a
mempty
          , lks_objs_hs :: [FilePath]
lks_objs_hs         = [FilePath]
all_hs_objs
          , lks_objs_js :: [FilePath]
lks_objs_js         = [FilePath]
all_js_objs
          , lks_objs_cc :: [FilePath]
lks_objs_cc         = [FilePath]
all_cc_objs
          }

    let finder_opts :: FinderOpts
finder_opts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
    ArchiveCache
ar_cache <- IO ArchiveCache
newArchiveCache

    LinkPlan
link_plan <- StgToJSConfig
-> UnitEnv
-> LinkSpec
-> FinderOpts
-> FinderCache
-> ArchiveCache
-> IO LinkPlan
computeLinkDependencies StgToJSConfig
cfg UnitEnv
unit_env LinkSpec
link_spec FinderOpts
finder_opts FinderCache
finder_cache ArchiveCache
ar_cache

    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JSLinkConfig
-> StgToJSConfig
-> Logger
-> TmpFs
-> ArchiveCache
-> FilePath
-> LinkPlan
-> IO ()
jsLink JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger TmpFs
tmpfs ArchiveCache
ar_cache FilePath
exe LinkPlan
link_plan

-- | link and write result to disk (jsexe directory)
jsLink
     :: JSLinkConfig
     -> StgToJSConfig
     -> Logger
     -> TmpFs
     -> ArchiveCache
     -> FilePath               -- ^ output file/directory
     -> LinkPlan
     -> IO ()
jsLink :: JSLinkConfig
-> StgToJSConfig
-> Logger
-> TmpFs
-> ArchiveCache
-> FilePath
-> LinkPlan
-> IO ()
jsLink JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger TmpFs
tmpfs ArchiveCache
ar_cache FilePath
out LinkPlan
link_plan = do

      -- create output directory
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False FilePath
out

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> BlockId -> Bool
logVerbAtLeast Logger
logger BlockId
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"jsLink:") BlockId
2 (LinkPlan -> SDoc
forall a. Outputable a => a -> SDoc
ppr LinkPlan
link_plan)

      -------------------------------------------------------------
      -- link all Haskell code (program + dependencies) into out.js

      -- retrieve code for Haskell dependencies
      [ModuleCode]
mods <- ArchiveCache -> LinkPlan -> IO [ModuleCode]
collectModuleCodes ArchiveCache
ar_cache LinkPlan
link_plan

      -- LTO + rendering of JS code
      LinkerStats
link_stats <- FilePath -> IOMode -> (Handle -> IO LinkerStats) -> IO LinkerStats
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"out.js") IOMode
WriteMode ((Handle -> IO LinkerStats) -> IO LinkerStats)
-> (Handle -> IO LinkerStats) -> IO LinkerStats
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
        Handle -> Bool -> [ModuleCode] -> IO LinkerStats
renderModules Handle
h (StgToJSConfig -> Bool
csPrettyRender StgToJSConfig
cfg) [ModuleCode]
mods

      -------------------------------------------------------------

      -- dump foreign references file (.frefs)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSLinkConfig -> Bool
lcForeignRefs JSLinkConfig
lc_cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let frefsFile :: FilePath
frefsFile  = FilePath
"out.frefs"
            -- frefs      = concatMap mc_frefs mods
            jsonFrefs :: ByteString
jsonFrefs  = ByteString
forall a. Monoid a => a
mempty -- FIXME: toJson frefs

        FilePath -> ByteString -> IO ()
BL.writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
frefsFile FilePath -> FilePath -> FilePath
<.> FilePath
"json") ByteString
jsonFrefs
        FilePath -> ByteString -> IO ()
BL.writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
frefsFile FilePath -> FilePath -> FilePath
<.> FilePath
"js")
                     (ByteString
"h$checkForeignRefs(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
jsonFrefs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
");")

      -- dump stats
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcNoStats JSLinkConfig
lc_cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let statsFile :: FilePath
statsFile = FilePath
"out.stats"
        FilePath -> FilePath -> IO ()
writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
statsFile) (LinkerStats -> FilePath
renderLinkerStats LinkerStats
link_stats)

      -- link generated RTS parts into rts.js
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcNoRts JSLinkConfig
lc_cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        JEnv
jsm <- IO JEnv
initJSM
        FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"rts.js") IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          let opt :: JStat
opt = JStat -> JStat
jsOptimize (JEnv -> JSM JStat -> JStat
forall a. JEnv -> JSM a -> a
runJSM JEnv
jsm (JSM JStat -> JStat) -> JSM JStat -> JStat
forall a b. (a -> b) -> a -> b
$ JStgStat -> JStat
jStgStatToJS (JStgStat -> JStat) -> StateT JEnv Identity JStgStat -> JSM JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgToJSConfig -> StateT JEnv Identity JStgStat
rts StgToJSConfig
cfg)
          IO Integer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Integer -> IO ()) -> IO Integer -> IO ()
forall a b. (a -> b) -> a -> b
$
            Bool -> Handle -> JStat -> IO Integer
hPutJS (StgToJSConfig -> Bool
csPrettyRender StgToJSConfig
cfg) Handle
h JStat
opt


      -- link user-provided JS files into lib.js
      (JSOptions
emcc_opts,[FilePath]
lib_cc_objs) <- FilePath
-> IOMode
-> (Handle -> IO (JSOptions, [FilePath]))
-> IO (JSOptions, [FilePath])
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"lib.js") IOMode
WriteMode ((Handle -> IO (JSOptions, [FilePath]))
 -> IO (JSOptions, [FilePath]))
-> (Handle -> IO (JSOptions, [FilePath]))
-> IO (JSOptions, [FilePath])
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do

        let
            tmp_dir :: TempDir
tmp_dir = LinkerConfig -> TempDir
linkerTempDir (StgToJSConfig -> LinkerConfig
csLinkerConfig StgToJSConfig
cfg)

            -- JS objects from dependencies' archives (.a)
            go_archives :: JSOptions -> [FilePath] -> [FilePath] -> IO (JSOptions, [FilePath])
go_archives JSOptions
emcc_opts [FilePath]
cc_objs = \case
              []     -> (JSOptions, [FilePath]) -> IO (JSOptions, [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSOptions
emcc_opts, [FilePath]
cc_objs)
              (FilePath
a:[FilePath]
as) -> do
                Ar.Archive [ArchiveEntry]
entries <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
a
                (JSOptions
emcc_opts', [FilePath]
cc_objs') <- JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
entries
                JSOptions -> [FilePath] -> [FilePath] -> IO (JSOptions, [FilePath])
go_archives JSOptions
emcc_opts' [FilePath]
cc_objs' [FilePath]
as

            -- archive's entries
            go_entries :: JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs = \case
              []     -> (JSOptions, [FilePath]) -> IO (JSOptions, [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSOptions
emcc_opts, [FilePath]
cc_objs)
              (ArchiveEntry
e:[ArchiveEntry]
es) -> case ByteString -> Maybe ObjectKind
getObjectKindBS (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
e) of
                Just ObjectKind
ObjHs -> do
                  -- Nothing to do. HS objects are collected in
                  -- collectModuleCodes
                  JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es
                Just ObjectKind
ObjCc -> do
                  -- extract the object file from the archive in a temporary
                  -- file and return its path
                  FilePath
cc_obj_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_CurrentModule FilePath
"o"
                  FilePath -> ByteString -> IO ()
B.writeFile FilePath
cc_obj_fn (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
e)
                  let cc_objs' :: [FilePath]
cc_objs' = FilePath
cc_obj_fnFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
cc_objs
                  JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs' [ArchiveEntry]
es
                Just ObjectKind
ObjJs -> do
                  -- extract the JS code and append it to the `lib.js` file
                  (JSOptions
opts,ByteString
bs) <- ByteString -> IO (JSOptions, ByteString)
parseJSObjectBS (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
e)
                  Handle -> ByteString -> IO ()
B.hPut   Handle
h ByteString
bs
                  Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
                  let emcc_opts' :: JSOptions
emcc_opts' = JSOptions
emcc_opts JSOptions -> JSOptions -> JSOptions
forall a. Semigroup a => a -> a -> a
<> JSOptions
opts
                  JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts' [FilePath]
cc_objs [ArchiveEntry]
es
                Maybe ObjectKind
Nothing -> do
                  Logger -> SDoc -> IO ()
logInfo Logger
logger ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Ignoring unexpected archive entry: ", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (ArchiveEntry -> FilePath
Ar.filename ArchiveEntry
e)])
                  JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es

            -- additional JS objects (e.g. from the command-line)
            go_extra :: JSOptions -> [FilePath] -> IO JSOptions
go_extra JSOptions
emcc_opts = \case
              []     -> JSOptions -> IO JSOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSOptions
emcc_opts
              (FilePath
e:[FilePath]
es) -> do
                (JSOptions
opts,ByteString
bs) <- FilePath -> IO (JSOptions, ByteString)
readJSObject FilePath
e
                Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
bs
                Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
                let emcc_opts' :: JSOptions
emcc_opts' = JSOptions
emcc_opts JSOptions -> JSOptions -> JSOptions
forall a. Semigroup a => a -> a -> a
<> JSOptions
opts
                JSOptions -> [FilePath] -> IO JSOptions
go_extra JSOptions
emcc_opts' [FilePath]
es

        -- archives
        (JSOptions
emcc_opts0, [FilePath]
cc_objs) <- JSOptions -> [FilePath] -> [FilePath] -> IO (JSOptions, [FilePath])
go_archives JSOptions
defaultJSOptions [] (Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (LinkPlan -> Set FilePath
lkp_archives LinkPlan
link_plan))
        -- extra object files
        JSOptions
emcc_opts1            <- JSOptions -> [FilePath] -> IO JSOptions
go_extra JSOptions
emcc_opts0 (Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (LinkPlan -> Set FilePath
lkp_objs_js LinkPlan
link_plan))
        (JSOptions, [FilePath]) -> IO (JSOptions, [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSOptions
emcc_opts1,[FilePath]
cc_objs)


      -- Link Cc objects using emcc's linker
      --
      -- Cc objects have been extracted from archives (see above) and are listed
      -- in lib_cc_objs.
      --
      -- We don't link C sources if there are none (obviously) or if asked
      -- explicitly by the user with -ddisable-js-c-sources (mostly used for
      -- debugging purpose).
      let emcc_objs :: [FilePath]
emcc_objs     = [FilePath]
lib_cc_objs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (LinkPlan -> Set FilePath
lkp_objs_cc LinkPlan
link_plan)
      let has_emcc_objs :: Bool
has_emcc_objs = Bool -> Bool
not ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
emcc_objs)
      let link_c_sources :: Bool
link_c_sources = JSLinkConfig -> Bool
lcLinkCsources JSLinkConfig
lc_cfg Bool -> Bool -> Bool
&& Bool
has_emcc_objs

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
link_c_sources (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

        Logger -> TmpFs -> LinkerConfig -> [Option] -> IO ()
runLink Logger
logger TmpFs
tmpfs (StgToJSConfig -> LinkerConfig
csLinkerConfig StgToJSConfig
cfg) ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [ FilePath -> Option
Option FilePath
"-o"
          , FilePath -> FilePath -> Option
FileOption FilePath
"" (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"clibs.js")
          -- Embed wasm files into a single .js file
          , FilePath -> Option
Option FilePath
"-sSINGLE_FILE=1"
          -- Enable support for addFunction (callbacks)
          , FilePath -> Option
Option FilePath
"-sALLOW_TABLE_GROWTH"
          -- keep some RTS methods and functions (otherwise removed as dead
          -- code)
          , FilePath -> Option
Option (FilePath
"-sEXPORTED_RUNTIME_METHODS=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"," (JSOptions -> [FilePath]
emccExportedRuntimeMethods JSOptions
emcc_opts)))
          , FilePath -> Option
Option (FilePath
"-sEXPORTED_FUNCTIONS=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"," (JSOptions -> [FilePath]
emccExportedFunctions JSOptions
emcc_opts)))
          ]
          -- pass extra options from JS files' pragmas
          [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
Option (JSOptions -> [FilePath]
emccExtraOptions JSOptions
emcc_opts)
          -- link objects
          [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
FileOption FilePath
"") [FilePath]
emcc_objs

      -- Don't enable the Emcc rts when not needed (i.e. no Wasm module to link
      -- with) and not forced by the caller (e.g. in the future iserv may require
      -- incremental linking of Wasm modules, hence the emcc rts even building
      -- iserv itself doesn't require the emcc rts)
      let use_emcc_rts :: UseEmccRts
use_emcc_rts = Bool -> UseEmccRts
UseEmccRts (Bool -> UseEmccRts) -> Bool -> UseEmccRts
forall a b. (a -> b) -> a -> b
$ Bool
link_c_sources Bool -> Bool -> Bool
|| JSLinkConfig -> Bool
lcForceEmccRts JSLinkConfig
lc_cfg


      -- link everything together into a runnable all.js
      -- only if we link a complete application,
      --   no incremental linking and no skipped parts
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSLinkConfig -> Bool
lcCombineAll JSLinkConfig
lc_cfg Bool -> Bool -> Bool
&& Bool -> Bool
not (JSLinkConfig -> Bool
lcNoRts JSLinkConfig
lc_cfg)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath -> UseEmccRts -> IO ()
writeRunMain FilePath
out UseEmccRts
use_emcc_rts
        ()
_ <- JSLinkConfig -> Bool -> FilePath -> IO ()
combineFiles JSLinkConfig
lc_cfg Bool
link_c_sources FilePath
out
        FilePath -> IO ()
writeHtml    FilePath
out
        JSLinkConfig -> FilePath -> IO ()
writeRunner JSLinkConfig
lc_cfg FilePath
out
        FilePath -> IO ()
writeExterns FilePath
out

data LinkSpec = LinkSpec
  { LinkSpec -> [UnitId]
lks_unit_ids        :: [UnitId]
  , LinkSpec -> ExportedFun -> Bool
lks_obj_root_filter :: ExportedFun -> Bool -- ^ Predicate for exported functions in objects to declare as root
  , LinkSpec -> Set ExportedFun
lks_extra_roots     :: Set ExportedFun -- ^ Extra root functions from loaded units
  , LinkSpec -> [FilePath]
lks_objs_hs         :: [FilePath]      -- ^ HS objects to link
  , LinkSpec -> [FilePath]
lks_objs_js         :: [FilePath]      -- ^ JS objects to link
  , LinkSpec -> [FilePath]
lks_objs_cc         :: [FilePath]      -- ^ Cc objects to link
  }

instance Outputable LinkSpec where
  ppr :: LinkSpec -> SDoc
ppr LinkSpec
s = SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"LinkSpec") BlockId
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
            [ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Unit ids: ", [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LinkSpec -> [UnitId]
lks_unit_ids LinkSpec
s)]
            , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"HS objects:", [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (LinkSpec -> [FilePath]
lks_objs_hs LinkSpec
s))]
            , SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS objects::") BlockId
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (LinkSpec -> [FilePath]
lks_objs_js LinkSpec
s)))
            , SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Cc objects::") BlockId
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (LinkSpec -> [FilePath]
lks_objs_cc LinkSpec
s)))
            , FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Object root filter: <function>"
            , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Extra roots: ", Set ExportedFun -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LinkSpec -> Set ExportedFun
lks_extra_roots LinkSpec
s)]
            ]

emptyLinkPlan :: LinkPlan
emptyLinkPlan :: LinkPlan
emptyLinkPlan = LinkPlan
  { lkp_block_info :: Map Module LocatedBlockInfo
lkp_block_info = Map Module LocatedBlockInfo
forall a. Monoid a => a
mempty
  , lkp_dep_blocks :: Set BlockRef
lkp_dep_blocks = Set BlockRef
forall a. Monoid a => a
mempty
  , lkp_archives :: Set FilePath
lkp_archives   = Set FilePath
forall a. Monoid a => a
mempty
  , lkp_objs_js :: Set FilePath
lkp_objs_js    = Set FilePath
forall a. Monoid a => a
mempty
  , lkp_objs_cc :: Set FilePath
lkp_objs_cc    = Set FilePath
forall a. Monoid a => a
mempty
  }

-- | Given a `base` link plan (assumed to be already linked) and a `new` link
-- plan, compute `(diff, total)` link plans.
--
-- - `diff` is the incremental link plan to get from `base` to `total`
-- - `total` is the total link plan as if `base` and `new` were linked at once
incrementLinkPlan :: LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan)
incrementLinkPlan :: LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan)
incrementLinkPlan LinkPlan
base LinkPlan
new = (LinkPlan
diff,LinkPlan
total)
  where
    total :: LinkPlan
total = LinkPlan
      { lkp_block_info :: Map Module LocatedBlockInfo
lkp_block_info = Map Module LocatedBlockInfo
-> Map Module LocatedBlockInfo -> Map Module LocatedBlockInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (LinkPlan -> Map Module LocatedBlockInfo
lkp_block_info LinkPlan
base) (LinkPlan -> Map Module LocatedBlockInfo
lkp_block_info LinkPlan
new)
      , lkp_dep_blocks :: Set BlockRef
lkp_dep_blocks = Set BlockRef -> Set BlockRef -> Set BlockRef
forall a. Ord a => Set a -> Set a -> Set a
S.union (LinkPlan -> Set BlockRef
lkp_dep_blocks LinkPlan
base) (LinkPlan -> Set BlockRef
lkp_dep_blocks LinkPlan
new)
      , lkp_archives :: Set FilePath
lkp_archives   = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.union (LinkPlan -> Set FilePath
lkp_archives LinkPlan
base) (LinkPlan -> Set FilePath
lkp_archives LinkPlan
new)
      , lkp_objs_js :: Set FilePath
lkp_objs_js    = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.union (LinkPlan -> Set FilePath
lkp_objs_js LinkPlan
base) (LinkPlan -> Set FilePath
lkp_objs_js LinkPlan
new)
      , lkp_objs_cc :: Set FilePath
lkp_objs_cc    = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.union (LinkPlan -> Set FilePath
lkp_objs_cc LinkPlan
base) (LinkPlan -> Set FilePath
lkp_objs_cc LinkPlan
new)
      }
    diff :: LinkPlan
diff = LinkPlan
      { lkp_block_info :: Map Module LocatedBlockInfo
lkp_block_info = LinkPlan -> Map Module LocatedBlockInfo
lkp_block_info LinkPlan
new -- block info from "new" contains all we need to load new blocks
      , lkp_dep_blocks :: Set BlockRef
lkp_dep_blocks = Set BlockRef -> Set BlockRef -> Set BlockRef
forall a. Ord a => Set a -> Set a -> Set a
S.difference (LinkPlan -> Set BlockRef
lkp_dep_blocks LinkPlan
new) (LinkPlan -> Set BlockRef
lkp_dep_blocks LinkPlan
base)
      , lkp_archives :: Set FilePath
lkp_archives   = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.difference (LinkPlan -> Set FilePath
lkp_archives LinkPlan
new)   (LinkPlan -> Set FilePath
lkp_archives LinkPlan
base)
      , lkp_objs_js :: Set FilePath
lkp_objs_js    = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.difference (LinkPlan -> Set FilePath
lkp_objs_js LinkPlan
new)    (LinkPlan -> Set FilePath
lkp_objs_js LinkPlan
base)
      , lkp_objs_cc :: Set FilePath
lkp_objs_cc    = Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
S.difference (LinkPlan -> Set FilePath
lkp_objs_cc LinkPlan
new)    (LinkPlan -> Set FilePath
lkp_objs_cc LinkPlan
base)
      }


computeLinkDependencies
  :: StgToJSConfig
  -> UnitEnv
  -> LinkSpec
  -> FinderOpts
  -> FinderCache
  -> ArchiveCache
  -> IO LinkPlan
computeLinkDependencies :: StgToJSConfig
-> UnitEnv
-> LinkSpec
-> FinderOpts
-> FinderCache
-> ArchiveCache
-> IO LinkPlan
computeLinkDependencies StgToJSConfig
cfg UnitEnv
unit_env LinkSpec
link_spec FinderOpts
finder_opts FinderCache
finder_cache ArchiveCache
ar_cache = do

  let units :: [UnitId]
units       = LinkSpec -> [UnitId]
lks_unit_ids        LinkSpec
link_spec
  let hs_objs :: [FilePath]
hs_objs     = LinkSpec -> [FilePath]
lks_objs_hs         LinkSpec
link_spec
  let js_objs :: [FilePath]
js_objs     = LinkSpec -> [FilePath]
lks_objs_js         LinkSpec
link_spec
  let cc_objs :: [FilePath]
cc_objs     = LinkSpec -> [FilePath]
lks_objs_cc         LinkSpec
link_spec
  let extra_roots :: Set ExportedFun
extra_roots = LinkSpec -> Set ExportedFun
lks_extra_roots     LinkSpec
link_spec
  let obj_is_root :: ExportedFun -> Bool
obj_is_root = LinkSpec -> ExportedFun -> Bool
lks_obj_root_filter LinkSpec
link_spec

  -- Process:
  -- 1) Find new required linkables (object files, libraries, etc.) for all
  -- transitive dependencies
  -- 2) Load ObjBlockInfo from them and cache them
  -- 3) Compute ObjBlock dependencies and return the link plan

  -- TODO (#23013): currently we directly compute the ObjBlock dependencies and
  -- find/load linkable on-demand when a module is missing.


  (Map Module LocatedBlockInfo
objs_block_info, [BlockRef]
objs_required_blocks) <- [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadObjBlockInfo [FilePath]
hs_objs

  let obj_roots :: Set ExportedFun
obj_roots = [ExportedFun] -> Set ExportedFun
forall a. Ord a => [a] -> Set a
S.fromList ([ExportedFun] -> Set ExportedFun)
-> ([ExportedFun] -> [ExportedFun])
-> [ExportedFun]
-> Set ExportedFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExportedFun -> Bool) -> [ExportedFun] -> [ExportedFun]
forall a. (a -> Bool) -> [a] -> [a]
filter ExportedFun -> Bool
obj_is_root ([ExportedFun] -> Set ExportedFun)
-> [ExportedFun] -> Set ExportedFun
forall a b. (a -> b) -> a -> b
$ (LocatedBlockInfo -> [ExportedFun])
-> [LocatedBlockInfo] -> [ExportedFun]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map ExportedFun BlockId -> [ExportedFun]
forall k a. Map k a -> [k]
M.keys (Map ExportedFun BlockId -> [ExportedFun])
-> (LocatedBlockInfo -> Map ExportedFun BlockId)
-> LocatedBlockInfo
-> [ExportedFun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInfo -> Map ExportedFun BlockId
bi_exports (BlockInfo -> Map ExportedFun BlockId)
-> (LocatedBlockInfo -> BlockInfo)
-> LocatedBlockInfo
-> Map ExportedFun BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedBlockInfo -> BlockInfo
lbi_info) (Map Module LocatedBlockInfo -> [LocatedBlockInfo]
forall k a. Map k a -> [a]
M.elems Map Module LocatedBlockInfo
objs_block_info)
      obj_units :: [UnitId]
obj_units = (Module -> UnitId) -> [Module] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Module -> UnitId
moduleUnitId ([Module] -> [UnitId]) -> [Module] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [Module] -> [Module]
forall a. Eq a => [a] -> [a]
nub (Map Module LocatedBlockInfo -> [Module]
forall k a. Map k a -> [k]
M.keys Map Module LocatedBlockInfo
objs_block_info)

  let ([UnitId]
rts_wired_units, Set ExportedFun
rts_wired_functions) = ([UnitId], Set ExportedFun)
rtsDeps

  -- all the units we want to link together, without their dependencies
  let root_units :: [UnitId]
root_units = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitEnv -> UnitId
ue_currentUnit UnitEnv
unit_env)
                   ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
interactiveUnitId)
                   ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub
                   ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [UnitId]
rts_wired_units [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId] -> [UnitId]
forall a. [a] -> [a]
reverse [UnitId]
obj_units [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId] -> [UnitId]
forall a. [a] -> [a]
reverse [UnitId]
units

  -- all the units we want to link together, including their dependencies,
  -- preload units, and backpack instantiations
  [UnitInfo]
all_units_infos <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
root_units)

  let all_units :: [UnitId]
all_units = (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
all_units_infos

  [FilePath]
dep_archives <- StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
getPackageArchives StgToJSConfig
cfg UnitEnv
unit_env [UnitId]
all_units
  (Map Module LocatedBlockInfo
archives_block_info, [BlockRef]
archives_required_blocks) <- ArchiveCache
-> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadArchiveBlockInfo ArchiveCache
ar_cache [FilePath]
dep_archives

  -- compute dependencies
  let block_info :: Map Module LocatedBlockInfo
block_info      = Map Module LocatedBlockInfo
objs_block_info Map Module LocatedBlockInfo
-> Map Module LocatedBlockInfo -> Map Module LocatedBlockInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Module LocatedBlockInfo
archives_block_info
      dep_fun_roots :: Set ExportedFun
dep_fun_roots   = Set ExportedFun
obj_roots Set ExportedFun -> Set ExportedFun -> Set ExportedFun
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set ExportedFun
rts_wired_functions Set ExportedFun -> Set ExportedFun -> Set ExportedFun
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set ExportedFun
extra_roots

  -- read transitive dependencies
  IORef [BlockRef]
new_required_blocks_var <- [BlockRef] -> IO (IORef [BlockRef])
forall a. a -> IO (IORef a)
newIORef []
  let load_info :: Module -> IO LocatedBlockInfo
load_info Module
mod = do
        -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps.
        Linkable
linkable <- case Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env) of
          Maybe HomeModInfo
Nothing ->
                -- It's not in the HPT because we are in one shot mode,
                -- so use the Finder to get a ModLocation...
              case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
                Maybe HomeUnit
Nothing -> FilePath -> SDoc -> IO Linkable
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: No home-unit: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod)
                Just HomeUnit
home_unit -> do
                    FindResult
mb_stuff <- FinderCache
-> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
findHomeModule FinderCache
finder_cache FinderOpts
finder_opts HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
                    case FindResult
mb_stuff of
                      Found ModLocation
loc Module
mod -> ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod
                      FindResult
_ -> FilePath -> SDoc -> IO Linkable
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: Couldn't find home-module: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod)
                where
                    found :: ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod = do {
                      Maybe Linkable
mb_lnk <- Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe Module
mod ModLocation
loc ;
                      case Maybe Linkable
mb_lnk of {
                          Maybe Linkable
Nothing  -> FilePath -> SDoc -> IO Linkable
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: Couldn't find linkable for module: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod) ;
                          Just Linkable
lnk -> Linkable -> IO Linkable
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Linkable
lnk
                      }}

          Just HomeModInfo
mod_info -> case HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
mod_info of
            Maybe Linkable
Nothing  -> FilePath -> SDoc -> IO Linkable
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: Couldn't find object file for home-module: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod)
            Just Linkable
lnk -> Linkable -> IO Linkable
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Linkable
lnk

        case Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable of
              [DotO FilePath
p] -> do
                  (Map Module LocatedBlockInfo
bis, [BlockRef]
req_b) <- [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadObjBlockInfo [FilePath
p]
                  -- Store new required blocks in IORef
                  IORef [BlockRef] -> ([BlockRef] -> [BlockRef]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [BlockRef]
new_required_blocks_var ([BlockRef] -> [BlockRef] -> [BlockRef]
forall a. [a] -> [a] -> [a]
(++) [BlockRef]
req_b)
                  case Module -> Map Module LocatedBlockInfo -> Maybe LocatedBlockInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mod Map Module LocatedBlockInfo
bis of
                    Maybe LocatedBlockInfo
Nothing -> FilePath -> SDoc -> IO LocatedBlockInfo
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: Didn't load any block info for home-module: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod)
                    Just LocatedBlockInfo
bi -> LocatedBlockInfo -> IO LocatedBlockInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedBlockInfo
bi
              [Unlinked]
ul -> FilePath -> SDoc -> IO LocatedBlockInfo
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps: Unrecognized linkable for home-module: "
                      ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
mod
                            , [Unlinked] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Unlinked]
ul])

  -- required blocks have no dependencies, so don't have to use them as roots in
  -- the traversal
  (Map Module LocatedBlockInfo
updated_block_info, Set BlockRef
transitive_deps) <- Map Module LocatedBlockInfo
-> (Module -> IO LocatedBlockInfo)
-> Set ExportedFun
-> Set BlockRef
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
getDeps Map Module LocatedBlockInfo
block_info Module -> IO LocatedBlockInfo
load_info Set ExportedFun
dep_fun_roots Set BlockRef
forall a. Monoid a => a
mempty

  [BlockRef]
new_required_blocks <- IORef [BlockRef] -> IO [BlockRef]
forall a. IORef a -> IO a
readIORef IORef [BlockRef]
new_required_blocks_var
  let required_blocks :: Set BlockRef
required_blocks = [BlockRef] -> Set BlockRef
forall a. Ord a => [a] -> Set a
S.fromList ([BlockRef] -> Set BlockRef) -> [BlockRef] -> Set BlockRef
forall a b. (a -> b) -> a -> b
$ [[BlockRef]] -> [BlockRef]
forall a. Monoid a => [a] -> a
mconcat
        [ [BlockRef]
archives_required_blocks
        , [BlockRef]
objs_required_blocks
        , [BlockRef]
new_required_blocks
        ]

  let all_deps :: Set BlockRef
all_deps = Set BlockRef -> Set BlockRef -> Set BlockRef
forall a. Ord a => Set a -> Set a -> Set a
S.union Set BlockRef
transitive_deps Set BlockRef
required_blocks

  let plan :: LinkPlan
plan = LinkPlan
        { lkp_block_info :: Map Module LocatedBlockInfo
lkp_block_info = Map Module LocatedBlockInfo
updated_block_info
        , lkp_dep_blocks :: Set BlockRef
lkp_dep_blocks = Set BlockRef
all_deps
        , lkp_archives :: Set FilePath
lkp_archives   = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList [FilePath]
dep_archives
        , lkp_objs_js :: Set FilePath
lkp_objs_js    = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList [FilePath]
js_objs
        , lkp_objs_cc :: Set FilePath
lkp_objs_cc    = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList [FilePath]
cc_objs
        }

  LinkPlan -> IO LinkPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LinkPlan
plan


-- | Compiled module
data ModuleCode = ModuleCode
  { ModuleCode -> Module
mc_module   :: !Module
  , ModuleCode -> JStat
mc_js_code  :: !JS.JStat
  , ModuleCode -> ByteString
mc_exports  :: !B.ByteString        -- ^ rendered exports
  , ModuleCode -> [ClosureInfo]
mc_closures :: ![ClosureInfo]
  , ModuleCode -> [StaticInfo]
mc_statics  :: ![StaticInfo]
  , ModuleCode -> [ForeignJSRef]
mc_frefs    :: ![ForeignJSRef]
  }

-- | ModuleCode after link with other modules.
--
-- It contains less information than ModuleCode because they have been commoned
-- up into global "metadata" for the whole link.
data CompactedModuleCode = CompactedModuleCode
  { CompactedModuleCode -> Module
cmc_module  :: !Module
  , CompactedModuleCode -> JStat
cmc_js_code :: !JS.JStat
  , CompactedModuleCode -> ByteString
cmc_exports :: !B.ByteString        -- ^ rendered exports
  }

-- | Output JS statements and return the output size in bytes.
hPutJS :: Bool -> Handle -> JS.JStat -> IO Integer
hPutJS :: Bool -> Handle -> JStat -> IO Integer
hPutJS Bool
render_pretty Handle
h = \case
  JS.BlockStat [] -> Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
  JStat
x                -> do
    Integer
before <- Handle -> IO Integer
hTell Handle
h
    if Bool
render_pretty
      then do
        SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDoc SDocContext
defaultJsContext (Bool -> Mode
Ppr.PageMode Bool
True) Handle
h (Bool -> JStat -> SDoc
forall doc. JsRender doc => Bool -> JStat -> doc
pretty Bool
render_pretty JStat
x)
      else do
        BufHandle
bh <- Handle -> IO BufHandle
newBufHandle Handle
h
        BufHandle -> SDocContext -> HDoc -> IO ()
bPutHDoc BufHandle
bh SDocContext
defaultJsContext (Line HDoc -> HDoc
forall doc. IsDoc doc => Line doc -> doc
line (Line HDoc -> HDoc) -> Line HDoc -> HDoc
forall a b. (a -> b) -> a -> b
$ Bool -> JStat -> HLine
forall doc. JsRender doc => Bool -> JStat -> doc
pretty Bool
render_pretty JStat
x)
        BufHandle -> IO ()
bFlush BufHandle
bh
    -- Append an empty line to correctly end the file in a newline
    Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
    Integer
after <- Handle -> IO Integer
hTell Handle
h
    Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$! (Integer
after Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
before)

-- | Link modules and pretty-print them into the given Handle
renderModules
  :: Handle
  -> Bool         -- ^ should we render readable JS for debugging?
  -> [ModuleCode] -- ^ linked code per module
  -> IO LinkerStats
renderModules :: Handle -> Bool -> [ModuleCode] -> IO LinkerStats
renderModules Handle
h Bool
render_pretty [ModuleCode]
mods = do

  -- link modules
  let ([CompactedModuleCode]
compacted_mods, JStat
meta) = [ModuleCode] -> ([CompactedModuleCode], JStat)
linkModules [ModuleCode]
mods

  let
    putJS :: JStat -> IO Integer
putJS   = Bool -> Handle -> JStat -> IO Integer
hPutJS Bool
render_pretty Handle
h

  ---------------------------------------------------------
  -- Pretty-print JavaScript code for all the dependencies.
  --
  -- We have to pretty-print at link time because we want to be able to perform
  -- global link-time optimisations (e.g. renamings) on the whole generated JS
  -- file.

  -- modules themselves
  [(Module, Word64)]
mod_sizes <- [CompactedModuleCode]
-> (CompactedModuleCode -> IO (Module, Word64))
-> IO [(Module, Word64)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CompactedModuleCode]
compacted_mods ((CompactedModuleCode -> IO (Module, Word64))
 -> IO [(Module, Word64)])
-> (CompactedModuleCode -> IO (Module, Word64))
-> IO [(Module, Word64)]
forall a b. (a -> b) -> a -> b
$ \CompactedModuleCode
m -> do

    !Word64
mod_size <- Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JStat -> IO Integer
putJS (JStat -> IO Integer) -> JStat -> IO Integer
forall a b. (a -> b) -> a -> b
$ CompactedModuleCode -> JStat
cmc_js_code CompactedModuleCode
m)
    let !mod_mod :: Module
mod_mod  = CompactedModuleCode -> Module
cmc_module CompactedModuleCode
m
    (Module, Word64) -> IO (Module, Word64)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module
mod_mod, Word64
mod_size)

  -- commoned up metadata
  let meta_opt :: JStat
meta_opt = JStat -> JStat
jsOptimize JStat
meta
  !Word64
meta_length <- Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JStat -> IO Integer
putJS JStat
meta_opt

  -- module exports
  (CompactedModuleCode -> IO ()) -> [CompactedModuleCode] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> IO ())
-> (CompactedModuleCode -> ByteString)
-> CompactedModuleCode
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactedModuleCode -> ByteString
cmc_exports) [CompactedModuleCode]
compacted_mods

  -- stats
  let !link_stats :: LinkerStats
link_stats = LinkerStats
        { bytesPerModule :: Map Module Word64
bytesPerModule     = [(Module, Word64)] -> Map Module Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Module, Word64)]
mod_sizes
        , packedMetaDataSize :: Word64
packedMetaDataSize = Word64
meta_length
        }

  LinkerStats -> IO LinkerStats
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkerStats
link_stats

-- | Render linker stats
renderLinkerStats :: LinkerStats -> String
renderLinkerStats :: LinkerStats -> FilePath
renderLinkerStats LinkerStats
s =
  FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n\n" [FilePath
meta_stats, FilePath
package_stats, FilePath
module_stats] FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n\n"
  where
    meta :: Word64
meta = LinkerStats -> Word64
packedMetaDataSize LinkerStats
s
    meta_stats :: FilePath
meta_stats = FilePath
"number of modules: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> BlockId -> FilePath
forall a. Show a => a -> FilePath
show ([(Module, Word64)] -> BlockId
forall a. [a] -> BlockId
forall (t :: * -> *) a. Foldable t => t a -> BlockId
length [(Module, Word64)]
bytes_per_mod)
                 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\npacked metadata:   " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
meta

    bytes_per_mod :: [(Module, Word64)]
bytes_per_mod = Map Module Word64 -> [(Module, Word64)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Module Word64 -> [(Module, Word64)])
-> Map Module Word64 -> [(Module, Word64)]
forall a b. (a -> b) -> a -> b
$ LinkerStats -> Map Module Word64
bytesPerModule LinkerStats
s

    show_unit :: UnitId -> FilePath
show_unit (UnitId FastString
fs) = FastString -> FilePath
unpackFS FastString
fs

    ps :: Map UnitId Word64
    ps :: Map UnitId Word64
ps = (Word64 -> Word64 -> Word64)
-> [(UnitId, Word64)] -> Map UnitId Word64
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) ([(UnitId, Word64)] -> Map UnitId Word64)
-> ([(Module, Word64)] -> [(UnitId, Word64)])
-> [(Module, Word64)]
-> Map UnitId Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Module, Word64) -> (UnitId, Word64))
-> [(Module, Word64)] -> [(UnitId, Word64)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,Word64
s) -> (Module -> UnitId
moduleUnitId Module
m,Word64
s)) ([(Module, Word64)] -> Map UnitId Word64)
-> [(Module, Word64)] -> Map UnitId Word64
forall a b. (a -> b) -> a -> b
$ [(Module, Word64)]
bytes_per_mod

    pad :: Int -> String -> String
    pad :: BlockId -> FilePath -> FilePath
pad BlockId
n FilePath
t = let l :: BlockId
l = FilePath -> BlockId
forall a. [a] -> BlockId
forall (t :: * -> *) a. Foldable t => t a -> BlockId
length FilePath
t
              in  if BlockId
l BlockId -> BlockId -> Bool
forall a. Ord a => a -> a -> Bool
< BlockId
n then FilePath
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> BlockId -> Char -> FilePath
forall a. BlockId -> a -> [a]
replicate (BlockId
nBlockId -> BlockId -> BlockId
forall a. Num a => a -> a -> a
-BlockId
l) Char
' ' else FilePath
t

    pkgMods :: [[(Module,Word64)]]
    pkgMods :: [[(Module, Word64)]]
pkgMods = ((Module, Word64) -> (Module, Word64) -> Bool)
-> [(Module, Word64)] -> [[(Module, Word64)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (UnitId -> UnitId -> Bool)
-> ((Module, Word64) -> UnitId)
-> (Module, Word64)
-> (Module, Word64)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Module -> UnitId
moduleUnitId (Module -> UnitId)
-> ((Module, Word64) -> Module) -> (Module, Word64) -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module, Word64) -> Module
forall a b. (a, b) -> a
fst)) [(Module, Word64)]
bytes_per_mod

    showMod :: (Module, Word64) -> String
    showMod :: (Module, Word64) -> FilePath
showMod (Module
m,Word64
s) = BlockId -> FilePath -> FilePath
pad BlockId
40 (FilePath
"    " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Module -> FilePath
moduleStableString Module
m FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":") FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n"

    package_stats :: String
    package_stats :: FilePath
package_stats = FilePath
"code size summary per package (in bytes):\n\n"
                     FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ((UnitId, Word64) -> FilePath) -> [(UnitId, Word64)] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(UnitId
p,Word64
s) -> BlockId -> FilePath -> FilePath
pad BlockId
25 (UnitId -> FilePath
show_unit UnitId
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":") FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n") (Map UnitId Word64 -> [(UnitId, Word64)]
forall k a. Map k a -> [(k, a)]
M.toList Map UnitId Word64
ps)

    module_stats :: String
    module_stats :: FilePath
module_stats = FilePath
"code size per module (in bytes):\n\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines (([(Module, Word64)] -> FilePath)
-> [[(Module, Word64)]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (((Module, Word64) -> FilePath) -> [(Module, Word64)] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Module, Word64) -> FilePath
showMod) [[(Module, Word64)]]
pkgMods)


getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
getPackageArchives StgToJSConfig
cfg UnitEnv
unit_env [UnitId]
units =
  (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [ ShortText -> FilePath
ST.unpack ShortText
p FilePath -> FilePath -> FilePath
</> FilePath
"lib" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ShortText -> FilePath
ST.unpack ShortText
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
profSuff FilePath -> FilePath -> FilePath
<.> FilePath
"a"
                        | UnitId
u <- [UnitId]
units
                        , ShortText
p <- UnitState -> UnitId -> [ShortText]
getInstalledPackageLibDirs UnitState
ue_state UnitId
u
                        , ShortText
l <- UnitState -> UnitId -> [ShortText]
getInstalledPackageHsLibs  UnitState
ue_state UnitId
u
                        ]
  where
    ue_state :: UnitState
ue_state = (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env

    -- XXX the profiling library name is probably wrong now
    profSuff :: FilePath
profSuff | StgToJSConfig -> Bool
csProf StgToJSConfig
cfg = FilePath
"_p"
             | Bool
otherwise  = FilePath
""


-- | Combine rts.js, lib.js, out.js to all.js that can be run
-- directly with node.js or SpiderMonkey jsshell
combineFiles :: JSLinkConfig
             -> Bool -- has clibs.js
             -> FilePath
             -> IO ()
combineFiles :: JSLinkConfig -> Bool -> FilePath -> IO ()
combineFiles JSLinkConfig
cfg Bool
has_clibs FilePath
fp = do
  let files :: [FilePath]
files = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
fp </>) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes
        [ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"rts.js"
        , FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"lib.js"
        , FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"out.js"
        , if Bool
has_clibs      then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"clibs.js" else Maybe FilePath
forall a. Maybe a
Nothing
        , if JSLinkConfig -> Bool
lcNoHsMain JSLinkConfig
cfg then Maybe FilePath
forall a. Maybe a
Nothing else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"runmain.js"
        ]
  FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
"all.js") IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
i ->
      FilePath -> IO ByteString
B.readFile FilePath
i IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> ByteString -> IO ()
B.hPut Handle
h

-- | write the index.html file that loads the program if it does not exit
writeHtml
  :: FilePath -- ^ output directory
  -> IO ()
writeHtml :: FilePath -> IO ()
writeHtml FilePath
out = do
  let htmlFile :: FilePath
htmlFile = FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"index.html"
  Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
htmlFile
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
e (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> ByteString -> IO ()
B.writeFile FilePath
htmlFile ByteString
templateHtml


templateHtml :: B.ByteString
templateHtml :: ByteString
templateHtml =
  ByteString
"<!DOCTYPE html>\n\
  \<html>\n\
  \  <head>\n\
  \  </head>\n\
  \  <body>\n\
  \  </body>\n\
  \  <script language=\"javascript\" src=\"all.js\" defer></script>\n\
  \</html>"

-- | write the runmain.js file that will be run with defer so that it runs after
-- index.html is loaded
writeRunMain
  :: FilePath -- ^ output directory
  -> UseEmccRts
  -> IO ()
writeRunMain :: FilePath -> UseEmccRts -> IO ()
writeRunMain FilePath
out UseEmccRts
use_emcc_rts = do
  let runMainFile :: FilePath
runMainFile = FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"runmain.js"
  FilePath -> ByteString -> IO ()
B.writeFile FilePath
runMainFile (UseEmccRts -> ByteString
runMainJS UseEmccRts
use_emcc_rts)

newtype UseEmccRts = UseEmccRts Bool

runMainJS :: UseEmccRts -> B.ByteString
runMainJS :: UseEmccRts -> ByteString
runMainJS (UseEmccRts Bool
use_emcc_rts) = if Bool
use_emcc_rts
  then ByteString
"Module['onRuntimeInitialized'] = function() {\n\
       \h$initEmscriptenHeap();\n\
       \h$main(h$mainZCZCMainzimain);\n\
       \}\n"
  else ByteString
"h$main(h$mainZCZCMainzimain);\n"

writeRunner :: JSLinkConfig -- ^ Settings
            -> FilePath     -- ^ Output directory
            -> IO ()
writeRunner :: JSLinkConfig -> FilePath -> IO ()
writeRunner JSLinkConfig
_settings FilePath
out = do
  FilePath
cd    <- IO FilePath
getCurrentDirectory
  let arch_os :: ArchOS
arch_os = ArchOS
hostPlatformArchOS
  let runner :: FilePath
runner  = FilePath
cd FilePath -> FilePath -> FilePath
</> ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os Bool
False (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> FilePath
dropExtension FilePath
out))
      srcFile :: FilePath
srcFile = FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"all" FilePath -> FilePath -> FilePath
<.> FilePath
"js"
      nodePgm :: B.ByteString
      nodePgm :: ByteString
nodePgm = ByteString
"node"
  ByteString
src <- FilePath -> IO ByteString
B.readFile (FilePath
cd FilePath -> FilePath -> FilePath
</> FilePath
srcFile)
  FilePath -> ByteString -> IO ()
B.writeFile FilePath
runner (ByteString
"#!/usr/bin/env " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nodePgm ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
src)
  Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
runner
  FilePath -> Permissions -> IO ()
setPermissions FilePath
runner (Permissions
perms {executable = True})

rtsExterns :: FastString
rtsExterns :: FastString
rtsExterns =
  FastString
"// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<>
  [FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat ((BlockId -> FastString) -> [BlockId] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> FastString
"/** @type {*} */\nObject.d" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FilePath -> FastString
mkFastString (BlockId -> FilePath
forall a. Show a => a -> FilePath
show BlockId
x) FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
";\n")
               [(BlockId
7::Int)..BlockId
16384])

writeExterns :: FilePath -> IO ()
writeExterns :: FilePath -> IO ()
writeExterns FilePath
out = FilePath -> FilePath -> IO ()
writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"all.js.externs")
  (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
unpackFS FastString
rtsExterns

-- | Get all block dependencies for a given set of roots
--
-- Returns the update block info map and the blocks.
getDeps :: Map Module LocatedBlockInfo     -- ^ Block info per module
        -> (Module -> IO LocatedBlockInfo) -- ^ Used to load block info if missing
        -> Set ExportedFun                 -- ^ start here
        -> Set BlockRef                    -- ^ and also link these
        -> IO (Map Module LocatedBlockInfo, Set BlockRef)
getDeps :: Map Module LocatedBlockInfo
-> (Module -> IO LocatedBlockInfo)
-> Set ExportedFun
-> Set BlockRef
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
getDeps Map Module LocatedBlockInfo
init_infos Module -> IO LocatedBlockInfo
load_info Set ExportedFun
root_funs Set BlockRef
root_blocks = Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> [ExportedFun]
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_funs Map Module LocatedBlockInfo
init_infos Set BlockRef
forall a. Set a
S.empty Set BlockRef
root_blocks (Set ExportedFun -> [ExportedFun]
forall a. Set a -> [a]
S.toList Set ExportedFun
root_funs)
  where
    -- A block may depend on:
    --  1. other blocks from the same module
    --  2. exported functions from another module
    --
    -- Process:
    --  1. We use the BlockInfos to find the block corresponding to every
    --  exported root functions.
    --
    --  2. We had these blocks to the set of root_blocks if they aren't already
    --  added to the result.
    --
    --  3. Then we traverse the root_blocks to find their dependencies and we
    --  add them to root_blocks (if they aren't already added to the result) and
    --  to root_funs.
    --
    --  4. back to 1

    lookup_info :: Map Module LocatedBlockInfo
-> Module -> IO (Map Module LocatedBlockInfo, BlockInfo)
lookup_info Map Module LocatedBlockInfo
infos Module
mod = case Module -> Map Module LocatedBlockInfo -> Maybe LocatedBlockInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mod Map Module LocatedBlockInfo
infos of
      Just LocatedBlockInfo
info -> (Map Module LocatedBlockInfo, BlockInfo)
-> IO (Map Module LocatedBlockInfo, BlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Module LocatedBlockInfo
infos, LocatedBlockInfo -> BlockInfo
lbi_info LocatedBlockInfo
info)
      Maybe LocatedBlockInfo
Nothing   -> do
        -- load info and update cache with it
        LocatedBlockInfo
info <- Module -> IO LocatedBlockInfo
load_info Module
mod
        (Map Module LocatedBlockInfo, BlockInfo)
-> IO (Map Module LocatedBlockInfo, BlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module
-> LocatedBlockInfo
-> Map Module LocatedBlockInfo
-> Map Module LocatedBlockInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Module
mod LocatedBlockInfo
info Map Module LocatedBlockInfo
infos, LocatedBlockInfo -> BlockInfo
lbi_info LocatedBlockInfo
info)

    traverse_blocks
      :: Map Module LocatedBlockInfo
      -> Set BlockRef
      -> Set BlockRef
      -> IO (Map Module LocatedBlockInfo, Set BlockRef)
    traverse_blocks :: Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_blocks Map Module LocatedBlockInfo
infos Set BlockRef
result Set BlockRef
open = case Set BlockRef -> Maybe (BlockRef, Set BlockRef)
forall a. Set a -> Maybe (a, Set a)
S.minView Set BlockRef
open of
      Maybe (BlockRef, Set BlockRef)
Nothing -> (Map Module LocatedBlockInfo, Set BlockRef)
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Module LocatedBlockInfo
infos, Set BlockRef
result)
      Just (BlockRef
ref, Set BlockRef
open') -> do
          let mod :: Module
mod = BlockRef -> Module
block_ref_mod BlockRef
ref
          !(Map Module LocatedBlockInfo
infos',BlockInfo
info) <- Map Module LocatedBlockInfo
-> Module -> IO (Map Module LocatedBlockInfo, BlockInfo)
lookup_info Map Module LocatedBlockInfo
infos Module
mod
          let block :: BlockDeps
block =  BlockInfo -> Array BlockId BlockDeps
bi_block_deps BlockInfo
info Array BlockId BlockDeps -> BlockId -> BlockDeps
forall i e. Ix i => Array i e -> i -> e
! BlockRef -> BlockId
block_ref_idx BlockRef
ref
              result' :: Set BlockRef
result' = BlockRef -> Set BlockRef -> Set BlockRef
forall a. Ord a => a -> Set a -> Set a
S.insert BlockRef
ref Set BlockRef
result
              to_block_ref :: BlockId -> BlockRef
to_block_ref BlockId
i = BlockRef
                                { block_ref_mod :: Module
block_ref_mod = Module
mod
                                , block_ref_idx :: BlockId
block_ref_idx = BlockId
i
                                }
          Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> [ExportedFun]
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_funs Map Module LocatedBlockInfo
infos' Set BlockRef
result'
             (Set BlockRef -> Set BlockRef -> [BlockRef] -> Set BlockRef
addOpen Set BlockRef
result' Set BlockRef
open' ([BlockRef] -> Set BlockRef) -> [BlockRef] -> Set BlockRef
forall a b. (a -> b) -> a -> b
$
               (BlockId -> BlockRef) -> [BlockId] -> [BlockRef]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> BlockRef
to_block_ref (BlockDeps -> [BlockId]
blockBlockDeps BlockDeps
block)) (BlockDeps -> [ExportedFun]
blockFunDeps BlockDeps
block)

    traverse_funs
      :: Map Module LocatedBlockInfo
      -> Set BlockRef
      -> Set BlockRef
      -> [ExportedFun]
      -> IO (Map Module LocatedBlockInfo, Set BlockRef)
    traverse_funs :: Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> [ExportedFun]
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_funs Map Module LocatedBlockInfo
infos Set BlockRef
result Set BlockRef
open = \case
      []     -> Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_blocks Map Module LocatedBlockInfo
infos Set BlockRef
result Set BlockRef
open
      (ExportedFun
f:[ExportedFun]
fs) -> do
        let mod :: Module
mod = ExportedFun -> Module
funModule ExportedFun
f
        -- lookup module block info for the module that exports the function
        !(Map Module LocatedBlockInfo
infos',BlockInfo
info) <- Map Module LocatedBlockInfo
-> Module -> IO (Map Module LocatedBlockInfo, BlockInfo)
lookup_info Map Module LocatedBlockInfo
infos Module
mod
        -- lookup block index associated to the function in the block info
        case ExportedFun -> Map ExportedFun BlockId -> Maybe BlockId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExportedFun
f (BlockInfo -> Map ExportedFun BlockId
bi_exports BlockInfo
info) of
          Maybe BlockId
Nothing  -> FilePath -> SDoc -> IO (Map Module LocatedBlockInfo, Set BlockRef)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"exported function not found: " (SDoc -> IO (Map Module LocatedBlockInfo, Set BlockRef))
-> SDoc -> IO (Map Module LocatedBlockInfo, Set BlockRef)
forall a b. (a -> b) -> a -> b
$ ExportedFun -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExportedFun
f
          Just BlockId
idx -> do
            let fun_block_ref :: BlockRef
fun_block_ref = BlockRef
                   { block_ref_mod :: Module
block_ref_mod = Module
mod
                   , block_ref_idx :: BlockId
block_ref_idx = BlockId
idx
                   }
            -- always add the module "global block" when we link a module
            let global_block_ref :: BlockRef
global_block_ref = BlockRef
                   { block_ref_mod :: Module
block_ref_mod = Module
mod
                   , block_ref_idx :: BlockId
block_ref_idx = BlockId
0
                   }
            Map Module LocatedBlockInfo
-> Set BlockRef
-> Set BlockRef
-> [ExportedFun]
-> IO (Map Module LocatedBlockInfo, Set BlockRef)
traverse_funs Map Module LocatedBlockInfo
infos' Set BlockRef
result (Set BlockRef -> Set BlockRef -> [BlockRef] -> Set BlockRef
addOpen Set BlockRef
result Set BlockRef
open [BlockRef
fun_block_ref,BlockRef
global_block_ref]) [ExportedFun]
fs

    -- extend the open block set with new blocks that are not already in the
    -- result block set nor in the open block set.
    addOpen
      :: Set BlockRef
      -> Set BlockRef
      -> [BlockRef]
      -> Set BlockRef
    addOpen :: Set BlockRef -> Set BlockRef -> [BlockRef] -> Set BlockRef
addOpen Set BlockRef
result Set BlockRef
open [BlockRef]
new_blocks =
      let alreadyLinked :: BlockRef -> Bool
alreadyLinked BlockRef
s = BlockRef -> Set BlockRef -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member BlockRef
s Set BlockRef
result Bool -> Bool -> Bool
|| BlockRef -> Set BlockRef -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member BlockRef
s Set BlockRef
open
      in  Set BlockRef
open Set BlockRef -> Set BlockRef -> Set BlockRef
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [BlockRef] -> Set BlockRef
forall a. Ord a => [a] -> Set a
S.fromList ((BlockRef -> Bool) -> [BlockRef] -> [BlockRef]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (BlockRef -> Bool) -> BlockRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockRef -> Bool
alreadyLinked) [BlockRef]
new_blocks)

-- | collect dependencies for a set of roots
collectModuleCodes :: ArchiveCache -> LinkPlan -> IO [ModuleCode]
collectModuleCodes :: ArchiveCache -> LinkPlan -> IO [ModuleCode]
collectModuleCodes ArchiveCache
ar_cache LinkPlan
link_plan = do

  let block_info :: Map Module LocatedBlockInfo
block_info = LinkPlan -> Map Module LocatedBlockInfo
lkp_block_info LinkPlan
link_plan
  let blocks :: Set BlockRef
blocks     = LinkPlan -> Set BlockRef
lkp_dep_blocks LinkPlan
link_plan

  -- we're going to load all the blocks. Instead of doing this randomly, we
  -- group them by module first.
  let module_blocks :: Map Module BlockIds
      module_blocks :: Map Module BlockIds
module_blocks = (BlockIds -> BlockIds -> BlockIds)
-> [(Module, BlockIds)] -> Map Module BlockIds
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith BlockIds -> BlockIds -> BlockIds
IS.union ([(Module, BlockIds)] -> Map Module BlockIds)
-> [(Module, BlockIds)] -> Map Module BlockIds
forall a b. (a -> b) -> a -> b
$
                      (BlockRef -> (Module, BlockIds))
-> [BlockRef] -> [(Module, BlockIds)]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockRef
ref -> (BlockRef -> Module
block_ref_mod BlockRef
ref, BlockId -> BlockIds
IS.singleton (BlockRef -> BlockId
block_ref_idx BlockRef
ref))) (Set BlockRef -> [BlockRef]
forall a. Set a -> [a]
S.toList Set BlockRef
blocks)

  -- GHCJS had this comment: "read ghc-prim first, since we depend on that for
  -- static initialization". Not sure if it's still true as we haven't ported
  -- the compactor yet. Still we sort to read ghc-prim blocks first just in
  -- case.
  let pred :: (Module, b) -> Bool
pred (Module, b)
x = Module -> UnitId
moduleUnitId ((Module, b) -> Module
forall a b. (a, b) -> a
fst (Module, b)
x) UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
primUnitId
      cmp :: (Module, b) -> (Module, b) -> Ordering
cmp (Module, b)
x (Module, b)
y = case ((Module, b) -> Bool
forall {b}. (Module, b) -> Bool
pred (Module, b)
x, (Module, b) -> Bool
forall {b}. (Module, b) -> Bool
pred (Module, b)
y) of
        (Bool
True,Bool
False)  -> Ordering
LT
        (Bool
False,Bool
True)  -> Ordering
GT
        (Bool
True,Bool
True)   -> Ordering
EQ
        (Bool
False,Bool
False) -> Ordering
EQ

      sorted_module_blocks :: [(Module,BlockIds)]
      sorted_module_blocks :: [(Module, BlockIds)]
sorted_module_blocks = ((Module, BlockIds) -> (Module, BlockIds) -> Ordering)
-> [(Module, BlockIds)] -> [(Module, BlockIds)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Module, BlockIds) -> (Module, BlockIds) -> Ordering
forall {b} {b}. (Module, b) -> (Module, b) -> Ordering
cmp (Map Module BlockIds -> [(Module, BlockIds)]
forall k a. Map k a -> [(k, a)]
M.toList Map Module BlockIds
module_blocks)

  -- load blocks
  [(Module, BlockIds)]
-> ((Module, BlockIds) -> IO ModuleCode) -> IO [ModuleCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Module, BlockIds)]
sorted_module_blocks (((Module, BlockIds) -> IO ModuleCode) -> IO [ModuleCode])
-> ((Module, BlockIds) -> IO ModuleCode) -> IO [ModuleCode]
forall a b. (a -> b) -> a -> b
$ \(Module
mod,BlockIds
bids) -> do
    case Module -> Map Module LocatedBlockInfo -> Maybe LocatedBlockInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mod Map Module LocatedBlockInfo
block_info of
      Maybe LocatedBlockInfo
Nothing  -> FilePath -> SDoc -> IO ModuleCode
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"collectModuleCodes: couldn't find block info for module" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
      Just LocatedBlockInfo
lbi -> ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode
extractBlocks ArchiveCache
ar_cache LocatedBlockInfo
lbi BlockIds
bids

extractBlocks :: ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode
extractBlocks :: ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode
extractBlocks ArchiveCache
ar_state LocatedBlockInfo
lbi BlockIds
blocks = do
  case LocatedBlockInfo -> BlockLocation
lbi_loc LocatedBlockInfo
lbi of
    ObjectFile FilePath
fp -> do
      [ObjBlock]
us <- FilePath -> BlockIds -> IO [ObjBlock]
readObjectBlocks FilePath
fp BlockIds
blocks
      ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjBlock] -> ModuleCode
collectCode [ObjBlock]
us)
    ArchiveFile FilePath
a -> do
      Object
obj <- ArchiveCache -> Module -> FilePath -> IO Object
readArObject ArchiveCache
ar_state Module
mod FilePath
a
      [ObjBlock]
us <- Object -> BlockIds -> IO [ObjBlock]
getObjectBlocks Object
obj BlockIds
blocks
      ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjBlock] -> ModuleCode
collectCode [ObjBlock]
us)
    InMemory FilePath
_n Object
obj -> do
      [ObjBlock]
us <- Object -> BlockIds -> IO [ObjBlock]
getObjectBlocks Object
obj BlockIds
blocks
      ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjBlock] -> ModuleCode
collectCode [ObjBlock]
us)
  where
    mod :: Module
mod           = BlockInfo -> Module
bi_module (LocatedBlockInfo -> BlockInfo
lbi_info LocatedBlockInfo
lbi)
    newline :: ByteString
newline       = FilePath -> ByteString
BC.pack FilePath
"\n"
    mk_exports :: [ObjBlock] -> ByteString
mk_exports    = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ([ObjBlock] -> [ByteString]) -> [ObjBlock] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse ByteString
newline ([ByteString] -> [ByteString])
-> ([ObjBlock] -> [ByteString]) -> [ObjBlock] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) ([ByteString] -> [ByteString])
-> ([ObjBlock] -> [ByteString]) -> [ObjBlock] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjBlock -> ByteString) -> [ObjBlock] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ObjBlock -> ByteString
oiRaw
    mk_js_code :: [ObjBlock] -> JStat
mk_js_code    = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat)
-> ([ObjBlock] -> [JStat]) -> [ObjBlock] -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjBlock -> JStat) -> [ObjBlock] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map ObjBlock -> JStat
oiStat
    collectCode :: [ObjBlock] -> ModuleCode
collectCode [ObjBlock]
l = ModuleCode
                      { mc_module :: Module
mc_module   = Module
mod
                      , mc_js_code :: JStat
mc_js_code  = [ObjBlock] -> JStat
mk_js_code [ObjBlock]
l
                      , mc_exports :: ByteString
mc_exports  = [ObjBlock] -> ByteString
mk_exports [ObjBlock]
l
                      , mc_closures :: [ClosureInfo]
mc_closures = (ObjBlock -> [ClosureInfo]) -> [ObjBlock] -> [ClosureInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjBlock -> [ClosureInfo]
oiClInfo [ObjBlock]
l
                      , mc_statics :: [StaticInfo]
mc_statics  = (ObjBlock -> [StaticInfo]) -> [ObjBlock] -> [StaticInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjBlock -> [StaticInfo]
oiStatic [ObjBlock]
l
                      , mc_frefs :: [ForeignJSRef]
mc_frefs    = (ObjBlock -> [ForeignJSRef]) -> [ObjBlock] -> [ForeignJSRef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjBlock -> [ForeignJSRef]
oiFImports [ObjBlock]
l
                      }

-- | Load an archive in memory and store it in the cache for future loads.
loadArchive :: ArchiveCache -> FilePath -> IO Ar.Archive
loadArchive :: ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
ar_file = do
  Map FilePath Archive
loaded_ars <- IORef (Map FilePath Archive) -> IO (Map FilePath Archive)
forall a. IORef a -> IO a
readIORef (ArchiveCache -> IORef (Map FilePath Archive)
loadedArchives ArchiveCache
ar_cache)
  case FilePath -> Map FilePath Archive -> Maybe Archive
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
ar_file Map FilePath Archive
loaded_ars of
    Just Archive
a -> Archive -> IO Archive
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
a
    Maybe Archive
Nothing -> do
      Archive
a <- FilePath -> IO Archive
Ar.loadAr FilePath
ar_file
      IORef (Map FilePath Archive)
-> (Map FilePath Archive -> Map FilePath Archive) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ArchiveCache -> IORef (Map FilePath Archive)
loadedArchives ArchiveCache
ar_cache) (FilePath -> Archive -> Map FilePath Archive -> Map FilePath Archive
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
ar_file Archive
a)
      Archive -> IO Archive
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
a


readArObject :: ArchiveCache -> Module -> FilePath -> IO Object
readArObject :: ArchiveCache -> Module -> FilePath -> IO Object
readArObject ArchiveCache
ar_cache Module
mod FilePath
ar_file = do
  Ar.Archive [ArchiveEntry]
entries <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
ar_file

  -- look for the right object in archive
  let go_entries :: [ArchiveEntry] -> IO Object
go_entries = \case
        -- XXX this shouldn't be an exception probably
        [] -> FilePath -> IO Object
forall a. HasCallStack => FilePath -> a
panic (FilePath -> IO Object) -> FilePath -> IO Object
forall a b. (a -> b) -> a -> b
$ FilePath
"could not find object for module "
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in "
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ar_file

        (ArchiveEntry
e:[ArchiveEntry]
es) -> do
          let bs :: ByteString
bs = ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
e
          BinHandle
bh <- ByteString -> IO BinHandle
unsafeUnpackBinBuffer ByteString
bs
          BinHandle -> IO (Either FilePath ModuleName)
getObjectHeader BinHandle
bh IO (Either FilePath ModuleName)
-> (Either FilePath ModuleName -> IO Object) -> IO Object
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left FilePath
_         -> [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
es -- not a valid object entry
            Right ModuleName
mod_name
              | ModuleName
mod_name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
              -> [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
es -- not the module we're looking for
              | Bool
otherwise
              -> BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name -- found it

  [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
entries

-- | dependencies for the RTS, these need to be always linked
rtsDeps :: ([UnitId], Set ExportedFun)
rtsDeps :: ([UnitId], Set ExportedFun)
rtsDeps =
  ( [UnitId
ghcInternalUnitId, UnitId
primUnitId]
  , [ExportedFun] -> Set ExportedFun
forall a. Ord a => [a] -> Set a
S.fromList ([ExportedFun] -> Set ExportedFun)
-> [ExportedFun] -> Set ExportedFun
forall a b. (a -> b) -> a -> b
$ [[ExportedFun]] -> [ExportedFun]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Conc.Sync"
          [FastString
"reportError"]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Control.Exception.Base"
          [FastString
"nonTermination"]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Exception.Type"
          [ FastString
"SomeException"
          , FastString
"underflowException"
          , FastString
"overflowException"
          , FastString
"divZeroException"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.TopHandler"
          [ FastString
"runMainIO"
          , FastString
"topHandler"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Base"
          [FastString
"$fMonadIO"]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Maybe"
          [ FastString
"Nothing"
          , FastString
"Just"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.Ptr"
          [FastString
"Ptr"]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.JS.Prim"
          [ FastString
"JSVal"
          , FastString
"JSException"
          , FastString
"$fShowJSException"
          , FastString
"$fExceptionJSException"
          , FastString
"resolve"
          , FastString
"resolveIO"
          , FastString
"toIO"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkInternalFuns FastString
"GHC.Internal.JS.Prim.Internal"
          [ FastString
"wouldBlock"
          , FastString
"blockedIndefinitelyOnMVar"
          , FastString
"blockedIndefinitelyOnSTM"
          , FastString
"ignoreException"
          , FastString
"setCurrentThreadResultException"
          , FastString
"setCurrentThreadResultValue"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkPrimFuns FastString
"GHC.Types"
          [ FastString
":"
          , FastString
"[]"
          ]
      , FastString -> [FastString] -> [ExportedFun]
mkPrimFuns FastString
"GHC.Tuple"
          [ FastString
"(,)"
          , FastString
"(,,)"
          , FastString
"(,,,)"
          , FastString
"(,,,,)"
          , FastString
"(,,,,,)"
          , FastString
"(,,,,,,)"
          , FastString
"(,,,,,,,)"
          , FastString
"(,,,,,,,,)"
          , FastString
"(,,,,,,,,,)"
          ]
      ]
  )

-- | Export the functions in @ghc-internal@
mkInternalFuns :: FastString -> [FastString] -> [ExportedFun]
mkInternalFuns :: FastString -> [FastString] -> [ExportedFun]
mkInternalFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
ghcInternalUnitId

-- | Export the Prim functions
mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
mkPrimFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
primUnitId

-- | Given a @UnitId@, a module name, and a set of symbols in the module,
-- package these into an @ExportedFun@.
mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
uid FastString
mod_name [FastString]
symbols = Module -> [FastString] -> [ExportedFun]
mkExportedModFuns Module
mod [FastString]
names
  where
    mod :: Module
mod        = GenUnit UnitId -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> GenUnit UnitId
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
uid)) (FastString -> ModuleName
mkModuleNameFS FastString
mod_name)
    names :: [FastString]
names      = (FastString -> FastString) -> [FastString] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Module -> FastString -> FastString
mkJsSymbol Bool
True Module
mod) [FastString]
symbols

-- | Given a @Module@ and a set of symbols in the module, package these into an
-- @ExportedFun@.
mkExportedModFuns :: Module -> [FastString] -> [ExportedFun]
mkExportedModFuns :: Module -> [FastString] -> [ExportedFun]
mkExportedModFuns Module
mod [FastString]
symbols = (FastString -> ExportedFun) -> [FastString] -> [ExportedFun]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> ExportedFun
mk_fun [FastString]
symbols
  where
    mk_fun :: FastString -> ExportedFun
mk_fun FastString
sym = Module -> LexicalFastString -> ExportedFun
ExportedFun Module
mod (FastString -> LexicalFastString
LexicalFastString FastString
sym)

-- | read all dependency data from the to-be-linked files
loadObjBlockInfo
  :: [FilePath] -- ^ object files to link
  -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadObjBlockInfo :: [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadObjBlockInfo [FilePath]
objs = ([LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef])
prepareLoadedDeps ([LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef]))
-> ([Maybe LocatedBlockInfo] -> [LocatedBlockInfo])
-> [Maybe LocatedBlockInfo]
-> (Map Module LocatedBlockInfo, [BlockRef])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe LocatedBlockInfo] -> [LocatedBlockInfo]
forall a. [Maybe a] -> [a]
catMaybes) ([Maybe LocatedBlockInfo]
 -> (Map Module LocatedBlockInfo, [BlockRef]))
-> IO [Maybe LocatedBlockInfo]
-> IO (Map Module LocatedBlockInfo, [BlockRef])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe LocatedBlockInfo))
-> [FilePath] -> IO [Maybe LocatedBlockInfo]
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 FilePath -> IO (Maybe LocatedBlockInfo)
readBlockInfoFromObj [FilePath]
objs

-- | Load dependencies for the Linker from Ar
loadArchiveBlockInfo :: ArchiveCache -> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadArchiveBlockInfo :: ArchiveCache
-> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadArchiveBlockInfo ArchiveCache
ar_cache [FilePath]
archives = do
  [[LocatedBlockInfo]]
archDeps <- [FilePath]
-> (FilePath -> IO [LocatedBlockInfo]) -> IO [[LocatedBlockInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
archives ((FilePath -> IO [LocatedBlockInfo]) -> IO [[LocatedBlockInfo]])
-> (FilePath -> IO [LocatedBlockInfo]) -> IO [[LocatedBlockInfo]]
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
    (Ar.Archive [ArchiveEntry]
entries) <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
file
    [Maybe LocatedBlockInfo] -> [LocatedBlockInfo]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LocatedBlockInfo] -> [LocatedBlockInfo])
-> IO [Maybe LocatedBlockInfo] -> IO [LocatedBlockInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchiveEntry -> IO (Maybe LocatedBlockInfo))
-> [ArchiveEntry] -> IO [Maybe LocatedBlockInfo]
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 (FilePath -> ArchiveEntry -> IO (Maybe LocatedBlockInfo)
readEntry FilePath
file) [ArchiveEntry]
entries
  (Map Module LocatedBlockInfo, [BlockRef])
-> IO (Map Module LocatedBlockInfo, [BlockRef])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef])
prepareLoadedDeps ([LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef]))
-> [LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef])
forall a b. (a -> b) -> a -> b
$ [[LocatedBlockInfo]] -> [LocatedBlockInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LocatedBlockInfo]]
archDeps)
    where
      readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe LocatedBlockInfo)
      readEntry :: FilePath -> ArchiveEntry -> IO (Maybe LocatedBlockInfo)
readEntry FilePath
ar_file ArchiveEntry
ar_entry = do
          let bs :: ByteString
bs = ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
ar_entry
          BinHandle
bh <- ByteString -> IO BinHandle
unsafeUnpackBinBuffer ByteString
bs
          BinHandle -> IO (Either FilePath ModuleName)
getObjectHeader BinHandle
bh IO (Either FilePath ModuleName)
-> (Either FilePath ModuleName -> IO (Maybe LocatedBlockInfo))
-> IO (Maybe LocatedBlockInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left FilePath
_         -> Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LocatedBlockInfo
forall a. Maybe a
Nothing -- not a valid object entry
            Right ModuleName
mod_name -> do
              Object
obj <- BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name
              let !info :: BlockInfo
info = Object -> BlockInfo
objBlockInfo Object
obj
              Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo))
-> Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a b. (a -> b) -> a -> b
$ LocatedBlockInfo -> Maybe LocatedBlockInfo
forall a. a -> Maybe a
Just (BlockLocation -> BlockInfo -> LocatedBlockInfo
LocatedBlockInfo (FilePath -> BlockLocation
ArchiveFile FilePath
ar_file) BlockInfo
info)

prepareLoadedDeps :: [LocatedBlockInfo]
                  -> (Map Module LocatedBlockInfo, [BlockRef])
prepareLoadedDeps :: [LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef])
prepareLoadedDeps [LocatedBlockInfo]
lbis = (Map Module LocatedBlockInfo
module_blocks, [BlockRef]
must_link)
  where
    must_link :: [BlockRef]
must_link     = (LocatedBlockInfo -> [BlockRef])
-> [LocatedBlockInfo] -> [BlockRef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BlockInfo -> [BlockRef]
requiredBlocks (BlockInfo -> [BlockRef])
-> (LocatedBlockInfo -> BlockInfo)
-> LocatedBlockInfo
-> [BlockRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedBlockInfo -> BlockInfo
lbi_info) [LocatedBlockInfo]
lbis
    module_blocks :: Map Module LocatedBlockInfo
module_blocks = [(Module, LocatedBlockInfo)] -> Map Module LocatedBlockInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Module, LocatedBlockInfo)] -> Map Module LocatedBlockInfo)
-> [(Module, LocatedBlockInfo)] -> Map Module LocatedBlockInfo
forall a b. (a -> b) -> a -> b
$ (LocatedBlockInfo -> (Module, LocatedBlockInfo))
-> [LocatedBlockInfo] -> [(Module, LocatedBlockInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\LocatedBlockInfo
d -> (BlockInfo -> Module
bi_module (LocatedBlockInfo -> BlockInfo
lbi_info LocatedBlockInfo
d), LocatedBlockInfo
d)) [LocatedBlockInfo]
lbis

requiredBlocks :: BlockInfo -> [BlockRef]
requiredBlocks :: BlockInfo -> [BlockRef]
requiredBlocks BlockInfo
d = (BlockId -> BlockRef) -> [BlockId] -> [BlockRef]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> BlockRef
mk_block_ref (BlockIds -> [BlockId]
IS.toList (BlockIds -> [BlockId]) -> BlockIds -> [BlockId]
forall a b. (a -> b) -> a -> b
$ BlockInfo -> BlockIds
bi_must_link BlockInfo
d)
  where
    mk_block_ref :: BlockId -> BlockRef
mk_block_ref BlockId
i = BlockRef
                      { block_ref_mod :: Module
block_ref_mod = BlockInfo -> Module
bi_module BlockInfo
d
                      , block_ref_idx :: BlockId
block_ref_idx = BlockId
i
                      }

-- | read block info from an object that might have already been into memory
-- pulls in all Deps from an archive
readBlockInfoFromObj :: FilePath -> IO (Maybe LocatedBlockInfo)
readBlockInfoFromObj :: FilePath -> IO (Maybe LocatedBlockInfo)
readBlockInfoFromObj FilePath
file = do
  FilePath -> IO (Maybe BlockInfo)
readObjectBlockInfo FilePath
file IO (Maybe BlockInfo)
-> (Maybe BlockInfo -> IO (Maybe LocatedBlockInfo))
-> IO (Maybe LocatedBlockInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe BlockInfo
Nothing   -> Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LocatedBlockInfo
forall a. Maybe a
Nothing
    Just BlockInfo
info -> Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo))
-> Maybe LocatedBlockInfo -> IO (Maybe LocatedBlockInfo)
forall a b. (a -> b) -> a -> b
$ LocatedBlockInfo -> Maybe LocatedBlockInfo
forall a. a -> Maybe a
Just (BlockLocation -> BlockInfo -> LocatedBlockInfo
LocatedBlockInfo (FilePath -> BlockLocation
ObjectFile FilePath
file) BlockInfo
info)


-- | Embed a JS file into a JS object .o file
--
-- JS files may contain option pragmas of the form: //#OPTIONS:
-- One of those is //#OPTIONS:CPP. When it is set, we append some common CPP
-- definitions to the file and call cpp on it.
--
-- Other options (e.g. EMCC additional flags for link time) are stored in the
-- JS object header. See JSOptions.
embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO ()
embedJsFile :: Logger
-> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO ()
embedJsFile Logger
logger DynFlags
dflags TmpFs
tmpfs UnitEnv
unit_env FilePath
input_fn FilePath
output_fn = do
  let profiling :: Bool
profiling  = Bool
False -- FIXME: add support for profiling way

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)

  -- the header lets the linker recognize processed JavaScript files
  -- But don't add JavaScript header to object files!

  -- read pragmas from JS file
  -- we need to store them explicitly as they can be removed by CPP.
  JSOptions
opts <- FilePath -> IO JSOptions
getOptionsFromJsFile FilePath
input_fn

  -- run CPP if needed
  FilePath
cpp_fn <- case JSOptions -> Bool
enableCPP JSOptions
opts of
    Bool
False -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
input_fn
    Bool
True  -> do
      -- append common CPP definitions to the .js file.
      -- They define macros that avoid directly wiring zencoded names
      -- in RTS JS files
      FilePath
pp_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
      ByteString
payload <- FilePath -> IO ByteString
B.readFile FilePath
input_fn
      FilePath -> ByteString -> IO ()
B.writeFile FilePath
pp_fn (Bool -> ByteString
commonCppDefs Bool
profiling ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
payload)

      -- run CPP on the input JS file
      FilePath
js_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
      let
        cpp_opts :: CppOpts
cpp_opts = CppOpts
          { useHsCpp :: Bool
useHsCpp       = Bool
False
          , cppLinePragmas :: Bool
cppLinePragmas = Bool
False -- LINE pragmas aren't JS compatible
          }
      Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> CppOpts
-> FilePath
-> FilePath
-> IO ()
doCpp Logger
logger
              TmpFs
tmpfs
              DynFlags
dflags
              UnitEnv
unit_env
              CppOpts
cpp_opts
              FilePath
pp_fn
              FilePath
js_fn
      FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
js_fn

  -- write JS object
  ByteString
cpp_bs <- FilePath -> IO ByteString
B.readFile FilePath
cpp_fn
  JSOptions -> ByteString -> FilePath -> IO ()
writeJSObject JSOptions
opts ByteString
cpp_bs FilePath
output_fn

-- | Link module codes.
--
-- Performs link time optimizations and produces one JStat per module plus some
-- commoned up initialization code.
linkModules :: [ModuleCode] -> ([CompactedModuleCode], JS.JStat)
linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat)
linkModules [ModuleCode]
mods = ([CompactedModuleCode]
compact_mods, JStat
meta)
  where
    compact_mods :: [CompactedModuleCode]
compact_mods = (ModuleCode -> CompactedModuleCode)
-> [ModuleCode] -> [CompactedModuleCode]
forall a b. (a -> b) -> [a] -> [b]
map ModuleCode -> CompactedModuleCode
compact [ModuleCode]
mods

    -- here GHCJS used to:
    --  - deduplicate declarations
    --  - rename local variables into shorter ones
    --  - compress initialization data
    -- but we haven't ported it (yet).
    compact :: ModuleCode -> CompactedModuleCode
compact ModuleCode
m = CompactedModuleCode
      { cmc_js_code :: JStat
cmc_js_code = ModuleCode -> JStat
mc_js_code ModuleCode
m
      , cmc_module :: Module
cmc_module  = ModuleCode -> Module
mc_module ModuleCode
m
      , cmc_exports :: ByteString
cmc_exports = ModuleCode -> ByteString
mc_exports ModuleCode
m
      }

    -- common up statics: different bindings may reference the same statics, we
    -- filter them here to initialize them once
    statics :: [StaticInfo]
statics = [StaticInfo] -> [StaticInfo]
nubStaticInfo ((ModuleCode -> [StaticInfo]) -> [ModuleCode] -> [StaticInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModuleCode -> [StaticInfo]
mc_statics [ModuleCode]
mods)

    infos :: [ClosureInfo]
infos   = (ModuleCode -> [ClosureInfo]) -> [ModuleCode] -> [ClosureInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModuleCode -> [ClosureInfo]
mc_closures [ModuleCode]
mods
    debug :: Bool
debug   = Bool
False -- TODO: this could be enabled in a debug build.
                    -- It adds debug info to heap objects
    meta :: JStat
meta = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
            -- render metadata as individual statements
            [ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((StaticInfo -> JStat) -> [StaticInfo] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map StaticInfo -> JStat
staticDeclStat [StaticInfo]
statics)
            , [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((StaticInfo -> JStat) -> [StaticInfo] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map StaticInfo -> JStat
staticInitStat [StaticInfo]
statics)
            , JStgStat -> JStat
jStgStatToJS (JStgStat -> JStat) -> JStgStat -> JStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((ClosureInfo -> JStgStat) -> [ClosureInfo] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ClosureInfo -> JStgStat
closureInfoStat Bool
debug) [ClosureInfo]
infos)
            ]

-- | Only keep a single StaticInfo with a given name
nubStaticInfo :: [StaticInfo] -> [StaticInfo]
nubStaticInfo :: [StaticInfo] -> [StaticInfo]
nubStaticInfo = UniqSet FastString -> [StaticInfo] -> [StaticInfo]
go UniqSet FastString
forall a. UniqSet a
emptyUniqSet
  where
    go :: UniqSet FastString -> [StaticInfo] -> [StaticInfo]
go UniqSet FastString
us = \case
      []     -> []
      (StaticInfo
x:[StaticInfo]
xs) ->
        -- only match on siVar. There is no reason for the initializing value to
        -- be different for the same global name.
        let name :: FastString
name = StaticInfo -> FastString
siVar StaticInfo
x
        in if FastString -> UniqSet FastString -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet FastString
name UniqSet FastString
us
          then UniqSet FastString -> [StaticInfo] -> [StaticInfo]
go UniqSet FastString
us [StaticInfo]
xs
          else StaticInfo
x StaticInfo -> [StaticInfo] -> [StaticInfo]
forall a. a -> [a] -> [a]
: UniqSet FastString -> [StaticInfo] -> [StaticInfo]
go (UniqSet FastString -> FastString -> UniqSet FastString
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet FastString
us FastString
name) [StaticInfo]
xs

-- | Initialize a global object.
--
-- All global objects have to be declared (staticInfoDecl) first.
staticInitStat :: StaticInfo -> JS.JStat
staticInitStat :: StaticInfo -> JStat
staticInitStat (StaticInfo FastString
i StaticVal
sv Maybe Ident
mcc) =
  JStgStat -> JStat
jStgStatToJS (JStgStat -> JStat) -> JStgStat -> JStat
forall a b. (a -> b) -> a -> b
$
  case StaticVal
sv of
    StaticData FastString
con [StaticArg]
args         -> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$sti" ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
                                    [ FastString -> JStgExpr
var FastString
i
                                    , FastString -> JStgExpr
var FastString
con
                                    , [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
                                    ]
    StaticFun  FastString
f   [StaticArg]
args         -> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$sti" ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
                                    [ FastString -> JStgExpr
var FastString
i
                                    , FastString -> JStgExpr
var FastString
f
                                    , [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
                                    ]
    StaticList [StaticArg]
args Maybe FastString
mt          -> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stl" ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
                                    [ FastString -> JStgExpr
var FastString
i
                                    , [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
                                    , JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr
forall a b. (a -> b) -> a -> b
$ JStgExpr
-> (FastString -> JStgExpr) -> Maybe FastString -> JStgExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JStgExpr
null_ (Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr)
-> (FastString -> Ident) -> FastString -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI) Maybe FastString
mt
                                    ]
    StaticThunk (Just (FastString
f,[StaticArg]
args)) -> FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$stc" ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
                                    [ FastString -> JStgExpr
var FastString
i
                                    , FastString -> JStgExpr
var FastString
f
                                    , [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
                                    ]
    StaticVal
_                           -> JStgStat
forall a. Monoid a => a
mempty
  where
    -- add optional cost-center argument
    add_cc_arg :: [JStgExpr] -> [JStgExpr]
add_cc_arg [JStgExpr]
as = case Maybe Ident
mcc of
      Maybe Ident
Nothing -> [JStgExpr]
as
      Just Ident
cc -> [JStgExpr]
as [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a] -> [a]
++ [Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
cc]

-- | declare and do first-pass init of a global object (create JS object for heap objects)
staticDeclStat :: StaticInfo -> JS.JStat
staticDeclStat :: StaticInfo -> JStat
staticDeclStat (StaticInfo FastString
global_name StaticVal
static_value Maybe Ident
_) = JStgStat -> JStat
jStgStatToJS JStgStat
decl
  where
    global_ident :: Ident
global_ident = FastString -> Ident
global FastString
global_name
    decl_init :: JStgExpr -> JStgStat
decl_init JStgExpr
v  = Ident
global_ident Ident -> JStgExpr -> JStgStat
||= JStgExpr
v
    decl_no_init :: JStgStat
decl_no_init = FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$di" [Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
global_ident]

    decl :: JStgStat
decl = case StaticVal
static_value of
      StaticUnboxed StaticUnboxed
u     -> JStgExpr -> JStgStat
decl_init (StaticUnboxed -> JStgExpr
unboxed_expr StaticUnboxed
u)
      StaticThunk Maybe (FastString, [StaticArg])
Nothing -> JStgStat
decl_no_init -- CAF initialized in an alternative way
      StaticVal
_                   -> JStgExpr -> JStgStat
decl_init (FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$d" [])

    unboxed_expr :: StaticUnboxed -> JStgExpr
unboxed_expr = \case
      StaticUnboxedBool Bool
b          -> FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$p" [Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Bool
b]
      StaticUnboxedInt Integer
i           -> FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$p" [Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
i]
      StaticUnboxedDouble SaneDouble
d        -> FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$p" [Double -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (SaneDouble -> Double
unSaneDouble SaneDouble
d)]
      StaticUnboxedString ByteString
str      -> FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$rawStringData" [JVal -> JStgExpr
ValExpr (ByteString -> JVal
to_byte_list ByteString
str)]
      StaticUnboxedStringOffset {} -> JStgExpr
0

    to_byte_list :: ByteString -> JVal
to_byte_list = [JStgExpr] -> JVal
JList ([JStgExpr] -> JVal)
-> (ByteString -> [JStgExpr]) -> ByteString -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> JStgExpr) -> [Word8] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> JStgExpr
Int (Integer -> JStgExpr) -> (Word8 -> Integer) -> Word8 -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> [JStgExpr])
-> (ByteString -> [Word8]) -> ByteString -> [JStgExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack