{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
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 (linkableObjs)
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)
, LinkerStats -> Word64
packedMetaDataSize :: !Word64
}
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
let cmdline_objs :: [FilePath]
cmdline_objs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
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
(cmdline_hs_objs, cmdline_js_objs, cmdline_cc_objs) <- [FilePath]
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> IO ([FilePath], [FilePath], [FilePath])
disc [] [] [] [FilePath]
cmdline_objs
let
exe = DynFlags -> FilePath
jsExeFileName DynFlags
dflags
all_hs_objs = [FilePath]
hs_objs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_hs_objs
all_js_objs = [FilePath]
cmdline_js_objs
all_cc_objs = [FilePath]
cmdline_cc_objs
is_root p
_ = Bool
True
let 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 = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
ar_cache <- newArchiveCache
link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
void $ jsLink lc_cfg cfg logger tmpfs ar_cache exe link_plan
jsLink
:: JSLinkConfig
-> StgToJSConfig
-> Logger
-> TmpFs
-> ArchiveCache
-> FilePath
-> 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
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)
mods <- ArchiveCache -> LinkPlan -> IO [ModuleCode]
collectModuleCodes ArchiveCache
ar_cache LinkPlan
link_plan
link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \Handle
h ->
Handle -> Bool -> [ModuleCode] -> IO LinkerStats
renderModules Handle
h (StgToJSConfig -> Bool
csPrettyRender StgToJSConfig
cfg) [ModuleCode]
mods
when (lcForeignRefs lc_cfg) $ do
let frefsFile = FilePath
"out.frefs"
jsonFrefs = ByteString
forall a. Monoid a => a
mempty
BL.writeFile (out </> frefsFile <.> "json") jsonFrefs
BL.writeFile (out </> frefsFile <.> "js")
("h$checkForeignRefs(" <> jsonFrefs <> ");")
unless (lcNoStats lc_cfg) $ do
let statsFile = FilePath
"out.stats"
writeFile (out </> statsFile) (renderLinkerStats link_stats)
unless (lcNoRts lc_cfg) $ do
jsm <- initJSM
withFile (out </> "rts.js") WriteMode $ \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
(emcc_opts,lib_cc_objs) <- withBinaryFile (out </> "lib.js") WriteMode $ \Handle
h -> do
let
tmp_dir :: TempDir
tmp_dir = LinkerConfig -> TempDir
linkerTempDir (StgToJSConfig -> LinkerConfig
csLinkerConfig StgToJSConfig
cfg)
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 entries <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
a
(emcc_opts', cc_objs') <- go_entries emcc_opts cc_objs entries
go_archives emcc_opts' cc_objs' as
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
JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es
Just ObjectKind
ObjCc -> do
cc_obj_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_CurrentModule FilePath
"o"
B.writeFile cc_obj_fn (Ar.filedata e)
let cc_objs' = FilePath
cc_obj_fnFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
cc_objs
go_entries emcc_opts cc_objs' es
Just ObjectKind
ObjJs -> do
(opts,bs) <- ByteString -> IO (JSOptions, ByteString)
parseJSObjectBS (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
e)
B.hPut h bs
hPutChar h '\n'
let emcc_opts' = JSOptions
emcc_opts JSOptions -> JSOptions -> JSOptions
forall a. Semigroup a => a -> a -> a
<> JSOptions
opts
go_entries emcc_opts' cc_objs es
Maybe ObjectKind
Nothing -> case ArchiveEntry -> FilePath
Ar.filename ArchiveEntry
e of
FilePath
"__.SYMDEF" ->
JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es
FilePath
"__.SYMDEF SORTED" ->
JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es
FilePath
unknown_name -> 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 FilePath
unknown_name])
JSOptions
-> [FilePath] -> [ArchiveEntry] -> IO (JSOptions, [FilePath])
go_entries JSOptions
emcc_opts [FilePath]
cc_objs [ArchiveEntry]
es
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
(opts,bs) <- FilePath -> IO (JSOptions, ByteString)
readJSObject FilePath
e
B.hPut h bs
hPutChar h '\n'
let emcc_opts' = JSOptions
emcc_opts JSOptions -> JSOptions -> JSOptions
forall a. Semigroup a => a -> a -> a
<> JSOptions
opts
go_extra emcc_opts' es
(emcc_opts0, 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))
emcc_opts1 <- go_extra emcc_opts0 (S.toList (lkp_objs_js link_plan))
pure (emcc_opts1,cc_objs)
let 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 -> Bool
not ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
emcc_objs)
let link_c_sources = JSLinkConfig -> Bool
lcLinkCsources JSLinkConfig
lc_cfg Bool -> Bool -> Bool
&& Bool
has_emcc_objs
when link_c_sources $ do
runLink logger tmpfs (csLinkerConfig cfg) $
[ Option "-o"
, FileOption "" (out </> "clibs.js")
, Option "-sSINGLE_FILE=1"
, Option "-sALLOW_TABLE_GROWTH"
, Option ("-sEXPORTED_RUNTIME_METHODS=" ++ concat (intersperse "," (emccExportedRuntimeMethods emcc_opts)))
, Option ("-sEXPORTED_FUNCTIONS=" ++ concat (intersperse "," (emccExportedFunctions emcc_opts)))
]
++ map Option (emccExtraOptions emcc_opts)
++ map (FileOption "") emcc_objs
let 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
when (lcCombineAll lc_cfg && not (lcNoRts lc_cfg)) $ do
writeRunMain out use_emcc_rts
_ <- combineFiles lc_cfg link_c_sources out
writeHtml out
writeRunner lc_cfg out
writeExterns out
data LinkSpec = LinkSpec
{ LinkSpec -> [UnitId]
lks_unit_ids :: [UnitId]
, LinkSpec -> ExportedFun -> Bool
lks_obj_root_filter :: ExportedFun -> Bool
, :: Set ExportedFun
, LinkSpec -> [FilePath]
lks_objs_hs :: [FilePath]
, LinkSpec -> [FilePath]
lks_objs_js :: [FilePath]
, LinkSpec -> [FilePath]
lks_objs_cc :: [FilePath]
}
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
}
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
, 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
(objs_block_info, objs_required_blocks) <- [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadObjBlockInfo [FilePath]
hs_objs
let 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 = (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 (rts_wired_units, rts_wired_functions) = rtsDeps
let 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_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units)
let 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
dep_archives <- getPackageArchives cfg unit_env all_units
(archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo ar_cache dep_archives
let 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
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
new_required_blocks_var <- newIORef []
let load_info Module
mod = do
linkable <- case Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env) of
Maybe HomeModInfo
Nothing ->
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
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 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 {
mb_lnk <- Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe Module
mod ModLocation
loc ;
case 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
(bis, req_b) <- loadObjBlockInfo (linkableObjs linkable)
modifyIORef new_required_blocks_var ((++) req_b)
case M.lookup mod 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
(updated_block_info, transitive_deps) <- getDeps block_info load_info dep_fun_roots mempty
new_required_blocks <- readIORef new_required_blocks_var
let 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 -> 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
{ 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
}
return plan
data ModuleCode = ModuleCode
{ ModuleCode -> Module
mc_module :: !Module
, ModuleCode -> JStat
mc_js_code :: !JS.JStat
, ModuleCode -> ByteString
mc_exports :: !B.ByteString
, ModuleCode -> [ClosureInfo]
mc_closures :: ![ClosureInfo]
, ModuleCode -> [StaticInfo]
mc_statics :: ![StaticInfo]
, ModuleCode -> [ForeignJSRef]
mc_frefs :: ![ForeignJSRef]
}
instance Outputable ModuleCode where
ppr :: ModuleCode -> SDoc
ppr ModuleCode
m = SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ModuleCode") 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
"Module: ", Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleCode -> Module
mc_module ModuleCode
m)]
, [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS Code:", Bool -> JStat -> SDoc
forall doc. JsRender doc => Bool -> JStat -> doc
pretty Bool
True (ModuleCode -> JStat
mc_js_code ModuleCode
m)]
, [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS Exports:", ByteString -> SDoc
pprHsBytes (ModuleCode -> ByteString
mc_exports ModuleCode
m)]
, SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS Closures::") BlockId
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ClosureInfo -> SDoc) -> [ClosureInfo] -> [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 (FilePath -> SDoc)
-> (ClosureInfo -> FilePath) -> ClosureInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureInfo -> FilePath
forall a. Show a => a -> FilePath
show) (ModuleCode -> [ClosureInfo]
mc_closures ModuleCode
m)))
, SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS Statics::") BlockId
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((StaticInfo -> SDoc) -> [StaticInfo] -> [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 (FilePath -> SDoc)
-> (StaticInfo -> FilePath) -> StaticInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaticInfo -> FilePath
forall a. Show a => a -> FilePath
show) (ModuleCode -> [StaticInfo]
mc_statics ModuleCode
m)))
, SDoc -> BlockId -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"JS ForeignRefs::") BlockId
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((ForeignJSRef -> SDoc) -> [ForeignJSRef] -> [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 (FilePath -> SDoc)
-> (ForeignJSRef -> FilePath) -> ForeignJSRef -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignJSRef -> FilePath
forall a. Show a => a -> FilePath
show) (ModuleCode -> [ForeignJSRef]
mc_frefs ModuleCode
m)))
]
data CompactedModuleCode = CompactedModuleCode
{ CompactedModuleCode -> Module
cmc_module :: !Module
, CompactedModuleCode -> JStat
cmc_js_code :: !JS.JStat
, CompactedModuleCode -> ByteString
cmc_exports :: !B.ByteString
}
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
before <- Handle -> IO Integer
hTell Handle
h
if render_pretty
then do
printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x)
else do
bh <- newBufHandle h
bPutHDoc bh defaultJsContext (line $ pretty render_pretty x)
bFlush bh
hPutChar h '\n'
after <- hTell h
pure $! (after - before)
renderModules
:: Handle
-> Bool
-> [ModuleCode]
-> IO LinkerStats
renderModules :: Handle -> Bool -> [ModuleCode] -> IO LinkerStats
renderModules Handle
h Bool
render_pretty [ModuleCode]
mods = do
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
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
!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 = CompactedModuleCode -> Module
cmc_module CompactedModuleCode
m
pure (mod_mod, mod_size)
let meta_opt = JStat -> JStat
jsOptimize JStat
meta
!meta_length <- fromIntegral <$> putJS meta_opt
mapM_ (B.hPut h . cmc_exports) compacted_mods
let !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
}
pure link_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 = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
profSuff :: FilePath
profSuff | StgToJSConfig -> Bool
csProf StgToJSConfig
cfg = FilePath
"_p"
| Bool
otherwise = FilePath
""
combineFiles :: JSLinkConfig
-> Bool
-> 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] -> [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
writeHtml
:: FilePath
-> IO ()
writeHtml :: FilePath -> IO ()
writeHtml FilePath
out = do
let htmlFile :: FilePath
htmlFile = FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"index.html"
e <- FilePath -> IO Bool
doesFileExist FilePath
htmlFile
unless e $
B.writeFile htmlFile 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>"
writeRunMain
:: FilePath
-> 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
-> FilePath
-> IO ()
writeRunner :: JSLinkConfig -> FilePath -> IO ()
writeRunner JSLinkConfig
_settings FilePath
out = do
cd <- IO FilePath
getCurrentDirectory
let arch_os = ArchOS
hostPlatformArchOS
let 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
out FilePath -> FilePath -> FilePath
</> FilePath
"all" FilePath -> FilePath -> FilePath
<.> FilePath
"js"
nodePgm :: B.ByteString
nodePgm = ByteString
"node"
src <- B.readFile (cd </> srcFile)
B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src)
perms <- getPermissions runner
setPermissions runner (perms {executable = True})
rtsExterns :: FastString
rtsExterns :: FastString
rtsExterns =
FastString
"/** @externs @suppress {duplicate} */\n" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<>
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
1::Int)..BlockId
16384]) FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<>
[FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat
((FastString -> FastString) -> [FastString] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (\FastString
x -> FastString
"/** @type {*} */\nObject." FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
x FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
";\n")
[FastString
"m", FastString
"f", FastString
"cc", FastString
"t", FastString
"size", FastString
"i", FastString
"n", FastString
"a", FastString
"r", FastString
"s"]) FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<>
[FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat
[
FastString
"/** @type {*} */\nObject.mv;\n"
] FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<>
[FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat
((FastString -> FastString) -> [FastString] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (\FastString
x -> FastString
x FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
";\n")
[
FastString
"/** @type {string} */ var __dirname"
, FastString
"/** @const */ var NodeJS = {}"
, FastString
"/** @interface */ NodeJS.Stream = function () {}"
, FastString
"/** @template THIS @this {THIS} @return {THIS} */ NodeJS.Stream.prototype.on = function() {}"
, FastString
"/** @return {boolean} */ NodeJS.Stream.prototype.write = function() {}"
, FastString
"/** @interface */ NodeJS.ProcessVersions = function() {}"
, FastString
"/** @type {string} */ NodeJS.ProcessVersions.prototype.node"
, FastString
"/** @interface */ NodeJS.Process = function() {}"
, FastString
"/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stderr"
, FastString
"/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdin"
, FastString
"/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdout"
, FastString
"/** @type {!NodeJS.ProcessVersions} */ NodeJS.Process.prototype.versions"
, FastString
"/** @return {?} */ NodeJS.Process.prototype.exit = function() {}"
, FastString
"/** @type {!Array<string>} */ NodeJS.Process.prototype.argv"
, FastString
"/** @type {!NodeJS.Process} */ var process"
, FastString
"/** @extends {Uint8Array} @constructor */ function Buffer(arg1, encoding) {}"
, FastString
"/** @return {!Buffer} */ Buffer.alloc = function() {}"
, FastString
"/** @type {*} */ var Module"
, FastString
"/** @type {!Int8Array} */ Module.HEAP8"
, FastString
"/** @type {!Uint8Array} */ Module.HEAPU8"
, FastString
"/** @return {number} */ Module.getEmptyTableSlot = function() {}"
, FastString
"/** @return {*} */ Module._free = function() {}"
, FastString
"/** @return {*} */ Module._malloc = function() {}"
, FastString
"/** @type {*} */ var putstr"
, FastString
"/** @type {*} */ var printErr"
, FastString
"/** @type {*} */ var debug"
])
writeExterns :: FilePath -> IO ()
writeExterns :: FilePath -> IO ()
writeExterns FilePath
out = FilePath -> FilePath -> IO ()
writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"all.externs.js")
(FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
unpackFS FastString
rtsExterns
getDeps :: Map Module LocatedBlockInfo
-> (Module -> IO LocatedBlockInfo)
-> Set ExportedFun
-> Set BlockRef
-> 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
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
info <- Module -> IO LocatedBlockInfo
load_info Module
mod
pure (M.insert mod info infos, lbi_info 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
!(infos',info) <- Map Module LocatedBlockInfo
-> Module -> IO (Map Module LocatedBlockInfo, BlockInfo)
lookup_info Map Module LocatedBlockInfo
infos Module
mod
let 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' = 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
i = BlockRef
{ block_ref_mod :: Module
block_ref_mod = Module
mod
, block_ref_idx :: BlockId
block_ref_idx = BlockId
i
}
traverse_funs infos' result'
(addOpen result' open' $
map to_block_ref (blockBlockDeps block)) (blockFunDeps 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
!(infos',info) <- Map Module LocatedBlockInfo
-> Module -> IO (Map Module LocatedBlockInfo, BlockInfo)
lookup_info Map Module LocatedBlockInfo
infos Module
mod
case M.lookup f (bi_exports 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
}
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
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)
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
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)
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)
[(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
ArchiveCache
ar_state LocatedBlockInfo
lbi BlockIds
blocks = do
case LocatedBlockInfo -> BlockLocation
lbi_loc LocatedBlockInfo
lbi of
ObjectFile FilePath
fp -> do
us <- FilePath -> BlockIds -> IO [ObjBlock]
readObjectBlocks FilePath
fp BlockIds
blocks
pure (collectCode us)
ArchiveFile FilePath
a -> do
obj <- ArchiveCache -> Module -> FilePath -> IO Object
readArObject ArchiveCache
ar_state Module
mod FilePath
a
us <- getObjectBlocks obj blocks
pure (collectCode us)
InMemory FilePath
_n Object
obj -> do
us <- Object -> BlockIds -> IO [ObjBlock]
getObjectBlocks Object
obj BlockIds
blocks
pure (collectCode 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
}
loadArchive :: ArchiveCache -> FilePath -> IO Ar.Archive
loadArchive :: ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
ar_file = do
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 M.lookup ar_file 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
a <- FilePath -> IO Archive
Ar.loadAr FilePath
ar_file
modifyIORef (loadedArchives ar_cache) (M.insert ar_file a)
pure 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 entries <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
ar_file
let go_entries = \case
[] -> 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
bh <- ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer ByteString
bs
getObjectHeader bh >>= \case
Left FilePath
_ -> [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
es
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
| Bool
otherwise
-> ReadBinHandle -> ModuleName -> IO Object
getObjectBody ReadBinHandle
bh ModuleName
mod_name
go_entries entries
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
"(,,,,,,,,,)"
]
]
)
mkInternalFuns :: FastString -> [FastString] -> [ExportedFun]
mkInternalFuns :: FastString -> [FastString] -> [ExportedFun]
mkInternalFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
ghcInternalUnitId
mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
mkPrimFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
primUnitId
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
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)
loadObjBlockInfo
:: [FilePath]
-> 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
loadArchiveBlockInfo :: ArchiveCache -> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadArchiveBlockInfo :: ArchiveCache
-> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef])
loadArchiveBlockInfo ArchiveCache
ar_cache [FilePath]
archives = do
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 entries) <- ArchiveCache -> FilePath -> IO Archive
loadArchive ArchiveCache
ar_cache FilePath
file
catMaybes <$> mapM (readEntry file) entries
return (prepareLoadedDeps $ concat 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
bh <- ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer ByteString
bs
getObjectHeader bh >>= \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
Right ModuleName
mod_name -> do
obj <- ReadBinHandle -> ModuleName -> IO Object
getObjectBody ReadBinHandle
bh ModuleName
mod_name
let !info = Object -> BlockInfo
objBlockInfo Object
obj
pure $ Just (LocatedBlockInfo (ArchiveFile ar_file) 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
}
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)
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
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)
opts <- FilePath -> IO JSOptions
getOptionsFromJsFile FilePath
input_fn
cpp_fn <- case enableCPP 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
pp_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
payload <- B.readFile input_fn
B.writeFile pp_fn (commonCppDefs profiling <> payload)
js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
let
cpp_opts = CppOpts
{ sourceCodePreprocessor :: SourceCodePreprocessor
sourceCodePreprocessor = SourceCodePreprocessor
SCPJsCpp
, cppLinePragmas :: Bool
cppLinePragmas = Bool
False
}
doCpp logger
tmpfs
dflags
unit_env
cpp_opts
pp_fn
js_fn
pure js_fn
cpp_bs <- B.readFile cpp_fn
writeJSObject opts cpp_bs output_fn
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
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
}
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
meta :: JStat
meta = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ [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)
]
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) ->
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
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
hdStiStr ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
[ FastString -> JStgExpr
global FastString
i
, FastString -> JStgExpr
global FastString
con
, [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
]
StaticFun FastString
f [StaticArg]
args -> FastString -> [JStgExpr] -> JStgStat
appS FastString
hdStiStr ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
[ FastString -> JStgExpr
global FastString
i
, FastString -> JStgExpr
global FastString
f
, [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
]
StaticList [StaticArg]
args Maybe FastString
mt -> FastString -> [JStgExpr] -> JStgStat
appS FastString
hdStlStr ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
[ FastString -> JStgExpr
global 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
hdStcStr ([JStgExpr] -> JStgStat) -> [JStgExpr] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> [JStgExpr]
add_cc_arg
[ FastString -> JStgExpr
global FastString
i
, FastString -> JStgExpr
global FastString
f
, [StaticArg] -> JStgExpr
jsStaticArgs [StaticArg]
args
]
StaticVal
_ -> JStgStat
forall a. Monoid a => a
mempty
where
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]
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
name 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
hdDiStr [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
StaticVal
_ -> JStgExpr -> JStgStat
decl_init (FastString -> [JStgExpr] -> JStgExpr
app FastString
hdDStr [])
unboxed_expr :: StaticUnboxed -> JStgExpr
unboxed_expr = \case
StaticUnboxedBool Bool
b -> FastString -> [JStgExpr] -> JStgExpr
app FastString
hdPStr [Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Bool
b]
StaticUnboxedInt Integer
i -> FastString -> [JStgExpr] -> JStgExpr
app FastString
hdPStr [Integer -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Integer
i]
StaticUnboxedDouble SaneDouble
d -> FastString -> [JStgExpr] -> JStgExpr
app FastString
hdPStr [Double -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (SaneDouble -> Double
unSaneDouble SaneDouble
d)]
StaticUnboxedString ByteString
str -> ByteString -> JStgExpr
initStr 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
initStr :: BS.ByteString -> JStgExpr
initStr :: ByteString -> JStgExpr
initStr ByteString
str =
case ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
str of
Just FastString
t -> FastString -> [JStgExpr] -> JStgExpr
app FastString
hdEncodeModifiedUtf8Str [JVal -> JStgExpr
ValExpr (FastString -> JVal
JStr FastString
t)]
Maybe FastString
Nothing -> FastString -> [JStgExpr] -> JStgExpr
app FastString
hdRawStringDataStr [JVal -> JStgExpr
ValExpr (JVal -> JStgExpr) -> JVal -> JStgExpr
forall a b. (a -> b) -> a -> b
$ ByteString -> JVal
to_byte_list ByteString
str]