{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module GHC.StgToJS.Linker.Linker
( jsLinkBinary
, embedJsFile
)
where
import Prelude
import GHC.Platform.Host (hostPlatformArchOS)
import GHC.JS.Make
import GHC.JS.Syntax
import GHC.Driver.Session (DynFlags(..))
import Language.Haskell.Syntax.Module.Name
import GHC.SysTools.Cpp
import GHC.SysTools
import GHC.Linker.Static.Utils (exeFileName)
import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Utils
import GHC.StgToJS.Rts.Rts
import GHC.StgToJS.Object
import GHC.StgToJS.Types hiding (LinkableUnit)
import GHC.StgToJS.Symbols
import GHC.StgToJS.Printer
import GHC.StgToJS.Arg
import GHC.StgToJS.Closure
import GHC.Unit.State
import GHC.Unit.Env
import GHC.Unit.Home
import GHC.Unit.Types
import GHC.Unit.Module (moduleStableString)
import GHC.Utils.Outputable hiding ((<>))
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.Monad
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.Concurrent.MVar
import Control.Monad
import Data.Array
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import Data.Function (on)
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.IORef
import Data.List ( partition, nub, intercalate, group, sort
, groupBy, intersperse,
)
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 System.IO
import System.FilePath ((<.>), (</>), dropExtension, takeDirectory)
import System.Directory ( createDirectoryIfMissing
, doesFileExist
, getCurrentDirectory
, Permissions(..)
, setPermissions
, getPermissions
)
data LinkerStats = LinkerStats
{ LinkerStats -> Map Module Word64
bytesPerModule :: !(Map Module Word64)
, LinkerStats -> Word64
packedMetaDataSize :: !Word64
}
newtype ArchiveState = ArchiveState { ArchiveState -> IORef (Map FilePath Archive)
loadedArchives :: IORef (Map FilePath Ar.Archive) }
emptyArchiveState :: IO ArchiveState
emptyArchiveState :: IO ArchiveState
emptyArchiveState = IORef (Map FilePath Archive) -> ArchiveState
ArchiveState (IORef (Map FilePath Archive) -> ArchiveState)
-> IO (IORef (Map FilePath Archive)) -> IO ArchiveState
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
jsLinkBinary
:: JSLinkConfig
-> StgToJSConfig
-> [FilePath]
-> Logger
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
jsLinkBinary :: JSLinkConfig
-> StgToJSConfig
-> [FilePath]
-> Logger
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
jsLinkBinary JSLinkConfig
lc_cfg StgToJSConfig
cfg [FilePath]
js_srcs Logger
logger DynFlags
dflags UnitEnv
u_env [FilePath]
objs [UnitId]
dep_pkgs
| 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 ]
([FilePath]
cmdline_js_srcs, [FilePath]
cmdline_js_objs) <- (FilePath -> IO Bool) -> [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
isJsFile [FilePath]
cmdline_objs
let
objs' :: [LinkedObj]
objs' = (FilePath -> LinkedObj) -> [FilePath] -> [LinkedObj]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> LinkedObj
ObjFile ([FilePath]
objs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_js_objs)
js_srcs' :: [FilePath]
js_srcs' = [FilePath]
js_srcs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_js_srcs
isRoot :: p -> Bool
isRoot p
_ = Bool
True
exe :: FilePath
exe = DynFlags -> FilePath
jsExeFileName DynFlags
dflags
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
-> UnitEnv
-> FilePath
-> [FilePath]
-> [UnitId]
-> [LinkedObj]
-> [FilePath]
-> (ExportedFun -> Bool)
-> Set ExportedFun
-> IO ()
link JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger UnitEnv
u_env FilePath
exe [FilePath]
forall a. Monoid a => a
mempty [UnitId]
dep_pkgs [LinkedObj]
objs' [FilePath]
js_srcs' ExportedFun -> Bool
forall {p}. p -> Bool
isRoot Set ExportedFun
forall a. Monoid a => a
mempty
link :: JSLinkConfig
-> StgToJSConfig
-> Logger
-> UnitEnv
-> FilePath
-> [FilePath]
-> [UnitId]
-> [LinkedObj]
-> [FilePath]
-> (ExportedFun -> Bool)
-> Set ExportedFun
-> IO ()
link :: JSLinkConfig
-> StgToJSConfig
-> Logger
-> UnitEnv
-> FilePath
-> [FilePath]
-> [UnitId]
-> [LinkedObj]
-> [FilePath]
-> (ExportedFun -> Bool)
-> Set ExportedFun
-> IO ()
link JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger UnitEnv
unit_env FilePath
out [FilePath]
_include [UnitId]
units [LinkedObj]
objFiles [FilePath]
jsFiles ExportedFun -> Bool
isRootFun Set ExportedFun
extraStaticDeps = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False FilePath
out
(Map Module (Deps, DepsLocation)
dep_map, [UnitId]
dep_units, Set LinkableUnit
all_deps, Set ExportedFun
_rts_wired_functions, [FilePath]
dep_archives)
<- StgToJSConfig
-> Logger
-> FilePath
-> UnitEnv
-> [UnitId]
-> [LinkedObj]
-> Set ExportedFun
-> (ExportedFun -> Bool)
-> IO
(Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit,
Set ExportedFun, [FilePath])
computeLinkDependencies StgToJSConfig
cfg Logger
logger FilePath
out UnitEnv
unit_env [UnitId]
units [LinkedObj]
objFiles Set ExportedFun
extraStaticDeps ExportedFun -> Bool
isRootFun
[ModuleCode]
mods <- Map Module (Deps, DepsLocation)
-> [UnitId] -> Set LinkableUnit -> IO [ModuleCode]
collectDeps Map Module (Deps, DepsLocation)
dep_map [UnitId]
dep_units Set LinkableUnit
all_deps
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 -> [ModuleCode] -> [FilePath] -> IO LinkerStats
renderLinker Handle
h [ModuleCode]
mods [FilePath]
jsFiles
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcOnlyOut JSLinkConfig
lc_cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let frefsFile :: FilePath
frefsFile = FilePath
"out.frefs"
jsonFrefs :: ByteString
jsonFrefs = ByteString
forall a. Monoid a => a
mempty
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
");")
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)
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
FilePath -> ByteString -> IO ()
BL.writeFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"rts.js") ( FilePath -> ByteString
BLC.pack FilePath
rtsDeclsText
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> ByteString
BLC.pack (StgToJSConfig -> FilePath
rtsText StgToJSConfig
cfg))
FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"lib.js") IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
[FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
dep_archives ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
archive_file -> do
Ar.Archive [ArchiveEntry]
entries <- FilePath -> IO Archive
Ar.loadAr FilePath
archive_file
[ArchiveEntry] -> (ArchiveEntry -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ArchiveEntry]
entries ((ArchiveEntry -> IO ()) -> IO ())
-> (ArchiveEntry -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ArchiveEntry
entry -> do
case ArchiveEntry -> Maybe ByteString
getJsArchiveEntry ArchiveEntry
entry of
Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
bs -> do
Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
bs
Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSLinkConfig -> Bool
generateAllJs JSLinkConfig
lc_cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
()
_ <- JSLinkConfig -> FilePath -> IO ()
combineFiles JSLinkConfig
lc_cfg FilePath
out
FilePath -> IO ()
writeHtml FilePath
out
FilePath -> IO ()
writeRunMain FilePath
out
JSLinkConfig -> FilePath -> IO ()
writeRunner JSLinkConfig
lc_cfg FilePath
out
FilePath -> IO ()
writeExterns FilePath
out
computeLinkDependencies
:: StgToJSConfig
-> Logger
-> String
-> UnitEnv
-> [UnitId]
-> [LinkedObj]
-> Set ExportedFun
-> (ExportedFun -> Bool)
-> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath])
computeLinkDependencies :: StgToJSConfig
-> Logger
-> FilePath
-> UnitEnv
-> [UnitId]
-> [LinkedObj]
-> Set ExportedFun
-> (ExportedFun -> Bool)
-> IO
(Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit,
Set ExportedFun, [FilePath])
computeLinkDependencies StgToJSConfig
cfg Logger
logger FilePath
target UnitEnv
unit_env [UnitId]
units [LinkedObj]
objFiles Set ExportedFun
extraStaticDeps ExportedFun -> Bool
isRootFun = do
(Map Module (Deps, DepsLocation)
objDepsMap, [LinkableUnit]
objRequiredUnits) <- [LinkedObj] -> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadObjDeps [LinkedObj]
objFiles
let roots :: Set ExportedFun
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
isRootFun ([ExportedFun] -> Set ExportedFun)
-> [ExportedFun] -> Set ExportedFun
forall a b. (a -> b) -> a -> b
$ ((Deps, DepsLocation) -> [ExportedFun])
-> [(Deps, DepsLocation)] -> [ExportedFun]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map ExportedFun Key -> [ExportedFun]
forall k a. Map k a -> [k]
M.keys (Map ExportedFun Key -> [ExportedFun])
-> ((Deps, DepsLocation) -> Map ExportedFun Key)
-> (Deps, DepsLocation)
-> [ExportedFun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deps -> Map ExportedFun Key
depsHaskellExported (Deps -> Map ExportedFun Key)
-> ((Deps, DepsLocation) -> Deps)
-> (Deps, DepsLocation)
-> Map ExportedFun Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Deps, DepsLocation) -> Deps
forall a b. (a, b) -> a
fst) (Map Module (Deps, DepsLocation) -> [(Deps, DepsLocation)]
forall k a. Map k a -> [a]
M.elems Map Module (Deps, DepsLocation)
objDepsMap)
rootMods :: [FilePath]
rootMods = ([Module] -> FilePath) -> [[Module]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> FilePath
moduleNameString (ModuleName -> FilePath)
-> ([Module] -> ModuleName) -> [Module] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> ([Module] -> Module) -> [Module] -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module] -> Module
forall a. HasCallStack => [a] -> a
head) ([[Module]] -> [FilePath])
-> (Set ExportedFun -> [[Module]]) -> Set ExportedFun -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module] -> [[Module]]
forall a. Eq a => [a] -> [[a]]
group ([Module] -> [[Module]])
-> (Set ExportedFun -> [Module]) -> Set ExportedFun -> [[Module]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort ([Module] -> [Module])
-> (Set ExportedFun -> [Module]) -> Set ExportedFun -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExportedFun -> Module) -> [ExportedFun] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ExportedFun -> Module
funModule ([ExportedFun] -> [Module])
-> (Set ExportedFun -> [ExportedFun])
-> Set ExportedFun
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ExportedFun -> [ExportedFun]
forall a. Set a -> [a]
S.toList (Set ExportedFun -> [FilePath]) -> Set ExportedFun -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set ExportedFun
roots
objPkgs :: [UnitId]
objPkgs = (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 (Deps, DepsLocation) -> [Module]
forall k a. Map k a -> [k]
M.keys Map Module (Deps, DepsLocation)
objDepsMap)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
[ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking ", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
target, FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
" (", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," [FilePath]
rootMods), Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
')' ]
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
[ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"objDepsMap ", Map Module (Deps, DepsLocation) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Map Module (Deps, DepsLocation)
objDepsMap ]
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
[ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"objFiles ", [LinkedObj] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LinkedObj]
objFiles ]
let ([UnitId]
rts_wired_units, Set ExportedFun
rts_wired_functions) = [UnitId] -> ([UnitId], Set ExportedFun)
rtsDeps [UnitId]
units
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
/= UnitId
mainUnitId)
([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]
objPkgs [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId] -> [UnitId]
forall a. [a] -> [a]
reverse [UnitId]
units
[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
GhcjsEnv
env <- IO GhcjsEnv
newGhcjsEnv
(Map Module (Deps, DepsLocation)
archsDepsMap, [LinkableUnit]
archsRequiredUnits) <- GhcjsEnv
-> [FilePath]
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadArchiveDeps GhcjsEnv
env [FilePath]
dep_archives
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
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 -> Key -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking with archives:") Key
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 [FilePath]
dep_archives))
let dep_units :: [UnitId]
dep_units = [UnitId]
all_units [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [GenHomeUnit UnitId -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId (UnitEnv -> GenHomeUnit UnitId
ue_unsafeHomeUnit (UnitEnv -> GenHomeUnit UnitId) -> UnitEnv -> GenHomeUnit UnitId
forall a b. (a -> b) -> a -> b
$ UnitEnv
unit_env)]
dep_map :: Map Module (Deps, DepsLocation)
dep_map = Map Module (Deps, DepsLocation)
objDepsMap Map Module (Deps, DepsLocation)
-> Map Module (Deps, DepsLocation)
-> Map Module (Deps, DepsLocation)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Module (Deps, DepsLocation)
archsDepsMap
excluded_units :: Set a
excluded_units = Set a
forall a. Set a
S.empty
dep_fun_roots :: Set ExportedFun
dep_fun_roots = Set ExportedFun
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
extraStaticDeps
dep_unit_roots :: [LinkableUnit]
dep_unit_roots = [LinkableUnit]
archsRequiredUnits [LinkableUnit] -> [LinkableUnit] -> [LinkableUnit]
forall a. [a] -> [a] -> [a]
++ [LinkableUnit]
objRequiredUnits
Set LinkableUnit
all_deps <- Map Module Deps
-> Set LinkableUnit
-> Set ExportedFun
-> [LinkableUnit]
-> IO (Set LinkableUnit)
getDeps (((Deps, DepsLocation) -> Deps)
-> Map Module (Deps, DepsLocation) -> Map Module Deps
forall a b. (a -> b) -> Map Module a -> Map Module b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Deps, DepsLocation) -> Deps
forall a b. (a, b) -> a
fst Map Module (Deps, DepsLocation)
dep_map) Set LinkableUnit
forall a. Set a
excluded_units Set ExportedFun
dep_fun_roots [LinkableUnit]
dep_unit_roots
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
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 -> Key -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Units to link:") Key
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
dep_units))
(Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit,
Set ExportedFun, [FilePath])
-> IO
(Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit,
Set ExportedFun, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Module (Deps, DepsLocation)
dep_map, [UnitId]
dep_units, Set LinkableUnit
all_deps, Set ExportedFun
rts_wired_functions, [FilePath]
dep_archives)
data ModuleCode = ModuleCode
{ ModuleCode -> Module
mc_module :: !Module
, ModuleCode -> JStat
mc_js_code :: !JStat
, ModuleCode -> ByteString
mc_exports :: !B.ByteString
, ModuleCode -> [ClosureInfo]
mc_closures :: ![ClosureInfo]
, ModuleCode -> [StaticInfo]
mc_statics :: ![StaticInfo]
, ModuleCode -> [ForeignJSRef]
mc_frefs :: ![ForeignJSRef]
}
data CompactedModuleCode = CompactedModuleCode
{ CompactedModuleCode -> Module
cmc_module :: !Module
, CompactedModuleCode -> JStat
cmc_js_code :: !JStat
, CompactedModuleCode -> ByteString
cmc_exports :: !B.ByteString
}
renderLinker
:: Handle
-> [ModuleCode]
-> [FilePath]
-> IO LinkerStats
renderLinker :: Handle -> [ModuleCode] -> [FilePath] -> IO LinkerStats
renderLinker Handle
h [ModuleCode]
mods [FilePath]
jsFiles = do
let ([CompactedModuleCode]
compacted_mods, JStat
meta) = [ModuleCode] -> ([CompactedModuleCode], JStat)
linkModules [ModuleCode]
mods
let
putBS :: ByteString -> IO ()
putBS = Handle -> ByteString -> IO ()
B.hPut Handle
h
putJS :: JStat -> IO Integer
putJS JStat
x = do
Integer
before <- Handle -> IO Integer
hTell Handle
h
Handle -> Doc -> IO ()
Ppr.printLeftRender Handle
h (JStat -> Doc
pretty JStat
x)
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)
[(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 (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)
!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
(CompactedModuleCode -> IO ()) -> [CompactedModuleCode] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> IO ()
putBS (ByteString -> IO ())
-> (CompactedModuleCode -> ByteString)
-> CompactedModuleCode
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompactedModuleCode -> ByteString
cmc_exports) [CompactedModuleCode]
compacted_mods
(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\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
>>= ByteString -> IO ()
putBS) [FilePath]
jsFiles
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
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
<> Key -> FilePath
forall a. Show a => a -> FilePath
show ([(Module, Word64)] -> Key
forall a. [a] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
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 :: Key -> FilePath -> FilePath
pad Key
n FilePath
t = let l :: Key
l = FilePath -> Key
forall a. [a] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length FilePath
t
in if Key
l Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
n then FilePath
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Key -> Char -> FilePath
forall a. Key -> a -> [a]
replicate (Key
nKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
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) = Key -> FilePath -> FilePath
pad Key
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) -> Key -> FilePath -> FilePath
pad Key
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
profSuff :: FilePath
profSuff | StgToJSConfig -> Bool
csProf StgToJSConfig
cfg = FilePath
"_p"
| Bool
otherwise = FilePath
""
combineFiles :: JSLinkConfig
-> FilePath
-> IO ()
combineFiles :: JSLinkConfig -> FilePath -> IO ()
combineFiles JSLinkConfig
cfg 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
"rts.js", FilePath
"lib.js", FilePath
"out.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 -> do
let cpy :: FilePath -> IO ()
cpy 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
(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
cpy [FilePath]
files
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcNoHsMain JSLinkConfig
cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
runMainJS
writeHtml
:: FilePath
-> 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>"
writeRunMain
:: FilePath
-> IO ()
writeRunMain :: FilePath -> IO ()
writeRunMain FilePath
out = do
let runMainFile :: FilePath
runMainFile = FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"runmain.js"
Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
runMainFile
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
runMainFile ByteString
runMainJS
runMainJS :: B.ByteString
runMainJS :: ByteString
runMainJS = ByteString
"h$main(h$mainZCZCMainzimain);\n"
writeRunner :: JSLinkConfig
-> FilePath
-> 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 ((Key -> FastString) -> [Key] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
x -> FastString
"/** @type {*} */\nObject.d" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FilePath -> FastString
mkFastString (Key -> FilePath
forall a. Show a => a -> FilePath
show Key
x) FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
";\n")
[(Key
7::Int)..Key
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
getDeps :: Map Module Deps
-> Set LinkableUnit
-> Set ExportedFun
-> [LinkableUnit]
-> IO (Set LinkableUnit)
getDeps :: Map Module Deps
-> Set LinkableUnit
-> Set ExportedFun
-> [LinkableUnit]
-> IO (Set LinkableUnit)
getDeps Map Module Deps
loaded_deps Set LinkableUnit
base Set ExportedFun
fun [LinkableUnit]
startlu = Set LinkableUnit
-> Set LinkableUnit -> [ExportedFun] -> IO (Set LinkableUnit)
go' Set LinkableUnit
forall a. Set a
S.empty ([LinkableUnit] -> Set LinkableUnit
forall a. Ord a => [a] -> Set a
S.fromList [LinkableUnit]
startlu) (Set ExportedFun -> [ExportedFun]
forall a. Set a -> [a]
S.toList Set ExportedFun
fun)
where
go :: Set LinkableUnit
-> Set LinkableUnit
-> IO (Set LinkableUnit)
go :: Set LinkableUnit -> Set LinkableUnit -> IO (Set LinkableUnit)
go Set LinkableUnit
result Set LinkableUnit
open = case Set LinkableUnit -> Maybe (LinkableUnit, Set LinkableUnit)
forall a. Set a -> Maybe (a, Set a)
S.minView Set LinkableUnit
open of
Maybe (LinkableUnit, Set LinkableUnit)
Nothing -> Set LinkableUnit -> IO (Set LinkableUnit)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Set LinkableUnit
result
Just (lu :: LinkableUnit
lu@(Module
lmod,Key
n), Set LinkableUnit
open') ->
case Module -> Map Module Deps -> Maybe Deps
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
lmod Map Module Deps
loaded_deps of
Maybe Deps
Nothing -> FilePath -> SDoc -> IO (Set LinkableUnit)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps.go: object file not loaded for: " (Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
lmod)
Just (Deps Module
_ BlockIds
_ Map ExportedFun Key
_ Array Key BlockDeps
b) ->
let block :: BlockDeps
block = Array Key BlockDeps
bArray Key BlockDeps -> Key -> BlockDeps
forall i e. Ix i => Array i e -> i -> e
!Key
n
result' :: Set LinkableUnit
result' = LinkableUnit -> Set LinkableUnit -> Set LinkableUnit
forall a. Ord a => a -> Set a -> Set a
S.insert LinkableUnit
lu Set LinkableUnit
result
in Set LinkableUnit
-> Set LinkableUnit -> [ExportedFun] -> IO (Set LinkableUnit)
go' Set LinkableUnit
result'
(Set LinkableUnit
-> Set LinkableUnit -> [LinkableUnit] -> Set LinkableUnit
addOpen Set LinkableUnit
result' Set LinkableUnit
open' ([LinkableUnit] -> Set LinkableUnit)
-> [LinkableUnit] -> Set LinkableUnit
forall a b. (a -> b) -> a -> b
$
(Key -> LinkableUnit) -> [Key] -> [LinkableUnit]
forall a b. (a -> b) -> [a] -> [b]
map (Module
lmod,) (BlockDeps -> [Key]
blockBlockDeps BlockDeps
block)) (BlockDeps -> [ExportedFun]
blockFunDeps BlockDeps
block)
go' :: Set LinkableUnit
-> Set LinkableUnit
-> [ExportedFun]
-> IO (Set LinkableUnit)
go' :: Set LinkableUnit
-> Set LinkableUnit -> [ExportedFun] -> IO (Set LinkableUnit)
go' Set LinkableUnit
result Set LinkableUnit
open [] = Set LinkableUnit -> Set LinkableUnit -> IO (Set LinkableUnit)
go Set LinkableUnit
result Set LinkableUnit
open
go' Set LinkableUnit
result Set LinkableUnit
open (ExportedFun
f:[ExportedFun]
fs) =
let key :: Module
key = ExportedFun -> Module
funModule ExportedFun
f
in case Module -> Map Module Deps -> Maybe Deps
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
key Map Module Deps
loaded_deps of
Maybe Deps
Nothing -> FilePath -> SDoc -> IO (Set LinkableUnit)
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps.go': object file not loaded for: " (SDoc -> IO (Set LinkableUnit)) -> SDoc -> IO (Set LinkableUnit)
forall a b. (a -> b) -> a -> b
$ Module -> SDoc
forall doc. IsLine doc => Module -> doc
pprModule Module
key
Just (Deps Module
_m BlockIds
_r Map ExportedFun Key
e Array Key BlockDeps
_b) ->
let lun :: Int
lun :: Key
lun = Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> SDoc -> Key
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"exported function not found: " (SDoc -> Key) -> SDoc -> Key
forall a b. (a -> b) -> a -> b
$ ExportedFun -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExportedFun
f)
(ExportedFun -> Map ExportedFun Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExportedFun
f Map ExportedFun Key
e)
lu :: LinkableUnit
lu = (Module
key, Key
lun)
in Set LinkableUnit
-> Set LinkableUnit -> [ExportedFun] -> IO (Set LinkableUnit)
go' Set LinkableUnit
result (Set LinkableUnit
-> Set LinkableUnit -> [LinkableUnit] -> Set LinkableUnit
addOpen Set LinkableUnit
result Set LinkableUnit
open [LinkableUnit
lu]) [ExportedFun]
fs
addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit]
-> Set LinkableUnit
addOpen :: Set LinkableUnit
-> Set LinkableUnit -> [LinkableUnit] -> Set LinkableUnit
addOpen Set LinkableUnit
result Set LinkableUnit
open [LinkableUnit]
newUnits =
let alreadyLinked :: LinkableUnit -> Bool
alreadyLinked LinkableUnit
s = LinkableUnit -> Set LinkableUnit -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
result Bool -> Bool -> Bool
||
LinkableUnit -> Set LinkableUnit -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
open Bool -> Bool -> Bool
||
LinkableUnit -> Set LinkableUnit -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
base
in Set LinkableUnit
open Set LinkableUnit -> Set LinkableUnit -> Set LinkableUnit
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [LinkableUnit] -> Set LinkableUnit
forall a. Ord a => [a] -> Set a
S.fromList ((LinkableUnit -> Bool) -> [LinkableUnit] -> [LinkableUnit]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LinkableUnit -> Bool) -> LinkableUnit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkableUnit -> Bool
alreadyLinked) [LinkableUnit]
newUnits)
collectDeps :: Map Module (Deps, DepsLocation)
-> [UnitId]
-> Set LinkableUnit
-> IO [ModuleCode]
collectDeps :: Map Module (Deps, DepsLocation)
-> [UnitId] -> Set LinkableUnit -> IO [ModuleCode]
collectDeps Map Module (Deps, DepsLocation)
mod_deps [UnitId]
packages Set LinkableUnit
all_deps = do
let packages' :: [UnitId]
packages' = ([UnitId] -> [UnitId] -> [UnitId])
-> ([UnitId], [UnitId]) -> [UnitId]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
(++) (([UnitId], [UnitId]) -> [UnitId])
-> ([UnitId], [UnitId]) -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> ([UnitId], [UnitId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
primUnitId) ([UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub [UnitId]
packages)
units_by_module :: Map Module IntSet
units_by_module :: Map Module BlockIds
units_by_module = (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
$
(LinkableUnit -> (Module, BlockIds))
-> [LinkableUnit] -> [(Module, BlockIds)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,Key
n) -> (Module
m, Key -> BlockIds
IS.singleton Key
n)) (Set LinkableUnit -> [LinkableUnit]
forall a. Set a -> [a]
S.toList Set LinkableUnit
all_deps)
mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)]
mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)]
mod_deps_bypkg = ([(Deps, DepsLocation)]
-> [(Deps, DepsLocation)] -> [(Deps, DepsLocation)])
-> [(UnitId, [(Deps, DepsLocation)])]
-> Map UnitId [(Deps, DepsLocation)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [(Deps, DepsLocation)]
-> [(Deps, DepsLocation)] -> [(Deps, DepsLocation)]
forall a. [a] -> [a] -> [a]
(++)
(((Module, (Deps, DepsLocation))
-> (UnitId, [(Deps, DepsLocation)]))
-> [(Module, (Deps, DepsLocation))]
-> [(UnitId, [(Deps, DepsLocation)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,(Deps, DepsLocation)
v) -> (Module -> UnitId
moduleUnitId Module
m,[(Deps, DepsLocation)
v])) (Map Module (Deps, DepsLocation) -> [(Module, (Deps, DepsLocation))]
forall k a. Map k a -> [(k, a)]
M.toList Map Module (Deps, DepsLocation)
mod_deps))
ArchiveState
ar_state <- IO ArchiveState
emptyArchiveState
([[Maybe ModuleCode]] -> [ModuleCode])
-> IO [[Maybe ModuleCode]] -> IO [ModuleCode]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe ModuleCode] -> [ModuleCode]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ModuleCode] -> [ModuleCode])
-> ([[Maybe ModuleCode]] -> [Maybe ModuleCode])
-> [[Maybe ModuleCode]]
-> [ModuleCode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe ModuleCode]] -> [Maybe ModuleCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IO [[Maybe ModuleCode]] -> IO [ModuleCode])
-> ((UnitId -> IO [Maybe ModuleCode]) -> IO [[Maybe ModuleCode]])
-> (UnitId -> IO [Maybe ModuleCode])
-> IO [ModuleCode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId]
-> (UnitId -> IO [Maybe ModuleCode]) -> IO [[Maybe ModuleCode]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitId]
packages' ((UnitId -> IO [Maybe ModuleCode]) -> IO [ModuleCode])
-> (UnitId -> IO [Maybe ModuleCode]) -> IO [ModuleCode]
forall a b. (a -> b) -> a -> b
$ \UnitId
pkg ->
((Deps, DepsLocation) -> IO (Maybe ModuleCode))
-> [(Deps, DepsLocation)] -> IO [Maybe ModuleCode]
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 ((Deps -> DepsLocation -> IO (Maybe ModuleCode))
-> (Deps, DepsLocation) -> IO (Maybe ModuleCode)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Deps -> DepsLocation -> IO (Maybe ModuleCode))
-> (Deps, DepsLocation) -> IO (Maybe ModuleCode))
-> (Deps -> DepsLocation -> IO (Maybe ModuleCode))
-> (Deps, DepsLocation)
-> IO (Maybe ModuleCode)
forall a b. (a -> b) -> a -> b
$ ArchiveState
-> Map Module BlockIds
-> Deps
-> DepsLocation
-> IO (Maybe ModuleCode)
extractDeps ArchiveState
ar_state Map Module BlockIds
units_by_module)
([(Deps, DepsLocation)]
-> Maybe [(Deps, DepsLocation)] -> [(Deps, DepsLocation)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Deps, DepsLocation)] -> [(Deps, DepsLocation)])
-> Maybe [(Deps, DepsLocation)] -> [(Deps, DepsLocation)]
forall a b. (a -> b) -> a -> b
$ UnitId
-> Map UnitId [(Deps, DepsLocation)]
-> Maybe [(Deps, DepsLocation)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UnitId
pkg Map UnitId [(Deps, DepsLocation)]
mod_deps_bypkg)
extractDeps :: ArchiveState
-> Map Module IntSet
-> Deps
-> DepsLocation
-> IO (Maybe ModuleCode)
ArchiveState
ar_state Map Module BlockIds
units Deps
deps DepsLocation
loc =
case Module -> Map Module BlockIds -> Maybe BlockIds
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mod Map Module BlockIds
units of
Maybe BlockIds
Nothing -> Maybe ModuleCode -> IO (Maybe ModuleCode)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleCode
forall a. Maybe a
Nothing
Just BlockIds
mod_units -> ModuleCode -> Maybe ModuleCode
forall a. a -> Maybe a
Just (ModuleCode -> Maybe ModuleCode)
-> IO ModuleCode -> IO (Maybe ModuleCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let selector :: Word -> IndexEntry -> Bool
selector Word
n IndexEntry
_ = Word -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n Key -> BlockIds -> Bool
`IS.member` BlockIds
mod_units Bool -> Bool -> Bool
|| Key -> Bool
isGlobalUnit (Word -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n)
case DepsLocation
loc of
ObjectFile FilePath
fp -> do
[ObjUnit]
us <- FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
readObjectUnits FilePath
fp Word -> IndexEntry -> Bool
selector
ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjUnit] -> ModuleCode
collectCode [ObjUnit]
us)
ArchiveFile FilePath
a -> do
Object
obj <- ArchiveState -> Module -> FilePath -> IO Object
readArObject ArchiveState
ar_state Module
mod FilePath
a
[ObjUnit]
us <- Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
getObjectUnits Object
obj Word -> IndexEntry -> Bool
selector
ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjUnit] -> ModuleCode
collectCode [ObjUnit]
us)
InMemory FilePath
_n Object
obj -> do
[ObjUnit]
us <- Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
getObjectUnits Object
obj Word -> IndexEntry -> Bool
selector
ModuleCode -> IO ModuleCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ObjUnit] -> ModuleCode
collectCode [ObjUnit]
us)
where
mod :: Module
mod = Deps -> Module
depsModule Deps
deps
newline :: ByteString
newline = FilePath -> ByteString
BC.pack FilePath
"\n"
mk_exports :: [ObjUnit] -> ByteString
mk_exports = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ([ObjUnit] -> [ByteString]) -> [ObjUnit] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse ByteString
newline ([ByteString] -> [ByteString])
-> ([ObjUnit] -> [ByteString]) -> [ObjUnit] -> [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])
-> ([ObjUnit] -> [ByteString]) -> [ObjUnit] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjUnit -> ByteString) -> [ObjUnit] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ObjUnit -> ByteString
oiRaw
mk_js_code :: [ObjUnit] -> JStat
mk_js_code = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> ([ObjUnit] -> [JStat]) -> [ObjUnit] -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjUnit -> JStat) -> [ObjUnit] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map ObjUnit -> JStat
oiStat
collectCode :: [ObjUnit] -> ModuleCode
collectCode [ObjUnit]
l = ModuleCode
{ mc_module :: Module
mc_module = Module
mod
, mc_js_code :: JStat
mc_js_code = [ObjUnit] -> JStat
mk_js_code [ObjUnit]
l
, mc_exports :: ByteString
mc_exports = [ObjUnit] -> ByteString
mk_exports [ObjUnit]
l
, mc_closures :: [ClosureInfo]
mc_closures = (ObjUnit -> [ClosureInfo]) -> [ObjUnit] -> [ClosureInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjUnit -> [ClosureInfo]
oiClInfo [ObjUnit]
l
, mc_statics :: [StaticInfo]
mc_statics = (ObjUnit -> [StaticInfo]) -> [ObjUnit] -> [StaticInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjUnit -> [StaticInfo]
oiStatic [ObjUnit]
l
, mc_frefs :: [ForeignJSRef]
mc_frefs = (ObjUnit -> [ForeignJSRef]) -> [ObjUnit] -> [ForeignJSRef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjUnit -> [ForeignJSRef]
oiFImports [ObjUnit]
l
}
readArObject :: ArchiveState -> Module -> FilePath -> IO Object
readArObject :: ArchiveState -> Module -> FilePath -> IO Object
readArObject ArchiveState
ar_state Module
mod FilePath
ar_file = do
Map FilePath Archive
loaded_ars <- IORef (Map FilePath Archive) -> IO (Map FilePath Archive)
forall a. IORef a -> IO a
readIORef (ArchiveState -> IORef (Map FilePath Archive)
loadedArchives ArchiveState
ar_state)
(Ar.Archive [ArchiveEntry]
entries) <- 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 (ArchiveState -> IORef (Map FilePath Archive)
loadedArchives ArchiveState
ar_state) (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
let go_entries :: [ArchiveEntry] -> IO Object
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
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
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
-> BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name
[ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
entries
diffDeps
:: [UnitId]
-> ([UnitId], Set ExportedFun)
-> ([UnitId], Set ExportedFun)
diffDeps :: [UnitId]
-> ([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun)
diffDeps [UnitId]
pkgs ([UnitId]
deps_pkgs,Set ExportedFun
deps_funs) =
( (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitId -> Bool
linked_pkg [UnitId]
deps_pkgs
, (ExportedFun -> Bool) -> Set ExportedFun -> Set ExportedFun
forall a. (a -> Bool) -> Set a -> Set a
S.filter ExportedFun -> Bool
linked_fun Set ExportedFun
deps_funs
)
where
linked_fun :: ExportedFun -> Bool
linked_fun ExportedFun
f = Module -> UnitId
moduleUnitId (ExportedFun -> Module
funModule ExportedFun
f) UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set UnitId
linked_pkgs
linked_pkg :: UnitId -> Bool
linked_pkg UnitId
p = UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member UnitId
p Set UnitId
linked_pkgs
linked_pkgs :: Set UnitId
linked_pkgs = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
S.fromList [UnitId]
pkgs
rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
rtsDeps [UnitId]
pkgs = [UnitId]
-> ([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun)
diffDeps [UnitId]
pkgs (([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun))
-> ([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun)
forall a b. (a -> b) -> a -> b
$
( [UnitId
baseUnitId, 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]
mkBaseFuns FastString
"GHC.Conc.Sync"
[FastString
"reportError"]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"Control.Exception.Base"
[FastString
"nonTermination"]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.Exception.Type"
[ FastString
"SomeException"
, FastString
"underflowException"
, FastString
"overflowException"
, FastString
"divZeroException"
]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.TopHandler"
[ FastString
"runMainIO"
, FastString
"topHandler"
]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.Base"
[FastString
"$fMonadIO"]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.Maybe"
[ FastString
"Nothing"
, FastString
"Just"
]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.Ptr"
[FastString
"Ptr"]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.JS.Prim"
[ FastString
"JSVal"
, FastString
"JSException"
, FastString
"$fShowJSException"
, FastString
"$fExceptionJSException"
, FastString
"resolve"
, FastString
"resolveIO"
, FastString
"toIO"
]
, FastString -> [FastString] -> [ExportedFun]
mkBaseFuns FastString
"GHC.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.Prim"
[ FastString
"(,)"
, FastString
"(,,)"
, FastString
"(,,,)"
, FastString
"(,,,,)"
, FastString
"(,,,,,)"
, FastString
"(,,,,,,)"
, FastString
"(,,,,,,,)"
, FastString
"(,,,,,,,,)"
, FastString
"(,,,,,,,,,)"
]
]
)
mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
mkBaseFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
baseUnitId
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 = (FastString -> ExportedFun) -> [FastString] -> [ExportedFun]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> ExportedFun
mk_fun [FastString]
symbols
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)
mk_fun :: FastString -> ExportedFun
mk_fun FastString
sym = Module -> LexicalFastString -> ExportedFun
ExportedFun Module
mod (FastString -> LexicalFastString
LexicalFastString (Bool -> Module -> FastString -> FastString
mkJsSymbol Bool
True Module
mod FastString
sym))
loadObjDeps :: [LinkedObj]
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadObjDeps :: [LinkedObj] -> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadObjDeps [LinkedObj]
objs = ([(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
prepareLoadedDeps ([(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> ([Maybe (Deps, DepsLocation)] -> [(Deps, DepsLocation)])
-> [Maybe (Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Deps, DepsLocation)] -> [(Deps, DepsLocation)]
forall a. [Maybe a] -> [a]
catMaybes) ([Maybe (Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> IO [Maybe (Deps, DepsLocation)]
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LinkedObj -> IO (Maybe (Deps, DepsLocation)))
-> [LinkedObj] -> IO [Maybe (Deps, DepsLocation)]
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 LinkedObj -> IO (Maybe (Deps, DepsLocation))
readDepsFromObj [LinkedObj]
objs
loadArchiveDeps :: GhcjsEnv
-> [FilePath]
-> IO ( Map Module (Deps, DepsLocation)
, [LinkableUnit]
)
loadArchiveDeps :: GhcjsEnv
-> [FilePath]
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadArchiveDeps GhcjsEnv
env [FilePath]
archives = MVar
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> (Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit])))
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (GhcjsEnv
-> MVar
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]))
linkerArchiveDeps GhcjsEnv
env) ((Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit])))
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> (Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit])))
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
forall a b. (a -> b) -> a -> b
$ \Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
m ->
case Set FilePath
-> Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> Maybe (Map Module (Deps, DepsLocation), [LinkableUnit])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Set FilePath
archives' Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
m of
Just (Map Module (Deps, DepsLocation), [LinkableUnit])
r -> (Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit]))
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
m, (Map Module (Deps, DepsLocation), [LinkableUnit])
r)
Maybe (Map Module (Deps, DepsLocation), [LinkableUnit])
Nothing -> [FilePath] -> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadArchiveDeps' [FilePath]
archives IO (Map Module (Deps, DepsLocation), [LinkableUnit])
-> ((Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit])))
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit]))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Map Module (Deps, DepsLocation), [LinkableUnit])
r -> (Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit]))
-> IO
(Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]),
(Map Module (Deps, DepsLocation), [LinkableUnit]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set FilePath
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
-> Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Set FilePath
archives' (Map Module (Deps, DepsLocation), [LinkableUnit])
r Map
(Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
m, (Map Module (Deps, DepsLocation), [LinkableUnit])
r)
where
archives' :: Set FilePath
archives' = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList [FilePath]
archives
loadArchiveDeps' :: [FilePath]
-> IO ( Map Module (Deps, DepsLocation)
, [LinkableUnit]
)
loadArchiveDeps' :: [FilePath] -> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadArchiveDeps' [FilePath]
archives = do
[[(Deps, DepsLocation)]]
archDeps <- [FilePath]
-> (FilePath -> IO [(Deps, DepsLocation)])
-> IO [[(Deps, DepsLocation)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
archives ((FilePath -> IO [(Deps, DepsLocation)])
-> IO [[(Deps, DepsLocation)]])
-> (FilePath -> IO [(Deps, DepsLocation)])
-> IO [[(Deps, DepsLocation)]]
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
(Ar.Archive [ArchiveEntry]
entries) <- FilePath -> IO Archive
Ar.loadAr FilePath
file
[Maybe (Deps, DepsLocation)] -> [(Deps, DepsLocation)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Deps, DepsLocation)] -> [(Deps, DepsLocation)])
-> IO [Maybe (Deps, DepsLocation)] -> IO [(Deps, DepsLocation)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchiveEntry -> IO (Maybe (Deps, DepsLocation)))
-> [ArchiveEntry] -> IO [Maybe (Deps, DepsLocation)]
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 (Deps, DepsLocation))
readEntry FilePath
file) [ArchiveEntry]
entries
(Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
prepareLoadedDeps ([(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> [(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
forall a b. (a -> b) -> a -> b
$ [[(Deps, DepsLocation)]] -> [(Deps, DepsLocation)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Deps, DepsLocation)]]
archDeps)
where
readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation))
readEntry :: FilePath -> ArchiveEntry -> IO (Maybe (Deps, DepsLocation))
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 (Deps, DepsLocation)))
-> IO (Maybe (Deps, DepsLocation))
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 (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deps, DepsLocation)
forall a. Maybe a
Nothing
Right ModuleName
mod_name -> do
Object
obj <- BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name
let !deps :: Deps
deps = Object -> Deps
objDeps Object
obj
Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation)))
-> Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a b. (a -> b) -> a -> b
$ (Deps, DepsLocation) -> Maybe (Deps, DepsLocation)
forall a. a -> Maybe a
Just (Deps
deps, FilePath -> DepsLocation
ArchiveFile FilePath
ar_file)
getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString
getJsArchiveEntry :: ArchiveEntry -> Maybe ByteString
getJsArchiveEntry ArchiveEntry
entry = ByteString -> Maybe ByteString
getJsBS (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
entry)
isJsFile :: FilePath -> IO Bool
isJsFile :: FilePath -> IO Bool
isJsFile FilePath
fp = FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
ByteString
bs <- Handle -> Key -> IO ByteString
B.hGet Handle
h Key
jsHeaderLength
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Bool
isJsBS ByteString
bs)
isJsBS :: B.ByteString -> Bool
isJsBS :: ByteString -> Bool
isJsBS ByteString
bs = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (ByteString -> Maybe ByteString
getJsBS ByteString
bs)
getJsBS :: B.ByteString -> Maybe B.ByteString
getJsBS :: ByteString -> Maybe ByteString
getJsBS ByteString
bs = ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
jsHeader ByteString
bs
jsHeader :: B.ByteString
= ByteString
"//JavaScript"
jsHeaderLength :: Int
= ByteString -> Key
B.length ByteString
jsHeader
prepareLoadedDeps :: [(Deps, DepsLocation)]
-> ( Map Module (Deps, DepsLocation)
, [LinkableUnit]
)
prepareLoadedDeps :: [(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
prepareLoadedDeps [(Deps, DepsLocation)]
deps =
let req :: [LinkableUnit]
req = ((Deps, DepsLocation) -> [LinkableUnit])
-> [(Deps, DepsLocation)] -> [LinkableUnit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deps -> [LinkableUnit]
requiredUnits (Deps -> [LinkableUnit])
-> ((Deps, DepsLocation) -> Deps)
-> (Deps, DepsLocation)
-> [LinkableUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Deps, DepsLocation) -> Deps
forall a b. (a, b) -> a
fst) [(Deps, DepsLocation)]
deps
depsMap :: Map Module (Deps, DepsLocation)
depsMap = [(Module, (Deps, DepsLocation))] -> Map Module (Deps, DepsLocation)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Module, (Deps, DepsLocation))]
-> Map Module (Deps, DepsLocation))
-> [(Module, (Deps, DepsLocation))]
-> Map Module (Deps, DepsLocation)
forall a b. (a -> b) -> a -> b
$ ((Deps, DepsLocation) -> (Module, (Deps, DepsLocation)))
-> [(Deps, DepsLocation)] -> [(Module, (Deps, DepsLocation))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Deps, DepsLocation)
d -> (Deps -> Module
depsModule ((Deps, DepsLocation) -> Deps
forall a b. (a, b) -> a
fst (Deps, DepsLocation)
d), (Deps, DepsLocation)
d)) [(Deps, DepsLocation)]
deps
in (Map Module (Deps, DepsLocation)
depsMap, [LinkableUnit]
req)
requiredUnits :: Deps -> [LinkableUnit]
requiredUnits :: Deps -> [LinkableUnit]
requiredUnits Deps
d = (Key -> LinkableUnit) -> [Key] -> [LinkableUnit]
forall a b. (a -> b) -> [a] -> [b]
map (Deps -> Module
depsModule Deps
d,) (BlockIds -> [Key]
IS.toList (BlockIds -> [Key]) -> BlockIds -> [Key]
forall a b. (a -> b) -> a -> b
$ Deps -> BlockIds
depsRequired Deps
d)
readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation))
readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation))
readDepsFromObj = \case
ObjLoaded FilePath
name Object
obj -> do
let !deps :: Deps
deps = Object -> Deps
objDeps Object
obj
Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation)))
-> Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a b. (a -> b) -> a -> b
$ (Deps, DepsLocation) -> Maybe (Deps, DepsLocation)
forall a. a -> Maybe a
Just (Deps
deps,FilePath -> Object -> DepsLocation
InMemory FilePath
name Object
obj)
ObjFile FilePath
file -> do
FilePath -> IO (Maybe Deps)
readObjectDeps FilePath
file IO (Maybe Deps)
-> (Maybe Deps -> IO (Maybe (Deps, DepsLocation)))
-> IO (Maybe (Deps, DepsLocation))
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 Deps
Nothing -> Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deps, DepsLocation)
forall a. Maybe a
Nothing
Just Deps
deps -> Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation)))
-> Maybe (Deps, DepsLocation) -> IO (Maybe (Deps, DepsLocation))
forall a b. (a -> b) -> a -> b
$ (Deps, DepsLocation) -> Maybe (Deps, DepsLocation)
forall a. a -> Maybe a
Just (Deps
deps,FilePath -> DepsLocation
ObjectFile FilePath
file)
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)
let header :: FilePath
header = FilePath
"//JavaScript\n"
FilePath -> IO Bool
jsFileNeedsCpp FilePath
input_fn IO Bool -> (Bool -> 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
>>= \case
Bool
False -> FilePath -> FilePath -> FilePath -> IO ()
copyWithHeader FilePath
header FilePath
input_fn FilePath
output_fn
Bool
True -> do
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)
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
{ cppUseCc :: Bool
cppUseCc = Bool
True
, cppLinePragmas :: Bool
cppLinePragmas = Bool
False
}
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 -> FilePath -> FilePath -> IO ()
copyWithHeader FilePath
header FilePath
js_fn FilePath
output_fn
jsFileNeedsCpp :: FilePath -> IO Bool
jsFileNeedsCpp :: FilePath -> IO Bool
jsFileNeedsCpp FilePath
fn = do
[JSOption]
opts <- FilePath -> IO [JSOption]
getOptionsFromJsFile FilePath
fn
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSOption
CPP JSOption -> [JSOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [JSOption]
opts)
linkModules :: [ModuleCode] -> ([CompactedModuleCode], 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)
, [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((ClosureInfo -> JStat) -> [ClosureInfo] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ClosureInfo -> JStat
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 -> JStat
staticInitStat :: StaticInfo -> JStat
staticInitStat (StaticInfo FastString
i StaticVal
sv Maybe Ident
mcc) =
case StaticVal
sv of
StaticData FastString
con [StaticArg]
args -> FastString -> [JExpr] -> JStat
appS FastString
"h$sti" ([JExpr] -> JStat) -> [JExpr] -> JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
add_cc_arg
[ FastString -> JExpr
var FastString
i
, FastString -> JExpr
var FastString
con
, [StaticArg] -> JExpr
jsStaticArgs [StaticArg]
args
]
StaticFun FastString
f [StaticArg]
args -> FastString -> [JExpr] -> JStat
appS FastString
"h$sti" ([JExpr] -> JStat) -> [JExpr] -> JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
add_cc_arg
[ FastString -> JExpr
var FastString
i
, FastString -> JExpr
var FastString
f
, [StaticArg] -> JExpr
jsStaticArgs [StaticArg]
args
]
StaticList [StaticArg]
args Maybe FastString
mt -> FastString -> [JExpr] -> JStat
appS FastString
"h$stl" ([JExpr] -> JStat) -> [JExpr] -> JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
add_cc_arg
[ FastString -> JExpr
var FastString
i
, [StaticArg] -> JExpr
jsStaticArgs [StaticArg]
args
, JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (JExpr -> JExpr) -> JExpr -> JExpr
forall a b. (a -> b) -> a -> b
$ JExpr -> (FastString -> JExpr) -> Maybe FastString -> JExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JExpr
null_ (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> (FastString -> Ident) -> FastString -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> Ident
TxtI) Maybe FastString
mt
]
StaticThunk (Just (FastString
f,[StaticArg]
args)) -> FastString -> [JExpr] -> JStat
appS FastString
"h$stc" ([JExpr] -> JStat) -> [JExpr] -> JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
add_cc_arg
[ FastString -> JExpr
var FastString
i
, FastString -> JExpr
var FastString
f
, [StaticArg] -> JExpr
jsStaticArgs [StaticArg]
args
]
StaticVal
_ -> JStat
forall a. Monoid a => a
mempty
where
add_cc_arg :: [JExpr] -> [JExpr]
add_cc_arg [JExpr]
as = case Maybe Ident
mcc of
Maybe Ident
Nothing -> [JExpr]
as
Just Ident
cc -> [JExpr]
as [JExpr] -> [JExpr] -> [JExpr]
forall a. [a] -> [a] -> [a]
++ [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
cc]
staticDeclStat :: StaticInfo -> JStat
staticDeclStat :: StaticInfo -> JStat
staticDeclStat (StaticInfo FastString
global_name StaticVal
static_value Maybe Ident
_) = JStat
decl
where
global_ident :: Ident
global_ident = FastString -> Ident
TxtI FastString
global_name
decl_init :: JExpr -> JStat
decl_init JExpr
v = Ident
global_ident Ident -> JExpr -> JStat
||= JExpr
v
decl_no_init :: JStat
decl_no_init = FastString -> [JExpr] -> JStat
appS FastString
"h$di" [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
global_ident]
decl :: JStat
decl = case StaticVal
static_value of
StaticUnboxed StaticUnboxed
u -> JExpr -> JStat
decl_init (StaticUnboxed -> JExpr
unboxed_expr StaticUnboxed
u)
StaticThunk Maybe (FastString, [StaticArg])
Nothing -> JStat
decl_no_init
StaticVal
_ -> JExpr -> JStat
decl_init (FastString -> [JExpr] -> JExpr
app FastString
"h$d" [])
unboxed_expr :: StaticUnboxed -> JExpr
unboxed_expr = \case
StaticUnboxedBool Bool
b -> FastString -> [JExpr] -> JExpr
app FastString
"h$p" [Bool -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Bool
b]
StaticUnboxedInt Integer
i -> FastString -> [JExpr] -> JExpr
app FastString
"h$p" [Integer -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Integer
i]
StaticUnboxedDouble SaneDouble
d -> FastString -> [JExpr] -> JExpr
app FastString
"h$p" [Double -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (SaneDouble -> Double
unSaneDouble SaneDouble
d)]
StaticUnboxedString ByteString
str -> FastString -> [JExpr] -> JExpr
app FastString
"h$rawStringData" [JVal -> JExpr
ValExpr (ByteString -> JVal
to_byte_list ByteString
str)]
StaticUnboxedStringOffset {} -> JExpr
0
to_byte_list :: ByteString -> JVal
to_byte_list = [JExpr] -> JVal
JList ([JExpr] -> JVal) -> (ByteString -> [JExpr]) -> ByteString -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> JExpr) -> [Word8] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> JExpr
Int (Integer -> JExpr) -> (Word8 -> Integer) -> Word8 -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> [JExpr])
-> (ByteString -> [Word8]) -> ByteString -> [JExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack