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

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

module GHC.StgToJS.Linker.Linker
  ( jsLinkBinary
  , 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) -- ^ number of bytes linked per module
  , LinkerStats -> Word64
packedMetaDataSize :: !Word64              -- ^ number of bytes for metadata
  }

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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
    -- additional objects to link are passed as FileOption ldInputs...
    let cmdline_objs :: [FilePath]
cmdline_objs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
    -- discriminate JavaScript sources from real object files.
    ([FilePath]
cmdline_js_srcs, [FilePath]
cmdline_js_objs) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
isJsFile [FilePath]
cmdline_objs
    let
        objs' :: [LinkedObj]
objs'    = forall a b. (a -> b) -> [a] -> [b]
map FilePath -> LinkedObj
ObjFile ([FilePath]
objs forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_js_objs)
        js_srcs' :: [FilePath]
js_srcs' = [FilePath]
js_srcs forall a. [a] -> [a] -> [a]
++ [FilePath]
cmdline_js_srcs
        isRoot :: p -> Bool
isRoot p
_ = Bool
True
        exe :: FilePath
exe      = DynFlags -> FilePath
jsExeFileName DynFlags
dflags

    forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 forall a. Monoid a => a
mempty [UnitId]
dep_pkgs [LinkedObj]
objs' [FilePath]
js_srcs' forall {p}. p -> Bool
isRoot forall a. Monoid a => a
mempty

-- | link and write result to disk (jsexe directory)
link :: JSLinkConfig
     -> StgToJSConfig
     -> Logger
     -> UnitEnv
     -> FilePath               -- ^ output file/directory
     -> [FilePath]             -- ^ include path for home package
     -> [UnitId]               -- ^ packages to link
     -> [LinkedObj]            -- ^ the object files we're linking
     -> [FilePath]             -- ^ extra js files to include
     -> (ExportedFun -> Bool)  -- ^ functions from the objects to use as roots (include all their deps)
     -> Set ExportedFun        -- ^ extra symbols to link in
     -> 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

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

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

      -- compute dependencies
      (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

      -- retrieve code for dependencies
      [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

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

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

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

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

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

      -- link generated RTS parts into rts.js
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcNoRts JSLinkConfig
lc_cfg) 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
                                         forall a. Semigroup a => a -> a -> a
<> FilePath -> ByteString
BLC.pack (StgToJSConfig -> FilePath
rtsText StgToJSConfig
cfg))

      -- link dependencies' JS files into lib.js
      forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
out FilePath -> FilePath -> FilePath
</> FilePath
"lib.js") IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
dep_archives forall a b. (a -> b) -> a -> b
$ \FilePath
archive_file -> do
          Ar.Archive [ArchiveEntry]
entries <- FilePath -> IO Archive
Ar.loadAr FilePath
archive_file
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ArchiveEntry]
entries forall a b. (a -> b) -> a -> b
$ \ArchiveEntry
entry -> do
            case ArchiveEntry -> Maybe ByteString
getJsArchiveEntry ArchiveEntry
entry of
              Maybe ByteString
Nothing -> 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'

      -- link everything together into all.js
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSLinkConfig -> Bool
generateAllJs JSLinkConfig
lc_cfg) 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    = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ExportedFun -> Bool
isRootFun forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deps -> Map ExportedFun Key
depsHaskellExported forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall k a. Map k a -> [a]
M.elems Map Module (Deps, DepsLocation)
objDepsMap)
      rootMods :: [FilePath]
rootMods = forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> FilePath
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ExportedFun -> Module
funModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set ExportedFun
roots
      objPkgs :: [UnitId]
objPkgs  = forall a b. (a -> b) -> [a] -> [b]
map Module -> UnitId
moduleUnitId forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub (forall k a. Map k a -> [k]
M.keys Map Module (Deps, DepsLocation)
objDepsMap)

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
2) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
    Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [doc] -> doc
hcat
      [ forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking ", forall doc. IsLine doc => FilePath -> doc
text FilePath
target, forall doc. IsLine doc => FilePath -> doc
text FilePath
" (", forall doc. IsLine doc => FilePath -> doc
text (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," [FilePath]
rootMods), forall doc. IsLine doc => Char -> doc
char Char
')' ]
    Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [doc] -> doc
hcat
      [ forall doc. IsLine doc => FilePath -> doc
text FilePath
"objDepsMap ", forall a. Outputable a => a -> SDoc
ppr Map Module (Deps, DepsLocation)
objDepsMap ]
    Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [doc] -> doc
hcat
      [ forall doc. IsLine doc => FilePath -> doc
text FilePath
"objFiles ", 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

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

  -- all the units we want to link together, including their dependencies,
  -- preload units, and backpack instantiations
  [UnitInfo]
all_units_infos <- 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
2) forall a b. (a -> b) -> a -> b
$
    Logger -> SDoc -> IO ()
logInfo Logger
logger forall a b. (a -> b) -> a -> b
$ SDoc -> Key -> SDoc -> SDoc
hang (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linking with archives:") Key
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall doc. IsLine doc => FilePath -> doc
text [FilePath]
dep_archives))

  -- compute dependencies
  let dep_units :: [UnitId]
dep_units      = [UnitId]
all_units forall a. [a] -> [a] -> [a]
++ [forall u. GenHomeUnit u -> UnitId
homeUnitId (UnitEnv -> HomeUnit
ue_unsafeHomeUnit forall a b. (a -> b) -> a -> b
$ UnitEnv
unit_env)]
      dep_map :: Map Module (Deps, DepsLocation)
dep_map        = Map Module (Deps, DepsLocation)
objDepsMap 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 = forall a. Set a
S.empty
      dep_fun_roots :: Set ExportedFun
dep_fun_roots  = Set ExportedFun
roots forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set ExportedFun
rts_wired_functions forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set ExportedFun
extraStaticDeps
      dep_unit_roots :: [LinkableUnit]
dep_unit_roots = [LinkableUnit]
archsRequiredUnits forall a. [a] -> [a] -> [a]
++ [LinkableUnit]
objRequiredUnits

  Set LinkableUnit
all_deps <- Map Module Deps
-> Set LinkableUnit
-> Set ExportedFun
-> [LinkableUnit]
-> IO (Set LinkableUnit)
getDeps (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Map Module (Deps, DepsLocation)
dep_map) forall a. Set a
excluded_units Set ExportedFun
dep_fun_roots [LinkableUnit]
dep_unit_roots

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Key -> Bool
logVerbAtLeast Logger
logger Key
2) forall a b. (a -> b) -> a -> b
$
    Logger -> SDoc -> IO ()
logInfo Logger
logger forall a b. (a -> b) -> a -> b
$ SDoc -> Key -> SDoc -> SDoc
hang (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Units to link:") Key
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Outputable a => a -> SDoc
ppr [UnitId]
dep_units))
    -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps)))

  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)


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

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

-- | Link modules and pretty-print them into the given Handle
renderLinker
  :: Handle
  -> [ModuleCode] -- ^ linked code per module
  -> [FilePath]   -- ^ additional JS files
  -> IO LinkerStats
renderLinker :: Handle -> [ModuleCode] -> [FilePath] -> IO LinkerStats
renderLinker Handle
h [ModuleCode]
mods [FilePath]
jsFiles = do

  -- link modules
  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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! (Integer
after forall a. Num a => a -> a -> a
- Integer
before)

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

  -- modules themselves
  [(Module, Word64)]
mod_sizes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CompactedModuleCode]
compacted_mods forall a b. (a -> b) -> a -> b
$ \CompactedModuleCode
m -> do
    !Word64
mod_size <- forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module
mod_mod, Word64
mod_size)

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

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

  -- explicit additional JS files
  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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
putBS) [FilePath]
jsFiles

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

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

-- | Render linker stats
renderLinkerStats :: LinkerStats -> String
renderLinkerStats :: LinkerStats -> FilePath
renderLinkerStats LinkerStats
s =
  forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n\n" [FilePath
meta_stats, FilePath
package_stats, FilePath
module_stats] 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: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Key
length [(Module, Word64)]
bytes_per_mod)
                 forall a. Semigroup a => a -> a -> a
<> FilePath
"\npacked metadata:   " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Word64
meta

    bytes_per_mod :: [(Module, Word64)]
bytes_per_mod = forall k a. Map k a -> [(k, a)]
M.toList 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 = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,Word64
s) -> (Module -> UnitId
moduleUnitId Module
m,Word64
s)) 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 = forall (t :: * -> *) a. Foldable t => t a -> Key
length FilePath
t
              in  if Key
l forall a. Ord a => a -> a -> Bool
< Key
n then FilePath
t forall a. Semigroup a => a -> a -> a
<> forall a. Key -> a -> [a]
replicate (Key
nforall a. Num a => a -> a -> a
-Key
l) Char
' ' else FilePath
t

    pkgMods :: [[(Module,Word64)]]
    pkgMods :: [[(Module, Word64)]]
pkgMods = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Module -> UnitId
moduleUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"    " forall a. Semigroup a => a -> a -> a
<> Module -> FilePath
moduleStableString Module
m forall a. Semigroup a => a -> a -> a
<> FilePath
":") forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Word64
s 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"
                     forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> FilePath
":") forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Word64
s forall a. Semigroup a => a -> a -> a
<> FilePath
"\n") (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" forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines (forall a b. (a -> b) -> [a] -> [b]
map (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 =
  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" forall a. [a] -> [a] -> [a]
++ ShortText -> FilePath
ST.unpack ShortText
l 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
ue_units UnitEnv
unit_env

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


-- | Combine rts.js, lib.js, out.js to all.js that can be run
-- directly with node.js or SpiderMonkey jsshell
combineFiles :: JSLinkConfig
             -> FilePath
             -> IO ()
combineFiles :: JSLinkConfig -> FilePath -> IO ()
combineFiles JSLinkConfig
cfg FilePath
fp = do
  let files :: [FilePath]
files = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
fp FilePath -> FilePath -> FilePath
</>) [FilePath
"rts.js", FilePath
"lib.js", FilePath
"out.js"]
  forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
"all.js") IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    let cpy :: FilePath -> IO ()
cpy FilePath
i = FilePath -> IO ByteString
B.readFile FilePath
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> ByteString -> IO ()
B.hPut Handle
h
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
cpy [FilePath]
files
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (JSLinkConfig -> Bool
lcNoHsMain JSLinkConfig
cfg) forall a b. (a -> b) -> a -> b
$ do
      Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
runMainJS

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


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

-- | write the runmain.js file that will be run with defer so that it runs after
-- index.html is loaded
writeRunMain
  :: FilePath -- ^ output directory
  -> 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
e 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 -- ^ Settings
            -> FilePath     -- ^ Output directory
            -> IO ()
writeRunner :: JSLinkConfig -> FilePath -> IO ()
writeRunner JSLinkConfig
_settings FilePath
out = do
  FilePath
cd    <- IO FilePath
getCurrentDirectory
  let arch_os :: ArchOS
arch_os = ArchOS
hostPlatformArchOS
  let runner :: FilePath
runner  = FilePath
cd FilePath -> FilePath -> FilePath
</> ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os Bool
False (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 " forall a. Semigroup a => a -> a -> a
<> ByteString
nodePgm forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" 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 :: Bool
executable = Bool
True})

rtsExterns :: FastString
rtsExterns :: FastString
rtsExterns =
  FastString
"// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" forall a. Semigroup a => a -> a -> a
<>
  forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (\Key
x -> FastString
"/** @type {*} */\nObject.d" forall a. Semigroup a => a -> a -> a
<> FilePath -> FastString
mkFastString (forall a. Show a => a -> FilePath
show Key
x) 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")
  forall a b. (a -> b) -> a -> b
$ FastString -> FilePath
unpackFS FastString
rtsExterns

-- | get all dependencies for a given set of roots
getDeps :: Map Module Deps  -- ^ loaded deps
        -> Set LinkableUnit -- ^ don't link these blocks
        -> Set ExportedFun  -- ^ start here
        -> [LinkableUnit]   -- ^ and also link these
        -> 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' forall a. Set a
S.empty (forall a. Ord a => [a] -> Set a
S.fromList [LinkableUnit]
startlu) (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 forall a. Set a -> Maybe (a, Set a)
S.minView Set LinkableUnit
open of
      Maybe (LinkableUnit, Set LinkableUnit)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Set LinkableUnit
result
      Just (lu :: LinkableUnit
lu@(Module
lmod,Key
n), Set LinkableUnit
open') ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
lmod Map Module Deps
loaded_deps of
            Maybe Deps
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps.go: object file not loaded for:  " (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
bforall i e. Ix i => Array i e -> i -> e
!Key
n
                  result' :: Set LinkableUnit
result' = 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' forall a b. (a -> b) -> a -> b
$
                   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 forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
key Map Module Deps
loaded_deps of
              Maybe Deps
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"getDeps.go': object file not loaded for:  " forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"exported function not found: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr ExportedFun
f)
                                     (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 = forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
result Bool -> Bool -> Bool
||
                            forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
open   Bool -> Bool -> Bool
||
                            forall a. Ord a => a -> Set a -> Bool
S.member LinkableUnit
s Set LinkableUnit
base
      in  Set LinkableUnit
open forall a. Ord a => Set a -> Set a -> Set a
`S.union` forall a. Ord a => [a] -> Set a
S.fromList (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkableUnit -> Bool
alreadyLinked) [LinkableUnit]
newUnits)

-- | collect dependencies for a set of roots
collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map
            -> [UnitId]                        -- ^ packages, code linked in this order
            -> Set LinkableUnit                -- ^ All dependencides
            -> 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

  -- read ghc-prim first, since we depend on that for static initialization
  let packages' :: [UnitId]
packages' = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a. Eq a => a -> a -> Bool
== UnitId
primUnitId) (forall a. Eq a => [a] -> [a]
nub [UnitId]
packages)

      units_by_module :: Map Module IntSet
      units_by_module :: Map Module BlockIds
units_by_module = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith BlockIds -> BlockIds -> BlockIds
IS.union forall a b. (a -> b) -> a -> b
$
                      forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,Key
n) -> (Module
m, Key -> BlockIds
IS.singleton Key
n)) (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 = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++)
                        (forall a b. (a -> b) -> [a] -> [b]
map (\(Module
m,(Deps, DepsLocation)
v) -> (Module -> UnitId
moduleUnitId Module
m,[(Deps, DepsLocation)
v])) (forall k a. Map k a -> [(k, a)]
M.toList Map Module (Deps, DepsLocation)
mod_deps))

  ArchiveState
ar_state <- IO ArchiveState
emptyArchiveState
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitId]
packages' forall a b. (a -> b) -> a -> b
$ \UnitId
pkg ->
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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)
         (forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ 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)
extractDeps :: ArchiveState
-> Map Module BlockIds
-> Deps
-> DepsLocation
-> IO (Maybe ModuleCode)
extractDeps ArchiveState
ar_state Map Module BlockIds
units Deps
deps DepsLocation
loc =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mod Map Module BlockIds
units of
    Maybe BlockIds
Nothing       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just BlockIds
mod_units -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      let selector :: Word -> IndexEntry -> Bool
selector Word
n IndexEntry
_  = 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 (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
          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
          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
          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    = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse ByteString
newline forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ObjUnit -> ByteString
oiRaw
    mk_js_code :: [ObjUnit] -> JStat
mk_js_code    = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjUnit -> [ClosureInfo]
oiClInfo [ObjUnit]
l
                      , mc_statics :: [StaticInfo]
mc_statics  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ObjUnit -> [StaticInfo]
oiStatic [ObjUnit]
l
                      , mc_frefs :: [ForeignJSRef]
mc_frefs    = 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 <- forall a. IORef a -> IO a
readIORef (ArchiveState -> IORef (Map FilePath Archive)
loadedArchives ArchiveState
ar_state)
  (Ar.Archive [ArchiveEntry]
entries) <- case 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 -> 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
      forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ArchiveState -> IORef (Map FilePath Archive)
loadedArchives ArchiveState
ar_state) (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
ar_file Archive
a)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
a

  -- look for the right object in archive
  let go_entries :: [ArchiveEntry] -> IO Object
go_entries = \case
        -- XXX this shouldn't be an exception probably
        [] -> forall a. HasCallStack => FilePath -> a
panic forall a b. (a -> b) -> a -> b
$ FilePath
"could not find object for module "
                      forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
                      forall a. [a] -> [a] -> [a]
++ FilePath
" in "
                      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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left FilePath
_         -> [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
es -- not a valid object entry
            Right ModuleName
mod_name
              | ModuleName
mod_name forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
mod
              -> [ArchiveEntry] -> IO Object
go_entries [ArchiveEntry]
es -- not the module we're looking for
              | Bool
otherwise
              -> BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name -- found it

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


-- | A helper function to read system dependencies that are hardcoded
diffDeps
  :: [UnitId]                    -- ^ Packages that are already Linked
  -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link
  -> ([UnitId], Set ExportedFun) -- ^ Diff
diffDeps :: [UnitId]
-> ([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun)
diffDeps [UnitId]
pkgs ([UnitId]
deps_pkgs,Set ExportedFun
deps_funs) =
  ( forall a. (a -> Bool) -> [a] -> [a]
filter   UnitId -> Bool
linked_pkg [UnitId]
deps_pkgs
  , 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) forall a. Ord a => a -> Set a -> Bool
`S.member` Set UnitId
linked_pkgs
    linked_pkg :: UnitId -> Bool
linked_pkg UnitId
p = forall a. Ord a => a -> Set a -> Bool
S.member UnitId
p Set UnitId
linked_pkgs
    linked_pkgs :: Set UnitId
linked_pkgs  = forall a. Ord a => [a] -> Set a
S.fromList [UnitId]
pkgs

-- | dependencies for the RTS, these need to be always linked
rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
rtsDeps [UnitId]
pkgs = [UnitId]
-> ([UnitId], Set ExportedFun) -> ([UnitId], Set ExportedFun)
diffDeps [UnitId]
pkgs forall a b. (a -> b) -> a -> b
$
  ( [UnitId
baseUnitId, UnitId
primUnitId]
  , forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ 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
"(,,,,,,,,,)"
          ]
      ]
  )

-- | Export the functions in base
mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
mkBaseFuns = UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
baseUnitId

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

-- | Given a @UnitId@, a module name, and a set of symbols in the module,
-- package these into an @ExportedFun@.
mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
uid FastString
mod_name [FastString]
symbols = forall a b. (a -> b) -> [a] -> [b]
map FastString -> ExportedFun
mk_fun [FastString]
symbols
  where
    mod :: Module
mod        = forall u. u -> ModuleName -> GenModule u
mkModule (forall uid. Definite uid -> GenUnit uid
RealUnit (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))

-- | read all dependency data from the to-be-linked files
loadObjDeps :: [LinkedObj] -- ^ object files to link
            -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LinkedObj -> IO (Maybe (Deps, DepsLocation))
readDepsFromObj [LinkedObj]
objs

-- | Load dependencies for the Linker from Ar
loadArchiveDeps :: GhcjsEnv
                -> [FilePath]
                -> IO ( Map Module (Deps, DepsLocation)
                      , [LinkableUnit]
                      )
loadArchiveDeps :: GhcjsEnv
-> [FilePath]
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadArchiveDeps GhcjsEnv
env [FilePath]
archives = 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) forall a b. (a -> b) -> a -> b
$ \Map
  (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
m ->
  case 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  -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Map Module (Deps, DepsLocation), [LinkableUnit])
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (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' = 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
archives forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
    (Ar.Archive [ArchiveEntry]
entries) <- FilePath -> IO Archive
Ar.loadAr FilePath
file
    forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> ArchiveEntry -> IO (Maybe (Deps, DepsLocation))
readEntry FilePath
file) [ArchiveEntry]
entries
  forall (m :: * -> *) a. Monad m => a -> m a
return ([(Deps, DepsLocation)]
-> (Map Module (Deps, DepsLocation), [LinkableUnit])
prepareLoadedDeps forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left FilePath
_         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing -- not a valid object entry
            Right ModuleName
mod_name -> do
              Object
obj <- BinHandle -> ModuleName -> IO Object
getObjectBody BinHandle
bh ModuleName
mod_name
              let !deps :: Deps
deps = Object -> Deps
objDeps Object
obj
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Deps
deps, FilePath -> DepsLocation
ArchiveFile FilePath
ar_file)

-- | Predicate to check that an entry in Ar is a JS source
-- and to return it without its header
getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString
getJsArchiveEntry :: ArchiveEntry -> Maybe ByteString
getJsArchiveEntry ArchiveEntry
entry = ByteString -> Maybe ByteString
getJsBS (ArchiveEntry -> ByteString
Ar.filedata ArchiveEntry
entry)

-- | Predicate to check that a file is a JS source
isJsFile :: FilePath -> IO Bool
isJsFile :: FilePath -> IO Bool
isJsFile FilePath
fp = forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  ByteString
bs <- Handle -> Key -> IO ByteString
B.hGet Handle
h Key
jsHeaderLength
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Bool
isJsBS ByteString
bs)

isJsBS :: B.ByteString -> Bool
isJsBS :: ByteString -> Bool
isJsBS ByteString
bs = forall a. Maybe a -> Bool
isJust (ByteString -> Maybe ByteString
getJsBS ByteString
bs)

-- | Get JS source with its header (if it's one)
getJsBS :: B.ByteString -> Maybe B.ByteString
getJsBS :: ByteString -> Maybe ByteString
getJsBS ByteString
bs = ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
jsHeader ByteString
bs

-- Header added to JS sources to discriminate them from other object files.
-- They all have .o extension but JS sources have this header.
jsHeader :: B.ByteString
jsHeader :: ByteString
jsHeader = ByteString
"//JavaScript"

jsHeaderLength :: Int
jsHeaderLength :: Key
jsHeaderLength = 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     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deps -> [LinkableUnit]
requiredUnits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Deps, DepsLocation)]
deps
      depsMap :: Map Module (Deps, DepsLocation)
depsMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Deps, DepsLocation)
d -> (Deps -> Module
depsModule (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 = forall a b. (a -> b) -> [a] -> [b]
map (Deps -> Module
depsModule Deps
d,) (BlockIds -> [Key]
IS.toList forall a b. (a -> b) -> a -> b
$ Deps -> BlockIds
depsRequired Deps
d)

-- | read dependencies from an object that might have already been into memory
-- pulls in all Deps from an archive
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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Deps
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just Deps
deps -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Deps
deps,FilePath -> DepsLocation
ObjectFile FilePath
file)


-- | Embed a JS file into a .o file
--
-- The JS file is merely copied into a .o file with an additional header
-- ("//Javascript") in order to be recognized later on.
--
-- JS files may contain option pragmas of the form: //#OPTIONS:
-- For now, only the CPP option is supported. If the CPP option is set, we
-- append some common CPP definitions to the file and call cpp on it.
embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO ()
embedJsFile :: Logger
-> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO ()
embedJsFile Logger
logger DynFlags
dflags TmpFs
tmpfs UnitEnv
unit_env FilePath
input_fn FilePath
output_fn = do
  let profiling :: Bool
profiling  = Bool
False -- FIXME: add support for profiling way

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

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

  Bool
is_js_obj <- if Bool
True
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                else FilePath -> IO Bool
isJsObjectFile FilePath
input_fn
                -- FIXME (Sylvain 2022-09): this call makes the
                -- testsuite go into a loop, I don't know why yet!
                -- Disabling it for now.

  if Bool
is_js_obj
    then FilePath -> FilePath -> FilePath -> IO ()
copyWithHeader FilePath
"" FilePath
input_fn FilePath
output_fn
    else do
      -- header appended to JS files stored as .o to recognize them.
      let header :: FilePath
header = FilePath
"//JavaScript\n"
      FilePath -> IO Bool
jsFileNeedsCpp FilePath
input_fn 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

          -- append common CPP definitions to the .js file.
          -- They define macros that avoid directly wiring zencoded names
          -- in RTS JS files
          FilePath
pp_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
          ByteString
payload <- FilePath -> IO ByteString
B.readFile FilePath
input_fn
          FilePath -> ByteString -> IO ()
B.writeFile FilePath
pp_fn (Bool -> ByteString
commonCppDefs Bool
profiling forall a. Semigroup a => a -> a -> a
<> ByteString
payload)

          -- run CPP on the input JS file
          FilePath
js_fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
          let
            cpp_opts :: CppOpts
cpp_opts = CppOpts
              { cppUseCc :: Bool
cppUseCc       = Bool
True
              , cppLinePragmas :: Bool
cppLinePragmas = Bool
False -- LINE pragmas aren't JS compatible
              }
          Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> CppOpts
-> FilePath
-> FilePath
-> IO ()
doCpp Logger
logger
                  TmpFs
tmpfs
                  DynFlags
dflags
                  UnitEnv
unit_env
                  CppOpts
cpp_opts
                  FilePath
pp_fn
                  FilePath
js_fn
          -- add header to recognize the object as a JS file
          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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSOption
CPP forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [JSOption]
opts)

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

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

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

    infos :: [ClosureInfo]
infos   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModuleCode -> [ClosureInfo]
mc_closures [ModuleCode]
mods
    meta :: JStat
meta = forall a. Monoid a => [a] -> a
mconcat
            -- render metadata as individual statements
            [ forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map StaticInfo -> JStat
staticDeclStat [StaticInfo]
statics)
            , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map StaticInfo -> JStat
staticInitStat [StaticInfo]
statics)
            , forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ClosureInfo -> JStat
closureInfoStat Bool
True) [ClosureInfo]
infos)
            ]

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

-- | Initialize a global object.
--
-- All global objects have to be declared (staticInfoDecl) first.
staticInitStat :: StaticInfo -> 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" 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" 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" forall a b. (a -> b) -> a -> b
$ [JExpr] -> [JExpr]
add_cc_arg
                                    [ FastString -> JExpr
var FastString
i
                                    , [StaticArg] -> JExpr
jsStaticArgs [StaticArg]
args
                                    , forall a. ToJExpr a => a -> JExpr
toJExpr forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe JExpr
null_ (forall a. ToJExpr a => a -> JExpr
toJExpr 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" 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
_                           -> forall a. Monoid a => a
mempty
  where
    -- add optional cost-center argument
    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 forall a. [a] -> [a] -> [a]
++ [forall a. ToJExpr a => a -> JExpr
toJExpr Ident
cc]

-- | declare and do first-pass init of a global object (create JS object for heap objects)
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" [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 -- CAF initialized in an alternative way
      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" [forall a. ToJExpr a => a -> JExpr
toJExpr Bool
b]
      StaticUnboxedInt Integer
i           -> FastString -> [JExpr] -> JExpr
app FastString
"h$p" [forall a. ToJExpr a => a -> JExpr
toJExpr Integer
i]
      StaticUnboxedDouble SaneDouble
d        -> FastString -> [JExpr] -> JExpr
app FastString
"h$p" [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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Integer -> JExpr
Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack