[Git][ghc/ghc][wip/js-staging] 2 commits: Switch from Data.Binary and ByteString to BinHandle
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Tue Sep 6 16:16:57 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
9956e89c by Sylvain Henry at 2022-09-06T18:17:15+02:00
Switch from Data.Binary and ByteString to BinHandle
- - - - -
24773ce8 by Sylvain Henry at 2022-09-06T18:17:15+02:00
Perf: use Ppr's LeftMode to output JS
- - - - -
11 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Linker/Archive.hs
- compiler/GHC/StgToJS/Linker/Dynamic.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Types.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/Utils/Binary.hs
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -15,7 +15,6 @@ module GHC.Iface.Binary (
readBinIface,
readBinIfaceHeader,
getSymtabName,
- getDictFastString,
CheckHiWay(..),
TraceBinIFace(..),
getWithUserData,
@@ -24,11 +23,8 @@ module GHC.Iface.Binary (
-- * Internal serialisation functions
getSymbolTable,
putName,
- putDictionary,
- putFastString,
putSymbolTable,
BinSymbolTable(..),
- BinDictionary(..)
) where
import GHC.Prelude
@@ -48,7 +44,6 @@ import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Platform
-import GHC.Data.FastString
import GHC.Settings.Constants
import GHC.Utils.Fingerprint
@@ -153,31 +148,28 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
-- Names or FastStrings.
getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
getWithUserData name_cache bh = do
+ bh <- getTables name_cache bh
+ get bh
+
+-- | Setup a BinHandle to read something written using putWithTables
+--
+-- Reading names has the side effect of adding them into the given NameCache.
+getTables :: NameCache -> BinHandle -> IO BinHandle
+getTables name_cache bh = do
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
- dict_p <- Binary.get bh
- data_p <- tellBin bh -- Remember where we are now
- seekBin bh dict_p
- dict <- getDictionary bh
- seekBin bh data_p -- Back to where we were before
+ dict <- Binary.forwardGet bh (getDictionary bh)
-- Initialise the user-data field of bh
- bh <- do
- bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
- (getDictFastString dict)
- symtab_p <- Binary.get bh -- Get the symtab ptr
- data_p <- tellBin bh -- Remember where we are now
- seekBin bh symtab_p
- symtab <- getSymbolTable bh name_cache
- seekBin bh data_p -- Back to where we were before
-
- -- It is only now that we know how to get a Name
- return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
- (getDictFastString dict)
-
- -- Read the interface file
- get bh
+ let bh_fs = setUserData bh $ newReadState (error "getSymtabName")
+ (getDictFastString dict)
+
+ symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)
+
+ -- It is only now that we know how to get a Name
+ return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
+ (getDictFastString dict)
-- | Write an interface file
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
@@ -211,64 +203,63 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
-- This segment should be read using `getWithUserData`.
putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
- -- Remember where the dictionary pointer will go
- dict_p_p <- tellBin bh
- -- Placeholder for ptr to dictionary
- put_ bh dict_p_p
-
- -- Remember where the symbol table pointer will go
- symtab_p_p <- tellBin bh
- put_ bh symtab_p_p
- -- Make some initial state
+ (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
+
+ case traceBinIface of
+ QuietBinIFace -> return ()
+ TraceBinIFace printer -> do
+ printer (text "writeBinIface:" <+> int name_count
+ <+> text "Names")
+ printer (text "writeBinIface:" <+> int fs_count
+ <+> text "dict entries")
+
+-- | Write name/symbol tables
+--
+-- 1. setup the given BinHandle with Name/FastString table handling
+-- 2. write the following
+-- - FastString table pointer
+-- - Name table pointer
+-- - payload
+-- - Name table
+-- - FastString table
+--
+-- It returns (number of names, number of FastStrings, payload write result)
+--
+putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
+putWithTables bh put_payload = do
+ -- initialize state for the name table and the FastString table.
symtab_next <- newFastMutInt 0
symtab_map <- newIORef emptyUFM
- let bin_symtab = BinSymbolTable {
- bin_symtab_next = symtab_next,
- bin_symtab_map = symtab_map }
- dict_next_ref <- newFastMutInt 0
- dict_map_ref <- newIORef emptyUFM
- let bin_dict = BinDictionary {
- bin_dict_next = dict_next_ref,
- bin_dict_map = dict_map_ref }
-
- -- Put the main thing,
- bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
- (putName bin_dict bin_symtab)
- (putFastString bin_dict)
- put_ bh payload
-
- -- Write the symtab pointer at the front of the file
- symtab_p <- tellBin bh -- This is where the symtab will start
- putAt bh symtab_p_p symtab_p -- Fill in the placeholder
- seekBin bh symtab_p -- Seek back to the end of the file
-
- -- Write the symbol table itself
- symtab_next <- readFastMutInt symtab_next
- symtab_map <- readIORef symtab_map
- putSymbolTable bh symtab_next symtab_map
- case traceBinIface of
- QuietBinIFace -> return ()
- TraceBinIFace printer ->
- printer (text "writeBinIface:" <+> int symtab_next
- <+> text "Names")
-
- -- NB. write the dictionary after the symbol table, because
- -- writing the symbol table may create more dictionary entries.
-
- -- Write the dictionary pointer at the front of the file
- dict_p <- tellBin bh -- This is where the dictionary will start
- putAt bh dict_p_p dict_p -- Fill in the placeholder
- seekBin bh dict_p -- Seek back to the end of the file
-
- -- Write the dictionary itself
- dict_next <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh dict_next dict_map
- case traceBinIface of
- QuietBinIFace -> return ()
- TraceBinIFace printer ->
- printer (text "writeBinIface:" <+> int dict_next
- <+> text "dict entries")
+ let bin_symtab = BinSymbolTable
+ { bin_symtab_next = symtab_next
+ , bin_symtab_map = symtab_map
+ }
+
+ (bh_fs, bin_dict, put_dict) <- initBinDictionary bh
+
+ (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
+
+ -- NB. write the dictionary after the symbol table, because
+ -- writing the symbol table may create more dictionary entries.
+ let put_symtab = do
+ name_count <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putSymbolTable bh_fs name_count symtab_map
+ pure name_count
+
+ forwardPut bh_fs (const put_symtab) $ do
+
+ -- BinHandle with FastString and Name writing support
+ let ud_fs = getUserData bh_fs
+ let ud_name = ud_fs
+ { ud_put_nonbinding_name = putName bin_dict bin_symtab
+ , ud_put_binding_name = putName bin_dict bin_symtab
+ }
+ let bh_name = setUserData bh ud_name
+
+ put_payload bh_name
+
+ return (name_count, fs_count, r)
@@ -287,9 +278,9 @@ binaryInterfaceMagic platform
--
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
-putSymbolTable bh next_off symtab = do
- put_ bh next_off
- let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
+putSymbolTable bh name_count symtab = do
+ put_ bh name_count
+ let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
-- It's OK to use nonDetEltsUFM here because the elements have
-- indices that array uses to create order
mapM_ (\n -> serialiseName bh n symtab) names
@@ -392,30 +383,3 @@ data BinSymbolTable = BinSymbolTable {
-- indexed by Name
}
-putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
-putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
-
-allocateFastString :: BinDictionary -> FastString -> IO Word32
-allocateFastString BinDictionary { bin_dict_next = j_r,
- bin_dict_map = out_r} f = do
- out <- readIORef out_r
- let !uniq = getUnique f
- case lookupUFM_Directly out uniq of
- Just (j, _) -> return (fromIntegral j :: Word32)
- Nothing -> do
- j <- readFastMutInt j_r
- writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM_Directly out uniq (j, f)
- return (fromIntegral j :: Word32)
-
-getDictFastString :: Dictionary -> BinHandle -> IO FastString
-getDictFastString dict bh = do
- j <- get bh
- return $! (dict ! fromIntegral (j :: Word32))
-
-data BinDictionary = BinDictionary {
- bin_dict_next :: !FastMutInt, -- The next index to use
- bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
- -- indexed by FastString
- }
-
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -21,7 +21,6 @@ import GHC.Settings.Utils ( maybeRead )
import GHC.Settings.Config ( cProjectVersion )
import GHC.Prelude
import GHC.Utils.Binary
-import GHC.Iface.Binary ( getDictFastString )
import GHC.Data.FastMutInt
import GHC.Data.FastString ( FastString )
import GHC.Types.Name
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -63,10 +63,10 @@ renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
renderJs' r = jsToDocR r . jsSaturate Nothing
data RenderJs = RenderJs
- { renderJsS :: RenderJs -> JStat -> Doc
- , renderJsE :: RenderJs -> JExpr -> Doc
- , renderJsV :: RenderJs -> JVal -> Doc
- , renderJsI :: RenderJs -> Ident -> Doc
+ { renderJsS :: !(RenderJs -> JStat -> Doc)
+ , renderJsE :: !(RenderJs -> JExpr -> Doc)
+ , renderJsV :: !(RenderJs -> JVal -> Doc)
+ , renderJsI :: !(RenderJs -> Ident -> Doc)
}
defaultRenderJs :: RenderJs
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
-- | JavaScript code generator
module GHC.StgToJS.CodeGen
@@ -52,16 +53,13 @@ import GHC.Utils.Encoding
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Utils.Binary
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Utils.Outputable hiding ((<>))
import qualified Data.Set as S
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
import Data.Monoid
import Control.Monad
-import Control.Monad.Trans.Class
-import Data.Bifunctor
-- | Code generator for JavaScript
stgToJS
@@ -82,26 +80,21 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
-- TODO: add dump pass for optimized STG ast for JS
- obj <- runG config this_mod unfloated_binds $ do
- ifProfilingM $ initCostCentres cccs
- (sym_table, lus) <- genUnits this_mod stg_binds spt_entries foreign_stubs
-
- -- (exported symbol names, javascript statements) for each linkable unit
- p <- forM lus \u -> do
- ts <- mapM (fmap (\(TxtI i) -> i) . identForId) (luIdExports u)
- return (ts ++ luOtherExports u, luStat u)
-
- deps <- genDependencyData this_mod lus
- lift $ Object.writeObject' (moduleName this_mod) sym_table deps (map (second BL.fromStrict) p)
+ (deps,lus) <- runG config this_mod unfloated_binds $ do
+ ifProfilingM $ initCostCentres cccs
+ lus <- genUnits this_mod stg_binds spt_entries foreign_stubs
+ deps <- genDependencyData this_mod lus
+ pure (deps,lus)
-- Doc to dump when -ddump-js is enabled
- let mod_name = renderWithContext defaultSDocContext (ppr this_mod)
when (logHasDumpFlag logger Opt_D_dump_js) $ do
- o <- Object.readObject mod_name obj
putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
- $ vcat (fmap (docToSDoc . jsToDoc . Object.oiStat) o)
+ $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus)
- BL.writeFile output_fn obj
+ -- Write the object file
+ bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
+ Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus)
+ writeBinMem bh output_fn
@@ -111,53 +104,59 @@ genUnits :: HasDebugCallStack
-> [CgStgTopBinding]
-> [SptEntry]
-> ForeignStubs
- -> G (Object.SymbolTable, [LinkableUnit]) -- ^ the final symbol table and the linkable units
-genUnits m ss spt_entries foreign_stubs
- = generateGlobalBlock =<<
- generateExportsBlock =<<
- go 2 Object.emptySymbolTable ss
+ -> G [LinkableUnit] -- ^ the linkable units
+genUnits m ss spt_entries foreign_stubs = do
+ gbl <- generateGlobalBlock
+ exports <- generateExportsBlock
+ others <- go 2 ss
+ pure (gbl:exports:others)
where
go :: HasDebugCallStack
=> Int -- the block we're generating (block 0 is the global unit for the module)
- -> Object.SymbolTable -- the shared symbol table
-> [CgStgTopBinding]
- -> G (Object.SymbolTable, [LinkableUnit])
- go !n st (x:xs) = do
- (st', mlu) <- generateBlock st x n
- (st'', lus) <- go (n+1) st' xs
- return (st'', maybe lus (:lus) mlu)
- go _ st [] = return (st, [])
+ -> G [LinkableUnit]
+ go !n = \case
+ [] -> pure []
+ (x:xs) -> do
+ mlu <- generateBlock x n
+ lus <- go (n+1) xs
+ return (maybe lus (:lus) mlu)
-- Generate the global unit that all other blocks in the module depend on
-- used for cost centres and static initializers
-- the global unit has no dependencies, exports the moduleGlobalSymbol
- generateGlobalBlock :: HasDebugCallStack
- => (Object.SymbolTable, [LinkableUnit])
- -> G (Object.SymbolTable, [LinkableUnit])
- generateGlobalBlock (st, lus) = do
+ generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
+ generateGlobalBlock = do
glbl <- State.gets gsGlobal
staticInit <-
initStaticPtrs spt_entries
- (st', _, bs) <- serializeLinkableUnit m st [] [] []
- ( -- O.optimize .
- jsSaturate (Just $ modulePrefix m 1)
- $ mconcat (reverse glbl) <> staticInit) "" [] []
- return ( st'
- , LinkableUnit bs
- []
- [moduleGlobalSymbol m]
- []
- []
- []
- False
- []
- : lus
- )
-
- generateExportsBlock :: HasDebugCallStack
- => (Object.SymbolTable, [LinkableUnit])
- -> G (Object.SymbolTable, [LinkableUnit])
- generateExportsBlock (st, lus) = do
+ let stat = ( -- O.optimize .
+ jsSaturate (Just $ modulePrefix m 1)
+ $ mconcat (reverse glbl) <> staticInit)
+ let syms = [moduleGlobalSymbol m]
+ let oi = ObjUnit
+ { oiSymbols = syms
+ , oiClInfo = []
+ , oiStatic = []
+ , oiStat = stat
+ , oiRaw = mempty
+ , oiFExports = []
+ , oiFImports = []
+ }
+ let lu = LinkableUnit
+ { luObjUnit = oi
+ , luIdExports = []
+ , luOtherExports = syms
+ , luIdDeps = []
+ , luPseudoIdDeps = []
+ , luOtherDeps = []
+ , luRequired = False
+ , luForeignRefs = []
+ }
+ pure lu
+
+ generateExportsBlock :: HasDebugCallStack => G LinkableUnit
+ generateExportsBlock = do
let (f_hdr, f_c) = case foreign_stubs of
NoStubs -> (empty, empty)
ForeignStubs hdr c -> (getCHeader hdr, getCStub c)
@@ -165,87 +164,107 @@ genUnits m ss spt_entries foreign_stubs
mkUniqueDep (tag:xs) = mkUnique tag (read xs)
mkUniqueDep [] = panic "mkUniqueDep"
- (st', _, bs) <- serializeLinkableUnit m
- st
- []
- []
- []
- mempty
- (mkFastString $ renderWithContext defaultSDocContext f_c)
- []
- []
- return ( st'
- , LinkableUnit bs
- []
- [moduleExportsSymbol m]
- [] -- id deps
- unique_deps -- pseudo id deps
- []
- True
- []
- : lus
- )
+ let syms = [moduleExportsSymbol m]
+ let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c
+ let oi = ObjUnit
+ { oiSymbols = syms
+ , oiClInfo = []
+ , oiStatic = []
+ , oiStat = mempty
+ , oiRaw = raw
+ , oiFExports = []
+ , oiFImports = []
+ }
+ let lu = LinkableUnit
+ { luObjUnit = oi
+ , luIdExports = []
+ , luOtherExports = syms
+ , luIdDeps = []
+ , luPseudoIdDeps = unique_deps
+ , luOtherDeps = []
+ , luRequired = True
+ , luForeignRefs = []
+ }
+ pure lu
-- Generate the linkable unit for one binding or group of
-- mutually recursive bindings
generateBlock :: HasDebugCallStack
- => Object.SymbolTable
- -> CgStgTopBinding
+ => CgStgTopBinding
-> Int
- -> G (Object.SymbolTable, Maybe LinkableUnit)
- generateBlock st (StgTopStringLit bnd str) n = do
- bids <- identsForId bnd
- case bids of
- [(TxtI b1t),(TxtI b2t)] -> do
- -- [e1,e2] <- genLit (MachStr str)
- emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing
- emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
- _extraTl <- State.gets (ggsToplevelStats . gsGroup)
- si <- State.gets (ggsStatic . gsGroup)
- let stat = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
- (st', _ss, bs) <- serializeLinkableUnit m st [bnd] [] si
- (jsSaturate (Just $ modulePrefix m n) stat) "" [] []
- pure (st', Just $ LinkableUnit bs [bnd] [] [] [] [] False [])
- _ -> panic "generateBlock: invalid size"
- generateBlock st (StgTopLifted decl) n = do
- tl <- genToplevel decl
- extraTl <- State.gets (ggsToplevelStats . gsGroup)
- ci <- State.gets (ggsClosureInfo . gsGroup)
- si <- State.gets (ggsStatic . gsGroup)
- unf <- State.gets gsUnfloated
- extraDeps <- State.gets (ggsExtraDeps . gsGroup)
- fRefs <- State.gets (ggsForeignRefs . gsGroup)
- resetGroup
- let allDeps = collectIds unf decl
- topDeps = collectTopIds decl
- required = hasExport decl
- stat = -- Opt.optimize .
- jsSaturate (Just $ modulePrefix m n)
- $ mconcat (reverse extraTl) <> tl
- (st', _ss, bs) <- serializeLinkableUnit m st topDeps ci si stat mempty [] fRefs
- return $! seqList topDeps `seq` seqList allDeps `seq` st' `seq`
- (st', Just $ LinkableUnit bs topDeps [] allDeps [] (S.toList extraDeps) required fRefs)
-
--- | serialize the payload of a linkable unit in the object file, adding strings
--- to the SymbolTable where necessary
-serializeLinkableUnit :: HasDebugCallStack
- => Module
- -> Object.SymbolTable -- symbol table to start with
- -> [Id] -- id's exported by unit
- -> [ClosureInfo]
- -> [StaticInfo]
- -> JStat -- generated code for the unit
- -> FastString
- -> [Object.ExpFun]
- -> [ForeignJSRef]
- -> G (Object.SymbolTable, [FastString], BS.ByteString)
-serializeLinkableUnit _m st i ci si stat rawStat fe fi = do
- !i' <- mapM idStr i
- !(!st', !lo) <- lift $ Object.runPutS st $ \bh -> Object.putLinkableUnit bh ci si stat rawStat fe fi
- let !o = BL.toStrict lo
- return (st', i', o) -- deepseq results?
- where
- idStr i = itxt <$> identForId i
+ -> G (Maybe LinkableUnit)
+ generateBlock top_bind n = case top_bind of
+ StgTopStringLit bnd str -> do
+ bids <- identsForId bnd
+ case bids of
+ [(TxtI b1t),(TxtI b2t)] -> do
+ -- [e1,e2] <- genLit (MachStr str)
+ emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing
+ emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
+ _extraTl <- State.gets (ggsToplevelStats . gsGroup)
+ si <- State.gets (ggsStatic . gsGroup)
+ let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
+ let stat = jsSaturate (Just $ modulePrefix m n) body
+ let ids = [bnd]
+ syms <- (\(TxtI i) -> [i]) <$> identForId bnd
+ let oi = ObjUnit
+ { oiSymbols = syms
+ , oiClInfo = []
+ , oiStatic = si
+ , oiStat = stat
+ , oiRaw = ""
+ , oiFExports = []
+ , oiFImports = []
+ }
+ let lu = LinkableUnit
+ { luObjUnit = oi
+ , luIdExports = ids
+ , luOtherExports = []
+ , luIdDeps = []
+ , luPseudoIdDeps = []
+ , luOtherDeps = []
+ , luRequired = False
+ , luForeignRefs = []
+ }
+ pure (Just lu)
+ _ -> panic "generateBlock: invalid size"
+
+ StgTopLifted decl -> do
+ tl <- genToplevel decl
+ extraTl <- State.gets (ggsToplevelStats . gsGroup)
+ ci <- State.gets (ggsClosureInfo . gsGroup)
+ si <- State.gets (ggsStatic . gsGroup)
+ unf <- State.gets gsUnfloated
+ extraDeps <- State.gets (ggsExtraDeps . gsGroup)
+ fRefs <- State.gets (ggsForeignRefs . gsGroup)
+ resetGroup
+ let allDeps = collectIds unf decl
+ topDeps = collectTopIds decl
+ required = hasExport decl
+ stat = -- Opt.optimize .
+ jsSaturate (Just $ modulePrefix m n)
+ $ mconcat (reverse extraTl) <> tl
+ syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps
+ let oi = ObjUnit
+ { oiSymbols = syms
+ , oiClInfo = ci
+ , oiStatic = si
+ , oiStat = stat
+ , oiRaw = ""
+ , oiFExports = []
+ , oiFImports = fRefs
+ }
+ let lu = LinkableUnit
+ { luObjUnit = oi
+ , luIdExports = topDeps
+ , luOtherExports = []
+ , luIdDeps = allDeps
+ , luPseudoIdDeps = []
+ , luOtherDeps = S.toList extraDeps
+ , luRequired = required
+ , luForeignRefs = fRefs
+ }
+ pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu
-- | variable prefix for the nth block in module
modulePrefix :: Module -> Int -> FastString
=====================================
compiler/GHC/StgToJS/Linker/Archive.hs
=====================================
@@ -1,6 +1,5 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
@@ -17,174 +16,133 @@
-----------------------------------------------------------------------------
module GHC.StgToJS.Linker.Archive
( Entry(..), Index, IndexEntry(..), Meta(..)
- , buildArchive
+ , writeArchive
, readMeta, readIndex
- , readSource, readAllSources
- , readObject, withObject, withAllObjects
+ , getArchiveEntries
+ , getArchiveEntry
) where
-import Control.Monad
-
-import Data.Binary
-import Data.Binary.Get
-import Data.Binary.Put
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy as B
-import Data.Data
-import Data.Int
-import GHC.Data.ShortText (ShortText)
-import qualified GHC.Data.ShortText as T
-
-import GHC.Generics hiding (Meta)
-
-import System.IO
import Prelude
+import Data.ByteString (ByteString)
+import Data.Word
+import Control.Monad
-import GHC.Unit.Module
-
-import GHC.StgToJS.Object ( versionTag, versionTagLength )
+import GHC.Unit.Module
+import GHC.Utils.Binary
+import GHC.Utils.Panic
+import GHC.Utils.Monad
+import GHC.Settings.Constants (hiVersion)
--- entry, offset in data section, length
type Index = [IndexEntry]
-data IndexEntry = IndexEntry { ieEntry :: Entry
- , ieOffset :: Int64
- , ieLength :: Int64
- } deriving (Show, Typeable, Generic)
-
-instance Binary IndexEntry
-
-data Entry = Object ShortText -- module name
- | JsSource FilePath
- deriving (Show, Typeable, Generic)
-
-instance Binary Entry
-
-data Meta = Meta { metaCppOptions :: [String]
- } deriving (Show, Typeable, Generic)
-
-instance Binary Meta
-
--- sizes of the sections in bytes
-data Sections = Sections { sectionIndex :: !Word64
- , sectionMeta :: !Word64
- , sectionData :: !Word64
- } deriving (Eq, Ord, Generic)
-
-instance Binary Sections where
- put (Sections i m d) = putWord64le i >> putWord64le m >> putWord64le d
- get = Sections <$> getWord64le <*> getWord64le <*> getWord64le
-
-sectionsLength :: Int
-sectionsLength = 24
-
-buildArchive :: Meta -> [(Entry, ByteString)] -> ByteString
-buildArchive meta entries =
- versionTag <> sections <> index <> meta' <> entries'
- where
- bl = fromIntegral . B.length
- sections = runPut . put $ Sections (bl index) (bl meta') (bl entries')
- meta' = runPut (put meta)
- index = runPut . put $ scanl1 (\(IndexEntry _ o l) (IndexEntry e _ l') -> IndexEntry e (o+l) l') $
- map (\(e,b) -> IndexEntry e 0 (B.length b)) entries
- entries' = mconcat (map snd entries)
+data IndexEntry = IndexEntry
+ { ieEntry :: !Entry -- ^ Entry identifier
+ , ieOffset :: !(Bin ByteString) -- ^ Offset in the archive
+ } deriving (Show)
+
+instance Binary IndexEntry where
+ put_ bh (IndexEntry a b) = do
+ put_ bh a
+ put_ bh b
+ get bh = IndexEntry <$> get bh <*> get bh
+
+data Entry
+ = Object !ModuleName
+ | JsSource !FilePath
+ deriving (Show)
+
+instance Binary Entry where
+ put_ bh = \case
+ Object m -> putByte bh 0 >> put_ bh m
+ JsSource p -> putByte bh 1 >> put_ bh p
+ get bh = getByte bh >>= \case
+ 0 -> Object <$> get bh
+ _ -> JsSource <$> get bh
+
+
+data Meta = Meta
+ { metaCppOptions :: [String]
+ }
+
+instance Binary Meta where
+ put_ bh (Meta a) = put_ bh a
+ get bh = Meta <$> get bh
+
+magic :: FixedLengthEncoding Word64
+magic = FixedLengthEncoding 0x435241534a434847 -- "GHCJSARC"
+
+writeArchive :: FilePath -> Meta -> [(Entry, ByteString)] -> IO ()
+writeArchive path meta entries = do
+ bh <- openBinMem (4*1024*1000)
+ put_ bh magic
+ put_ bh (show hiVersion)
+
+ put_ bh meta
+
+ -- forward put the index
+ forwardPut_ bh (put_ bh) $ do
+ idx <- forM entries $ \(e,bs) -> do
+ p <- tellBin bh
+ put_ bh bs
+ pure $ IndexEntry
+ { ieEntry = e
+ , ieOffset = p
+ }
+ pure idx
+
+ writeBinMem bh path
+
+data Header = Header
+ { hdrMeta :: !Meta
+ , hdrIndex :: !Index
+ , hdrHandle :: !BinHandle
+ }
+
+getArchiveHeader :: BinHandle -> IO Header
+getArchiveHeader bh = do
+ is_magic <- (== magic) <$> get bh
+ unless is_magic $ panic "getArchiveHeader: invalid magic header"
+
+ is_correct_version <- ((== hiVersion) . read) <$> get bh
+ unless is_correct_version $ panic "getArchiveHeader: invalid header version"
+
+ meta <- get bh
+ idx <- forwardGet bh (get bh)
+ pure $ Header
+ { hdrMeta = meta
+ , hdrIndex = idx
+ , hdrHandle = bh
+ }
readMeta :: FilePath -> IO Meta
-readMeta file = withBinaryFile file ReadMode $ \h -> do
- sections <- hReadHeader ("readMeta " ++ file) h
- hSeek h RelativeSeek (toInteger $ sectionIndex sections)
- m <- B.hGet h (fromIntegral $ sectionMeta sections)
- return $! runGet get m
+readMeta file = do
+ bh <- readBinMem file
+ hdr <- getArchiveHeader bh
+ pure $! hdrMeta hdr
readIndex :: FilePath -> IO Index
-readIndex file =
- withArchive "readIndex" file $ \_sections index _h -> return index
-
-readSource :: FilePath -> FilePath -> IO ByteString
-readSource source file = withArchive "readSource" file $
- withEntry ("readSource " ++ file)
- ("source file " ++ source)
- selectSrc
- (\h l -> B.hGet h $ fromIntegral l)
+readIndex file = do
+ bh <- readBinMem file
+ hdr <- getArchiveHeader bh
+ pure $! hdrIndex hdr
+
+getArchiveEntries :: Header -> (Entry -> Bool) -> IO [ByteString]
+getArchiveEntries hdr pred = mapMaybeM read_entry (hdrIndex hdr)
where
- selectSrc (JsSource src) = src == source
- selectSrc _ = False
-
-readAllSources :: FilePath -> IO [(FilePath, ByteString)]
-readAllSources file = withArchive "readAllSources" file $ \sections index h ->
- forM [ (o, l, src) | IndexEntry (JsSource src) o l <- index ] $ \(o, l, src) -> do
- hSeek h AbsoluteSeek (fromIntegral $ dataSectionStart sections + fromIntegral o)
- (src,) <$> B.hGet h (fromIntegral l)
-
-readObject :: ModuleName -> FilePath -> IO ByteString
-readObject m file = withArchive "readObject" file $
- withModuleObject ("readObject " ++ file) m (\h l -> B.hGet h $ fromIntegral l)
-
--- | seeks to the starting position of the object in the file
-withObject :: ModuleName -> FilePath -> (Handle -> Int64 -> IO a) -> IO a
-withObject m file f = withArchive "withObject" file $
- withModuleObject ("withObject " ++ file) m f
-
-
-withAllObjects :: FilePath -> (ModuleName -> Handle -> Int64 -> IO a) -> IO [a]
-withAllObjects file f = withArchive "withAllObjects" file $ \sections index h ->
- forM [ (o, l, mn) | IndexEntry (Object mn) o l <- index ] $ \(o, l, mn) -> do
- hSeek h AbsoluteSeek (fromIntegral $ dataSectionStart sections + fromIntegral o)
- f (mkModuleName (T.unpack mn)) h l
-
----------------------------------------------------------------------------------
-
-withArchive :: String -> FilePath -> (Sections -> Index -> Handle -> IO a) -> IO a
-withArchive name file f = withBinaryFile file ReadMode $ \h -> do
- let name' = name ++ " " ++ file
- putStrLn ("reading archive: " ++ name ++ " -> " ++ file)
- sections <- hReadHeader name' h
- index <- hReadIndex name' sections h
- f sections index h
-
--- | seeks to start of entry data in file, then runs the action
--- exactly one matching entry is expected
-withEntry :: String -> String
- -> (Entry -> Bool) -> (Handle -> Int64 -> IO a)
- -> Sections -> Index -> Handle
- -> IO a
-withEntry name entryName p f sections index h =
- case filter (p . ieEntry) index of
- [] -> error (name ++ ": cannot find " ++ entryName)
- [IndexEntry _ o l] -> do
- hSeek h AbsoluteSeek (dataSectionStart sections + toInteger o)
- f h (fromIntegral l)
- _ -> error (name ++ ": multiple matches for " ++ entryName)
-
-withModuleObject :: String -> ModuleName -> (Handle -> Int64 -> IO a)
- -> Sections -> Index -> Handle
- -> IO a
-withModuleObject name m f =
- withEntry name ("object for module " ++ ms) selectEntry f
+ bh = hdrHandle hdr
+ read_entry (IndexEntry e offset)
+ | pred e = do
+ seekBin bh offset
+ Just <$> get bh
+ | otherwise = pure Nothing
+
+getArchiveEntry :: Header -> (Entry -> Bool) -> IO (Maybe ByteString)
+getArchiveEntry hdr pred = go (hdrIndex hdr)
where
- ms = moduleNameString m
- mt = T.pack ms
- selectEntry (Object m') = mt == m'
- selectEntry _ = False
-
--- | expects Handle to be positioned at the start of the header
--- Handle is positioned at start of index after return
-hReadHeader :: String -> Handle -> IO Sections
-hReadHeader name h = do
- ts <- B.hGet h (versionTagLength + sectionsLength)
- when (B.take (fromIntegral versionTagLength) ts /= versionTag)
- (error $ name ++ ": version tag mismatch")
- return $! runGet get (B.drop (fromIntegral versionTagLength) ts)
-
--- | expects Handle to be positioned at the start of the index
--- Handle is positioned at start of metadata section after return
-hReadIndex :: String -> Sections -> Handle -> IO Index
-hReadIndex _name s h = do
- i <- B.hGet h (fromIntegral $ sectionIndex s)
- return $! runGet get i
-
--- start of data section in file
-dataSectionStart :: Sections -> Integer
-dataSectionStart s = toInteger (versionTagLength + sectionsLength)
- + toInteger (sectionIndex s + sectionMeta s)
+ bh = hdrHandle hdr
+ go = \case
+ (IndexEntry e offset:es)
+ | pred e -> seekBin bh offset >> (Just <$> get bh)
+ | otherwise -> go es
+ [] -> pure Nothing
=====================================
compiler/GHC/StgToJS/Linker/Dynamic.hs
=====================================
@@ -21,8 +21,12 @@
module GHC.StgToJS.Linker.Dynamic
( jsLinkBinary
, jsLinkLib
- ) where
+ )
+where
+import GHC.Driver.Session
+
+import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Archive
import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Utils
@@ -32,7 +36,6 @@ import GHC.Linker.Types
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
-import GHC.Driver.Session
import GHC.Types.Unique.DFM
import GHC.Types.Basic
@@ -44,15 +47,12 @@ import Prelude
import Control.Monad
-import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import Data.List ( nub )
-import qualified GHC.Data.ShortText as T
import System.FilePath
import GHC.Platform.Ways
import GHC.Utils.Logger
-import GHC.StgToJS.Types
import GHC.Utils.TmpFs (TmpFs)
---------------------------------------------------------------------------------
@@ -77,13 +77,13 @@ jsLinkLib settings jsFiles dflags _logger hpt
jsFiles' = nub (lcJsLibSrcs settings ++ jsFiles)
meta = Meta (opt_P dflags)
jsEntries <- forM jsFiles' $ \file ->
- (JsSource file,) . B.fromStrict <$> BS.readFile file
+ (JsSource file,) <$> BS.readFile file
objEntries <- forM (eltsUDFM hpt) $ \hmi -> do
- let mt = T.pack . moduleNameString . moduleName . mi_module . hm_iface $ hmi
+ let mod_name = moduleName . mi_module . hm_iface $ hmi
files = maybe [] (\l -> [ o | DotO o <- linkableUnlinked l]) (hm_linkable hmi)
-- fixme archive does not handle multiple files for a module yet
- forM files (fmap ((Object mt,) . B.fromStrict) . BS.readFile)
- B.writeFile outputFile (buildArchive meta (concat objEntries ++ jsEntries))
+ forM files (fmap ((Object mod_name,)) . BS.readFile)
+ writeArchive outputFile meta (concat objEntries ++ jsEntries)
-- we don't use shared js_so libraries ourselves, but Cabal expects that we
-- generate one when building with --dynamic-too. Just write an empty file
when (gopt Opt_BuildDynamicToo dflags || WayDyn `elem` ways dflags) $ do
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -66,7 +66,7 @@ import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.IORef
import Data.List ( partition, nub, foldl', intercalate, group, sort
- , groupBy, isSuffixOf, find, intersperse
+ , groupBy, intersperse
)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
@@ -77,15 +77,13 @@ import Data.Word
import GHC.Generics (Generic)
-import System.FilePath (splitPath, (<.>), (</>), dropExtension, isExtensionOf)
-import System.Environment (lookupEnv)
+import System.FilePath (splitPath, (<.>), (</>), dropExtension)
import System.Directory ( createDirectoryIfMissing
, doesFileExist
, getCurrentDirectory
, Permissions(..)
, setPermissions
, getPermissions
- , listDirectory
)
import GHC.Driver.Session (targetWays_, DynFlags(..))
@@ -93,6 +91,8 @@ import Language.Haskell.Syntax.Module.Name
import GHC.Unit.Module (moduleStableString)
import GHC.Utils.Logger (Logger, logVerbAtLeast)
import GHC.Utils.TmpFs (TmpFs)
+import GHC.Utils.Binary
+import GHC.Utils.Ppr (Style(..), renderStyle, Mode(..))
import GHC.Linker.Static.Utils (exeFileName)
@@ -102,14 +102,14 @@ newtype LinkerStats = LinkerStats
-- | result of a link pass
data LinkResult = LinkResult
- { linkOut :: B.ByteString -- ^ compiled Haskell code
- , linkOutStats :: LinkerStats -- ^ statistics about generated code
- , linkOutMetaSize :: Int64 -- ^ size of packed metadata in generated code
- , linkForeignRefs :: [ForeignJSRef] -- ^ foreign code references in compiled haskell code
- , linkLibRTS :: [FilePath] -- ^ library code to load with the RTS
- , linkLibA :: [FilePath] -- ^ library code to load after RTS
- , linkLibAArch :: [FilePath] -- ^ library code to load from archives after RTS
- , linkBase :: Base -- ^ base metadata to use if we want to link incrementally against this result
+ { linkOut :: FilePath -> IO () -- ^ compiled Haskell code
+ , linkOutStats :: LinkerStats -- ^ statistics about generated code
+ , linkOutMetaSize :: Int64 -- ^ size of packed metadata in generated code
+ , linkForeignRefs :: [ForeignJSRef] -- ^ foreign code references in compiled haskell code
+ , linkLibRTS :: [FilePath] -- ^ library code to load with the RTS
+ , linkLibA :: [FilePath] -- ^ library code to load after RTS
+ , linkLibAArch :: [FilePath] -- ^ library code to load from archives after RTS
+ , linkBase :: Base -- ^ base metadata to use if we want to link incrementally against this result
} deriving (Generic)
newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.Archive) }
@@ -143,7 +143,7 @@ link env lc_cfg cfg logger tmpfs dflags unit_env out include pkgs objFiles jsFil
jsExt | genBase = "base.js"
| otherwise = "js"
createDirectoryIfMissing False out
- B.writeFile (out </> "out" <.> jsExt) (linkOut link_res)
+ linkOut link_res (out </> "out" <.> jsExt)
-- dump foreign references file (.frefs)
unless (lcOnlyOut lc_cfg) $ do
@@ -167,12 +167,13 @@ link env lc_cfg cfg logger tmpfs dflags unit_env out include pkgs objFiles jsFil
let all_lib_js = linkLibA link_res
lla' <- streamShims <$> readShimFiles logger tmpfs dflags unit_env all_lib_js
- llarch' <- mapM (readShimsArchive dflags) (linkLibAArch link_res)
+ llarch' <- mapM readShimsArchive (linkLibAArch link_res)
let lib_js = BL.fromChunks $! llarch' ++ lla'
BL.writeFile (out </> "lib" <.> jsExt) lib_js
if genBase
- then generateBase out (linkBase link_res)
+ then panic "support for base bundle not implemented"
+ -- generateBase out (linkBase link_res)
else when ( not (lcOnlyOut lc_cfg)
&& not (lcNoRts lc_cfg)
&& not (usingBase lc_cfg)
@@ -184,8 +185,8 @@ link env lc_cfg cfg logger tmpfs dflags unit_env out include pkgs objFiles jsFil
writeRunner lc_cfg out
writeExterns out
-readShimsArchive :: DynFlags -> FilePath -> IO B.ByteString
-readShimsArchive dflags ar_file = do
+readShimsArchive :: FilePath -> IO B.ByteString
+readShimsArchive ar_file = do
(Ar.Archive entries) <- Ar.loadAr ar_file
jsdata <- catMaybes <$> mapM readEntry entries
return (B.intercalate "\n" jsdata)
@@ -231,7 +232,7 @@ link' env lc_cfg cfg dflags logger unit_env target _include pkgs objFiles _jsFil
base <- case lcUseBase lc_cfg of
NoBase -> return emptyBase
- BaseFile file -> loadBase file
+ BaseFile _file -> panic "support for base bundle not implemented" -- loadBase file
BaseState b -> return b
let (rdPkgs, rds) = rtsDeps pkgs
@@ -269,9 +270,8 @@ link' env lc_cfg cfg dflags logger unit_env target _include pkgs objFiles _jsFil
-- retrieve code for dependencies
code <- collectDeps dep_map dep_units all_deps
- let (outJs, metaSize, compactorState, stats) =
- renderLinker lc_cfg cfg (baseCompactorState base) rds code
- base' = Base compactorState (nub $ basePkgs base ++ pkgs'')
+ (outJs, metaSize, compactorState, stats) <- renderLinker lc_cfg cfg (baseCompactorState base) rds code
+ let base' = Base compactorState (nub $ basePkgs base ++ pkgs'')
(all_deps `S.union` baseUnits base)
return $ LinkResult
@@ -299,7 +299,7 @@ link' env lc_cfg cfg dflags logger unit_env target _include pkgs objFiles _jsFil
data ModuleCode = ModuleCode
{ mc_module :: !Module
, mc_js_code :: !JStat
- , mc_exports :: !FastString -- ^ rendered exports
+ , mc_exports :: !B.ByteString -- ^ rendered exports
, mc_closures :: ![ClosureInfo]
, mc_statics :: ![StaticInfo]
, mc_frefs :: ![ForeignJSRef]
@@ -311,36 +311,50 @@ renderLinker
-> CompactorState
-> Set ExportedFun
-> [ModuleCode] -- ^ linked code per module
- -> (B.ByteString, Int64, CompactorState, LinkerStats)
-renderLinker settings cfg renamer_state rtsDeps code =
- ( rendered_all
- , meta_length
- , renamer_state'
- , stats
- )
- where
- -- extract ModuleCode fields required to make a LinkedUnit
- code_to_linked_unit c = LinkedUnit
- { lu_js_code = mc_js_code c
- , lu_closures = mc_closures c
- , lu_statics = mc_statics c
- }
- -- call the compactor
- (renamer_state', compacted, meta) = compact settings cfg renamer_state
- (map ((\(LexicalFastString f) -> f) . funSymbol) $ S.toList rtsDeps)
- (map code_to_linked_unit code)
+ -> IO (FilePath -> IO (), Int64, CompactorState, LinkerStats)
+renderLinker settings cfg renamer_state rtsDeps code = do
+
+ -- extract ModuleCode fields required to make a LinkedUnit
+ let code_to_linked_unit c = LinkedUnit
+ { lu_js_code = mc_js_code c
+ , lu_closures = mc_closures c
+ , lu_statics = mc_statics c
+ }
+
+ -- call the compactor
+ let (renamer_state', compacted, meta) = compact settings cfg renamer_state
+ (map ((\(LexicalFastString f) -> f) . funSymbol) $ S.toList rtsDeps)
+ (map code_to_linked_unit code)
+ let
+ render_all fp = do
+ BL.writeFile fp rendered_all
+
-- render result into JS code
rendered_all = mconcat [mconcat rendered_mods, rendered_meta, rendered_exports]
rendered_mods = fmap render_js compacted
rendered_meta = render_js meta
- render_js = BC.pack . (<>"\n") . show . pretty
- rendered_exports = BC.concat . map bytesFS . filter (not . nullFS) $ map mc_exports code
- meta_length = fromIntegral (BC.length rendered_meta)
+ doc_str = renderStyle (Style
+ { lineLength = 100
+ , ribbonsPerLine = 1.5
+ , mode = LeftMode
+ -- Faster to write but uglier code.
+ -- Use "PageMode False" to enable nicer code instead
+ })
+ render_js x = BL.fromChunks [BC.pack (doc_str (pretty x)), BC.pack "\n"]
+ rendered_exports = BL.fromChunks (map mc_exports code)
+ meta_length = fromIntegral (BL.length rendered_meta)
-- make LinkerStats entry for the given ModuleCode.
-- For now, only associate generated code size in bytes to each module
- mk_stat c b = (mc_module c, fromIntegral . BC.length $ b)
+ mk_stat c b = (mc_module c, fromIntegral . BL.length $ b)
stats = LinkerStats $ M.fromList $ zipWith mk_stat code rendered_mods
+ pure
+ ( render_all
+ , meta_length
+ , renamer_state'
+ , stats
+ )
+
-- | Render linker stats
linkerStats :: Int64 -- ^ code size of packed metadata
-> LinkerStats -- ^ code size per module
@@ -567,30 +581,33 @@ extractDeps :: ArchiveState
extractDeps ar_state units deps loc =
case M.lookup mod units of
Nothing -> return Nothing
- Just modUnits -> do
- let selector n _ = n `IS.member` modUnits || isGlobalUnit n
- x <- case loc of
- ObjectFile o -> collectCode =<< readObjectFileKeys selector o
- ArchiveFile a -> (collectCode
- <=< readObjectKeys (a ++ ':':moduleNameString (moduleName mod)) selector)
- =<< readArObject ar_state mod a
- InMemory n b -> collectCode =<< readObjectKeys n selector b
- return x
+ Just mod_units -> Just <$> do
+ let selector n _ = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n)
+ case loc of
+ ObjectFile fp -> do
+ us <- readObjectUnits fp selector
+ pure (collectCode us)
+ ArchiveFile a -> do
+ obj <- readArObject ar_state mod a
+ us <- getObjectUnits obj selector
+ pure (collectCode us)
+ InMemory _n obj -> do
+ us <- getObjectUnits obj selector
+ pure (collectCode us)
where
mod = depsModule deps
- newline = mkFastString "\n"
+ newline = BC.pack "\n"
unlines' = intersperse newline . map oiRaw
- collectCode l = let x = ModuleCode
- { mc_module = mod
- , mc_js_code = mconcat (map oiStat l)
- , mc_exports = mconcat (unlines' l)
- , mc_closures = concatMap oiClInfo l
- , mc_statics = concatMap oiStatic l
- , mc_frefs = concatMap oiFImports l
- }
- in return (Just x)
-
-readArObject :: ArchiveState -> Module -> FilePath -> IO BL.ByteString
+ collectCode l = ModuleCode
+ { mc_module = mod
+ , mc_js_code = mconcat (map oiStat l)
+ , mc_exports = mconcat (unlines' l)
+ , mc_closures = concatMap oiClInfo l
+ , mc_statics = concatMap oiStatic l
+ , mc_frefs = concatMap oiFImports l
+ }
+
+readArObject :: ArchiveState -> Module -> FilePath -> IO Object
readArObject ar_state mod ar_file = do
loaded_ars <- readIORef (loadedArchives ar_state)
(Ar.Archive entries) <- case M.lookup ar_file loaded_ars of
@@ -599,19 +616,27 @@ readArObject ar_state mod ar_file = do
a <- Ar.loadAr ar_file
modifyIORef (loadedArchives ar_state) (M.insert ar_file a)
pure a
- let tag = moduleNameTag $ moduleName mod
- matchTag entry
- | Right hdr <- getHeader (BL.fromStrict $ Ar.filedata entry)
- = hdrModuleName hdr == tag
- | otherwise
- = False
-
- -- XXX this shouldn't be an exception probably
- pure $! maybe (error $ "could not find object for module "
- ++ moduleNameString (moduleName mod)
- ++ " in "
- ++ ar_file)
- (BL.fromStrict . Ar.filedata) (find matchTag entries)
+
+ -- look for the right object in archive
+ let go_entries = \case
+ -- XXX this shouldn't be an exception probably
+ [] -> panic $ "could not find object for module "
+ ++ moduleNameString (moduleName mod)
+ ++ " in "
+ ++ ar_file
+
+ (e:es) -> do
+ let bs = Ar.filedata e
+ bh <- unsafeUnpackBinBuffer bs
+ getObjectHeader bh >>= \case
+ Left _ -> go_entries es -- not a valid object entry
+ Right mod_name
+ | mod_name /= moduleName mod
+ -> go_entries es -- not the module we're looking for
+ | otherwise
+ -> getObjectBody bh mod_name -- found it
+
+ go_entries entries
{- | Static dependencies are symbols that need to be linked regardless
of whether the linked program refers to them. For example
@@ -824,15 +849,15 @@ loadArchiveDeps' archives = do
return (prepareLoadedDeps $ concat archDeps)
where
readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation))
- readEntry ar_file ar_entry
- | isObjFile ar_entry =
- fmap (,ArchiveFile ar_file) <$>
- (readDepsMaybe (ar_file ++ ':':Ar.filename ar_entry) (BL.fromStrict $ Ar.filedata ar_entry))
- | otherwise = return Nothing
-
-
-isObjFile :: Ar.ArchiveEntry -> Bool
-isObjFile = checkEntryHeader "GHCJSOBJ"
+ readEntry ar_file ar_entry = do
+ let bs = Ar.filedata ar_entry
+ bh <- unsafeUnpackBinBuffer bs
+ getObjectHeader bh >>= \case
+ Left _ -> pure Nothing -- not a valid object entry
+ Right mod_name -> do
+ obj <- getObjectBody bh mod_name
+ let !deps = objDeps obj
+ pure $ Just (deps, ArchiveFile ar_file)
isJsFile :: Ar.ArchiveEntry -> Bool
isJsFile = checkEntryHeader "//JavaScript"
@@ -857,12 +882,15 @@ requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d)
-- read dependencies from an object that might have already been into memory
-- pulls in all Deps from an archive
readDepsFile' :: LinkedObj -> IO (Deps, DepsLocation)
-readDepsFile' (ObjLoaded name bs) = (,InMemory name bs) <$>
- readDeps name bs
-readDepsFile' (ObjFile file) =
- (,ObjectFile file) <$> readDepsFile file
-
-generateBase :: FilePath -> Base -> IO ()
-generateBase outDir b =
- BL.writeFile (outDir </> "out.base.symbs") (renderBase b)
+readDepsFile' = \case
+ ObjLoaded name obj -> do
+ let !deps = objDeps obj
+ pure (deps,InMemory name obj)
+ ObjFile file -> do
+ deps <- readObjectDeps file
+ pure (deps,ObjectFile file)
+
+-- generateBase :: FilePath -> Base -> IO ()
+-- generateBase outDir b =
+-- BL.writeFile (outDir </> "out.base.symbs") (renderBase b)
=====================================
compiler/GHC/StgToJS/Linker/Types.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.StgToJS.Object
import GHC.StgToJS.Types (ClosureInfo, StaticInfo)
import GHC.Unit.Types
-import GHC.Utils.Panic
import GHC.Utils.Outputable hiding ((<>))
import GHC.Data.FastString
import GHC.Driver.Env.Types (HscEnv)
@@ -51,14 +50,9 @@ import GHC.Types.Unique.Map
import Control.Monad
import Data.Array
-import qualified Data.Binary as DB
-import qualified Data.Binary.Get as DB
-import qualified Data.Binary.Put as DB
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Lazy as BL
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
-import Data.List (sortOn)
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.IntMap as I
@@ -111,19 +105,19 @@ data StringTable = StringTable
, stIdents :: !(UniqMap FastString (Either Int Int)) -- ^ identifiers in the table
}
-instance DB.Binary Ident where
- put (TxtI s) = DB.put $ unpackFS s
- get = TxtI . mkFastString <$> DB.get
+-- instance DB.Binary Ident where
+-- put (TxtI s) = DB.put $ unpackFS s
+-- get = TxtI . mkFastString <$> DB.get
-instance DB.Binary StringTable where
- put (StringTable tids offs idents) = do
- DB.put tids
- DB.put (M.toList offs)
- -- The lexical sorting allows us to use nonDetEltsUniqMap without introducing non-determinism
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap idents)
- get = StringTable <$> DB.get
- <*> fmap M.fromList DB.get
- <*> fmap listToUniqMap DB.get
+-- instance DB.Binary StringTable where
+-- put (StringTable tids offs idents) = do
+-- DB.put tids
+-- DB.put (M.toList offs)
+-- -- The lexical sorting allows us to use nonDetEltsUniqMap without introducing non-determinism
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap idents)
+-- get = StringTable <$> DB.get
+-- <*> fmap M.fromList DB.get
+-- <*> fmap listToUniqMap DB.get
emptyStringTable :: StringTable
emptyStringTable = StringTable (listArray (0,-1) []) M.empty emptyUniqMap
@@ -293,9 +287,9 @@ data Base = Base { baseCompactorState :: CompactorState
, baseUnits :: Set (Module, Int)
}
-instance DB.Binary Base where
- get = getBase "<unknown file>"
- put = putBase
+-- instance DB.Binary Base where
+-- get = getBase "<unknown file>"
+-- put = putBase
showBase :: Base -> String
showBase b = unlines
@@ -309,96 +303,96 @@ showBase b = unlines
emptyBase :: Base
emptyBase = Base emptyCompactorState [] S.empty
-putBase :: Base -> DB.Put
-putBase (Base cs packages funs) = do
- DB.putByteString "GHCJSBASE"
- DB.putLazyByteString versionTag
- putCs cs
- putList DB.put packages
- -- putList putPkg pkgs
- putList DB.put mods
- putList putFun (S.toList funs)
- where
- pi :: Int -> DB.Put
- pi = DB.putWord32le . fromIntegral
- uniq :: Ord a => [a] -> [a]
- uniq = S.toList . S.fromList
- -- pkgs = uniq (map fst $ S.toList funs)
- -- pkgsM = M.fromList (zip pkgs [(0::Int)..])
- mods = uniq (map fst $ S.toList funs)
- modsM = M.fromList (zip mods [(0::Int)..])
- putList f xs = pi (length xs) >> mapM_ f xs
- -- serialise the compactor state
- putCs (CompactorState [] _ _ _ _ _ _ _ _ _ _ _) =
- panic "putBase: putCs exhausted renamer symbol names"
- putCs (CompactorState (ns:_) nm es _ ss _ ls _ pes pss pls sts) = do
- DB.put ns
- -- We can use nonDetEltsUniqMap without introducing non-determinism by sorting lexically
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap nm)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap es)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap ss)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap ls)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pes)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pss)
- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pls)
- DB.put sts
- -- putPkg mod = DB.put mod
- -- fixme group things first
- putFun (m,s) = --pi (pkgsM M.! p) >>
- pi (modsM M.! m) >> DB.put s
-
-getBase :: FilePath -> DB.Get Base
-getBase file = getBase'
- where
- gi :: DB.Get Int
- gi = fromIntegral <$> DB.getWord32le
- getList f = DB.getWord32le >>= \n -> replicateM (fromIntegral n) f
- getFun ms = (,) <$>
- -- ((ps!) <$> gi) <*>
- ((ms!) <$> gi) <*> DB.get
- la xs = listArray (0, length xs - 1) xs
- -- getPkg = DB.get
- getCs = do
- n <- DB.get
- nm <- listToUniqMap <$> DB.get
- es <- listToUniqMap <$> DB.get
- ss <- listToUniqMap <$> DB.get
- ls <- listToUniqMap <$> DB.get
- pes <- listToUniqMap <$> DB.get
- pss <- listToUniqMap <$> DB.get
- pls <- listToUniqMap <$> DB.get
- CompactorState (dropWhile (/=n) renamedVars)
- nm
- es
- (sizeUniqMap es)
- ss
- (sizeUniqMap ss)
- ls
- (sizeUniqMap ls)
- pes
- pss
- pls <$> DB.get
- getBase' = do
- hdr <- DB.getByteString 9
- when (hdr /= "GHCJSBASE")
- (panic $ "getBase: invalid base file: " <> file)
- vt <- DB.getLazyByteString (fromIntegral versionTagLength)
- when (vt /= versionTag)
- (panic $ "getBase: incorrect version: " <> file)
- cs <- makeCompactorParent <$> getCs
- linkedPackages <- getList DB.get
- -- pkgs <- la <$> getList getPkg
- mods <- la <$> getList DB.get
- funs <- getList (getFun mods)
- return (Base cs linkedPackages $ S.fromList funs)
-
--- | lazily render the base metadata into a bytestring
-renderBase :: Base -> BL.ByteString
-renderBase = DB.runPut . putBase
-
--- | lazily load base metadata from a file, see @UseBase at .
-loadBase :: FilePath -> IO Base
-loadBase file = DB.runGet (getBase file) <$> BL.readFile file
+-- putBase :: Base -> DB.Put
+-- putBase (Base cs packages funs) = do
+-- DB.putByteString "GHCJSBASE"
+-- DB.putLazyByteString versionTag
+-- putCs cs
+-- putList DB.put packages
+-- -- putList putPkg pkgs
+-- putList DB.put mods
+-- putList putFun (S.toList funs)
+-- where
+-- pi :: Int -> DB.Put
+-- pi = DB.putWord32le . fromIntegral
+-- uniq :: Ord a => [a] -> [a]
+-- uniq = S.toList . S.fromList
+-- -- pkgs = uniq (map fst $ S.toList funs)
+-- -- pkgsM = M.fromList (zip pkgs [(0::Int)..])
+-- mods = uniq (map fst $ S.toList funs)
+-- modsM = M.fromList (zip mods [(0::Int)..])
+-- putList f xs = pi (length xs) >> mapM_ f xs
+-- -- serialise the compactor state
+-- putCs (CompactorState [] _ _ _ _ _ _ _ _ _ _ _) =
+-- panic "putBase: putCs exhausted renamer symbol names"
+-- putCs (CompactorState (ns:_) nm es _ ss _ ls _ pes pss pls sts) = do
+-- DB.put ns
+-- -- We can use nonDetEltsUniqMap without introducing non-determinism by sorting lexically
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap nm)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap es)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap ss)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap ls)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pes)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pss)
+-- DB.put (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap pls)
+-- DB.put sts
+-- -- putPkg mod = DB.put mod
+-- -- fixme group things first
+-- putFun (m,s) = --pi (pkgsM M.! p) >>
+-- pi (modsM M.! m) >> DB.put s
+
+-- getBase :: FilePath -> DB.Get Base
+-- getBase file = getBase'
+-- where
+-- gi :: DB.Get Int
+-- gi = fromIntegral <$> DB.getWord32le
+-- getList f = DB.getWord32le >>= \n -> replicateM (fromIntegral n) f
+-- getFun ms = (,) <$>
+-- -- ((ps!) <$> gi) <*>
+-- ((ms!) <$> gi) <*> DB.get
+-- la xs = listArray (0, length xs - 1) xs
+-- -- getPkg = DB.get
+-- getCs = do
+-- n <- DB.get
+-- nm <- listToUniqMap <$> DB.get
+-- es <- listToUniqMap <$> DB.get
+-- ss <- listToUniqMap <$> DB.get
+-- ls <- listToUniqMap <$> DB.get
+-- pes <- listToUniqMap <$> DB.get
+-- pss <- listToUniqMap <$> DB.get
+-- pls <- listToUniqMap <$> DB.get
+-- CompactorState (dropWhile (/=n) renamedVars)
+-- nm
+-- es
+-- (sizeUniqMap es)
+-- ss
+-- (sizeUniqMap ss)
+-- ls
+-- (sizeUniqMap ls)
+-- pes
+-- pss
+-- pls <$> DB.get
+-- getBase' = do
+-- hdr <- DB.getByteString 9
+-- when (hdr /= "GHCJSBASE")
+-- (panic $ "getBase: invalid base file: " <> file)
+-- vt <- DB.getLazyByteString (fromIntegral versionTagLength)
+-- when (vt /= versionTag)
+-- (panic $ "getBase: incorrect version: " <> file)
+-- cs <- makeCompactorParent <$> getCs
+-- linkedPackages <- getList DB.get
+-- -- pkgs <- la <$> getList getPkg
+-- mods <- la <$> getList DB.get
+-- funs <- getList (getFun mods)
+-- return (Base cs linkedPackages $ S.fromList funs)
+
+-- -- | lazily render the base metadata into a bytestring
+-- renderBase :: Base -> BL.ByteString
+-- renderBase = DB.runPut . putBase
+--
+-- -- | lazily load base metadata from a file, see @UseBase at .
+-- loadBase :: FilePath -> IO Base
+-- loadBase file = DB.runGet (getBase file) <$> BL.readFile file
-- | There are 3 ways the linker can use @Base at . We can not use it, and thus not
-- do any incremental linking. We can load it from a file, where we assume that
@@ -502,9 +496,9 @@ data LinkedUnit = LinkedUnit
}
-- | An object file that's either already in memory (with name) or on disk
-data LinkedObj = ObjFile FilePath -- ^ load from this file
- | ObjLoaded String BL.ByteString -- ^ already loaded: description and payload
- deriving (Eq, Ord, Show)
+data LinkedObj
+ = ObjFile FilePath -- ^ load from this file
+ | ObjLoaded String Object -- ^ already loaded: description and payload
data GhcjsEnv = GhcjsEnv
{ compiledModules :: MVar (Map Module ByteString) -- ^ keep track of already compiled modules so we don't compile twice for dynamic-too
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -31,75 +30,49 @@
--
-- file layout:
-- - magic "GHCJSOBJ"
--- - length of symbol table
--- - length of dependencies
--- - length of index
-- - compiler version tag
--- - symbol table
--- - dependency info
--- - closureinfo index
--- - closureinfo data (offsets described by index)
+-- - module name
+-- - offsets of string table
+-- - dependencies
+-- - offset of the index
+-- - unit infos
+-- - index
+-- - string table
--
-----------------------------------------------------------------------------
module GHC.StgToJS.Object
- ( writeObject'
- , readDepsFile
- , readDepsFileEither
- , hReadDeps
- , hReadDepsEither
- , readDeps, readDepsMaybe
- , readObjectFile
- , readObjectFileKeys
+ ( putObject
+ , getObjectHeader
+ , getObjectBody
+ , getObject
, readObject
- , readObjectKeys
- , putLinkableUnit
- , emptySymbolTable
+ , getObjectUnits
+ , readObjectUnits
+ , readObjectDeps
, isGlobalUnit
- , isExportsUnit -- XXX verify that this is used
- -- XXX probably should instead do something that just inspects the header instead of exporting it
- , Header(..), getHeader, moduleNameTag
- , SymbolTable
- , ObjUnit (..)
+ , Object(..)
+ , IndexEntry(..)
, Deps (..), BlockDeps (..), DepsLocation (..)
- , ExpFun (..), ExportedFun (..)
- , versionTag, versionTagLength
- , runPutS
+ , ExportedFun (..)
)
where
import GHC.Prelude
-import Control.Exception (bracket)
import Control.Monad
import Data.Array
-import Data.Monoid
-import qualified Data.Binary as DB
-import qualified Data.Binary.Get as DB
-import qualified Data.Binary.Put as DB
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as B
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as C8 (pack, unpack)
-import qualified Data.ByteString.Short as SBS
-import Data.Function (on)
import Data.Int
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
-import Data.IORef
-import Data.List (sortBy, sortOn)
+import Data.List (sortOn)
import Data.Map (Map)
import qualified Data.Map as M
-import Data.Maybe (catMaybes)
import Data.Word
-import Data.Char (isSpace)
+import Data.Char
-import GHC.Generics
-import GHC.Settings.Constants (hiVersion)
-
-import System.IO (openBinaryFile, withBinaryFile, Handle,
- hClose, hSeek, SeekMode(..), IOMode(..) )
+import GHC.Settings.Constants (hiVersion)
import GHC.JS.Syntax
import GHC.StgToJS.Types
@@ -110,16 +83,19 @@ import GHC.Data.FastString
import GHC.Types.Unique.Map
import GHC.Float (castDoubleToWord64, castWord64ToDouble)
+
import GHC.Utils.Binary hiding (SymbolTable)
-import GHC.Utils.Misc
import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text)
-
-data Header = Header
- { hdrModuleName :: !BS.ByteString
- , hdrSymbsLen :: !Int64
- , hdrDepsLen :: !Int64
- , hdrIdxLen :: !Int64
- } deriving (Eq, Ord, Show)
+import GHC.Utils.Panic
+import GHC.Utils.Monad (mapMaybeM)
+
+data Object = Object
+ { objModuleName :: !ModuleName
+ , objHandle :: !BinHandle -- ^ BinHandle that can be used to read the ObjUnits
+ , objPayloadOffset :: !(Bin ObjUnit) -- ^ Offset of the payload (units)
+ , objDeps :: !Deps
+ , objIndex :: !Index
+ }
type BlockId = Int
type BlockIds = IntSet
@@ -135,7 +111,7 @@ data Deps = Deps
-- ^ exported Haskell functions -> block
, depsBlocks :: !(Array BlockId BlockDeps)
-- ^ info about each block
- } deriving (Generic)
+ }
instance Outputable Deps where
ppr d = vcat
@@ -144,29 +120,17 @@ instance Outputable Deps where
]
-- | Where are the dependencies
-data DepsLocation = ObjectFile FilePath -- ^ In an object file at path
- | ArchiveFile FilePath -- ^ In a Ar file at path
- | InMemory String ByteString -- ^ In memory
- deriving (Eq, Show)
-
-instance Outputable DepsLocation where
- ppr x = text (show x)
+data DepsLocation
+ = ObjectFile FilePath -- ^ In an object file at path
+ | ArchiveFile FilePath -- ^ In a Ar file at path
+ | InMemory String Object -- ^ In memory
data BlockDeps = BlockDeps
{ blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object
, blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects
-- , blockForeignExported :: [ExpFun]
-- , blockForeignImported :: [ForeignRef]
- } deriving (Generic)
-
-data ExpFun = ExpFun
- { isIO :: !Bool
- , args :: [JSFFIType]
- , result :: !JSFFIType
- } deriving (Eq, Ord, Show)
-
-trim :: String -> String
-trim = let f = dropWhile isSpace . reverse in f . f
+ }
{- | we use the convention that the first unit (0) is a module-global
unit that's always included when something from the module
@@ -176,24 +140,6 @@ trim = let f = dropWhile isSpace . reverse in f . f
isGlobalUnit :: Int -> Bool
isGlobalUnit n = n == 0
-isExportsUnit :: Int -> Bool
-isExportsUnit n = n == 1
-
-data JSFFIType
- = Int8Type
- | Int16Type
- | Int32Type
- | Int64Type
- | Word8Type
- | Word16Type
- | Word32Type
- | Word64Type
- | DoubleType
- | ByteArrayType
- | PtrType
- | RefType
- deriving (Show, Ord, Eq, Enum)
-
data ExportedFun = ExportedFun
{ funModule :: !Module
, funSymbol :: !LexicalFastString
@@ -205,120 +151,129 @@ instance Outputable ExportedFun where
, hcat [ text "symbol: ", ppr f ]
]
--- we need to store the size separately, since getting a HashMap's size is O(n)
-data SymbolTable
- = SymbolTable !Int !(UniqMap FastString Int)
-
-emptySymbolTable :: SymbolTable
-emptySymbolTable = SymbolTable 0 emptyUniqMap
-
-insertSymbol :: FastString -> SymbolTable -> (SymbolTable, Int)
-insertSymbol s st@(SymbolTable n t) =
- case lookupUniqMap t s of
- Just k -> (st, k)
- Nothing -> (SymbolTable (n+1) (addToUniqMap t s n), n)
-
-data ObjEnv = ObjEnv
- { oeSymbols :: Dictionary
- , _oeName :: String
+-- | Write an ObjUnit, except for the top level symbols which are stored in the
+-- index
+putObjUnit :: BinHandle -> ObjUnit -> IO ()
+putObjUnit bh (ObjUnit _syms b c d e f g) = do
+ put_ bh b
+ put_ bh c
+ put_ bh d
+ put_ bh e
+ put_ bh f
+ put_ bh g
+
+-- | Read an ObjUnit and associate it to the given symbols (that must have been
+-- read from the index)
+getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit
+getObjUnit syms bh = do
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ e <- get bh
+ f <- get bh
+ g <- get bh
+ pure (ObjUnit syms b c d e f g)
+
+
+magic :: String
+magic = "GHCJSOBJ"
+
+-- | Serialized unit indexes and their exported symbols
+-- (the first unit is module-global)
+type Index = [IndexEntry]
+data IndexEntry = IndexEntry
+ { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit
+ , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file
}
-runGetS :: HasDebugCallStack => String -> Dictionary -> (BinHandle -> IO a) -> ByteString -> IO a
-runGetS name st m bl = do
- let bs = B.toStrict bl
- bh0 <- unpackBinBuffer (BS.length bs) bs
- let bh = setUserData bh0 (newReadState undefined (readTable (ObjEnv st name)))
- m bh
-
--- temporary kludge to bridge BinHandle and ByteString
-runPutS :: SymbolTable -> (BinHandle -> IO ()) -> IO (SymbolTable, ByteString)
-runPutS st ps = do
- bh0 <- openBinMem (1024 * 1024)
- t_r <- newIORef st
- let bh = setUserData bh0 (newWriteState undefined undefined (insertTable t_r))
- ps bh
- (,) <$> readIORef t_r <*> (B.fromStrict <$> packBinBuffer bh)
-
-insertTable :: IORef SymbolTable -> BinHandle -> FastString -> IO ()
-insertTable t_r bh s = do
- t <- readIORef t_r
- let !(t', n) = insertSymbol s t
- writeIORef t_r t'
- put_ bh n
- return ()
-
-readTable :: ObjEnv -> BinHandle -> IO FastString
-readTable e bh = do
- n :: Int <- get bh
- return $ (oeSymbols e) ! fromIntegral n
-
--- one toplevel block in the object file
-data ObjUnit = ObjUnit
- { oiSymbols :: [FastString] -- toplevel symbols (stored in index)
- , oiClInfo :: [ClosureInfo] -- closure information of all closures in block
- , oiStatic :: [StaticInfo] -- static closure data
- , oiStat :: JStat -- the code
- , oiRaw :: FastString -- raw JS code
- , oiFExports :: [ExpFun]
- , oiFImports :: [ForeignJSRef]
- }
+instance Binary IndexEntry where
+ put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b
+ get bh = IndexEntry <$> get bh <*> get bh
--- | Write a linkable unit
-putLinkableUnit
+putObject
:: BinHandle
- -> [ClosureInfo]
- -> [StaticInfo]
- -> JStat
- -> FastString
- -> [ExpFun]
- -> [ForeignJSRef]
+ -> ModuleName -- ^ module
+ -> Deps -- ^ dependencies
+ -> [ObjUnit] -- ^ linkable units and their symbols
-> IO ()
-putLinkableUnit bh ci si s sraw fe fi = do
- put_ bh ci
- put_ bh si
- put_ bh s
- put_ bh sraw
- put_ bh fe
- put_ bh fi
-
--- tag to store the module name in the object file
-moduleNameTag :: ModuleName -> BS.ByteString
-moduleNameTag (ModuleName fs) = case compare len moduleNameLength of
- EQ -> tag
- LT -> tag <> BS.replicate (moduleNameLength - len) 0 -- pad with 0s
- GT -> BS.drop (len - moduleNameLength) tag -- take only the ending chars
- where
- !tag = SBS.fromShort (fs_sbs fs)
- !len = n_chars fs
-
-writeObject'
- :: ModuleName -- ^ module
- -> SymbolTable -- ^ final symbol table
- -> Deps -- ^ dependencies
- -> [([FastString],ByteString)] -- ^ serialized units and their exported symbols, the first unit is module-global
- -> IO ByteString
-writeObject' mod_name st0 deps0 os = do
- (sti, idx) <- putIndex st0 os
- let symbs = putSymbolTable sti
- deps1 <- putDepsSection deps0
- let bl = fromIntegral . B.length
- let hdr = putHeader (Header (moduleNameTag mod_name) (bl symbs) (bl deps1) (bl idx))
- return $ hdr <> symbs <> deps1 <> idx <> mconcat (map snd os)
-
-putIndex :: SymbolTable -> [([FastString], ByteString)] -> IO (SymbolTable, ByteString)
-putIndex st xs = runPutS st (\bh -> put_ bh $ zip symbols offsets)
- where
- (symbols, values) = unzip xs
- offsets = scanl (+) 0 (map B.length values)
-
-getIndex :: HasDebugCallStack => String -> Dictionary -> ByteString -> IO [([FastString], Int64)]
-getIndex name st bs = runGetS name st get bs
-
-putDeps :: SymbolTable -> Deps -> IO (SymbolTable, ByteString)
-putDeps st deps = runPutS st (\bh -> put_ bh deps)
-
-getDeps :: HasDebugCallStack => String -> Dictionary -> ByteString -> IO Deps
-getDeps name st bs = runGetS name st get bs
+putObject bh mod_name deps os = do
+ forM_ magic (putByte bh . fromIntegral . ord)
+ put_ bh (show hiVersion)
+
+ -- we store the module name as a String because we don't want to have to
+ -- decode the FastString table just to decode it when we're looking for an
+ -- object in an archive.
+ put_ bh (moduleNameString mod_name)
+
+ (bh_fs, _bin_dict, put_dict) <- initBinDictionary bh
+
+ forwardPut_ bh (const put_dict) $ do
+ put_ bh_fs deps
+
+ -- forward put the index
+ forwardPut_ bh_fs (put_ bh_fs) $ do
+ idx <- forM os $ \o -> do
+ p <- tellBin bh_fs
+ -- write units without their symbols
+ putObjUnit bh_fs o
+ -- return symbols and offset to store in the index
+ pure (oiSymbols o,p)
+ pure idx
+
+-- | Parse object header
+getObjectHeader :: BinHandle -> IO (Either String ModuleName)
+getObjectHeader bh = do
+ let go_magic = \case
+ [] -> pure True
+ (e:es) -> getByte bh >>= \case
+ c | fromIntegral (ord e) == c -> go_magic es
+ | otherwise -> pure False
+
+ is_magic <- go_magic magic
+ case is_magic of
+ False -> pure (Left "invalid magic header")
+ True -> do
+ is_correct_version <- ((== hiVersion) . read) <$> get bh
+ case is_correct_version of
+ False -> pure (Left "invalid header version")
+ True -> do
+ mod_name <- get bh
+ pure (Right (mkModuleName (mod_name)))
+
+
+-- | Parse object body. Must be called after a sucessful getObjectHeader
+getObjectBody :: BinHandle -> ModuleName -> IO Object
+getObjectBody bh0 mod_name = do
+ -- Read the string table
+ dict <- forwardGet bh0 (getDictionary bh0)
+ let bh = setUserData bh0 $ defaultUserData { ud_get_fs = getDictFastString dict }
+
+ deps <- get bh
+ idx <- forwardGet bh (get bh)
+ payload_pos <- tellBin bh
+
+ pure $ Object
+ { objModuleName = mod_name
+ , objHandle = bh
+ , objPayloadOffset = payload_pos
+ , objDeps = deps
+ , objIndex = idx
+ }
+
+-- | Parse object
+getObject :: BinHandle -> IO Object
+getObject bh = do
+ getObjectHeader bh >>= \case
+ Left err -> panic ("getObject: " ++ err)
+ Right mod_name -> getObjectBody bh mod_name
+
+-- | Read object from file
+--
+-- The object is still in memory after this (see objHandle).
+readObject :: FilePath -> IO Object
+readObject file = do
+ bh <- readBinMem file
+ getObject bh
toI32 :: Int -> Int32
toI32 = fromIntegral
@@ -326,18 +281,6 @@ toI32 = fromIntegral
fromI32 :: Int32 -> Int
fromI32 = fromIntegral
-putDepsSection :: Deps -> IO ByteString
-putDepsSection deps = do
- (st, depsbs) <- putDeps emptySymbolTable deps
- let stbs = putSymbolTable st
- return $ DB.runPut (DB.putWord32le (fromIntegral $ B.length stbs)) <> stbs <> depsbs
-
-getDepsSection :: HasDebugCallStack => String -> ByteString -> IO Deps
-getDepsSection name bs =
- let symbsLen = fromIntegral $ DB.runGet DB.getWord32le bs
- symbs = getSymbolTable (B.drop 4 bs)
- in getDeps name symbs (B.drop (4+symbsLen) bs)
-
instance Binary Deps where
put_ bh (Deps m r e b) = do
put_ bh m
@@ -362,177 +305,48 @@ instance Binary ExpFun where
put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res
get bh = ExpFun <$> get bh <*> get bh <*> get bh
--- | reads only the part necessary to get bh the dependencies
--- so it's potentially more efficient than readDeps <$> B.readFile file
-readDepsFile :: FilePath -> IO Deps
-readDepsFile file = withBinaryFile file ReadMode (hReadDeps file)
-
-readDepsFileEither :: FilePath -> IO (Either String Deps)
-readDepsFileEither file = withBinaryFile file ReadMode (hReadDepsEither file)
-
-hReadDeps :: String -> Handle -> IO Deps
-hReadDeps name h = do
- res <- hReadDepsEither name h
- case res of
- Left err -> error ("hReadDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err)
- Right deps -> pure deps
-
-hReadDepsEither :: String -> Handle -> IO (Either String Deps)
-hReadDepsEither name h = do
- mhdr <- getHeader <$> B.hGet h headerLength
- case mhdr of
- Left err -> pure (Left err)
- Right hdr -> do
- hSeek h RelativeSeek (fromIntegral $ hdrSymbsLen hdr)
- Right <$> (getDepsSection name =<< B.hGet h (fromIntegral $ hdrDepsLen hdr))
-
-readDepsEither :: String -> ByteString -> IO (Either String Deps)
-readDepsEither name bs =
- case getHeader bs of
- Left err -> return $ Left err
- Right hdr ->
- let depsStart = fromIntegral headerLength + fromIntegral (hdrSymbsLen hdr)
- in Right <$> getDepsSection name (B.drop depsStart bs)
-
-
--- | call with contents of the file
-readDeps :: String -> B.ByteString -> IO Deps
-readDeps name bs = do
- mdeps <- readDepsEither name bs
- case mdeps of
- Left err -> error ("readDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err)
- Right deps -> return deps
-
-readDepsMaybe :: String -> ByteString -> IO (Maybe Deps)
-readDepsMaybe name bs = either (const Nothing) Just <$> readDepsEither name bs
-
--- | extract the linkable units from an object file
-readObjectFile :: FilePath -> IO [ObjUnit]
-readObjectFile = readObjectFileKeys (\_ _ -> True)
-
-readObjectFileKeys :: (Int -> [FastString] -> Bool) -> FilePath -> IO [ObjUnit]
-readObjectFileKeys p file = bracket (openBinaryFile file ReadMode) hClose $ \h -> do
- mhdr <- getHeader <$> B.hGet h headerLength
- case mhdr of
- Left err -> error ("readObjectFileKeys: not a valid GHCJS object: " ++ file ++ "\n " ++ err)
- Right hdr -> do
- bss <- B.hGet h (fromIntegral $ hdrSymbsLen hdr)
- hSeek h RelativeSeek (fromIntegral $ hdrDepsLen hdr)
- bsi <- B.fromStrict <$> BS.hGetContents h
- readObjectKeys' file p (getSymbolTable bss) bsi (B.drop (fromIntegral $ hdrIdxLen hdr) bsi)
-
-readObject :: String -> ByteString -> IO [ObjUnit]
-readObject name = readObjectKeys name (\_ _ -> True)
-
-readObjectKeys :: HasDebugCallStack => String -> (Int -> [FastString] -> Bool) -> ByteString -> IO [ObjUnit]
-readObjectKeys name p bs =
- case getHeader bs of
- Left err -> error ("readObjectKeys: not a valid GHCJS object: " ++ name ++ "\n " ++ err)
- Right hdr ->
- let bssymbs = B.drop (fromIntegral headerLength) bs
- bsidx = B.drop (fromIntegral $ hdrSymbsLen hdr + hdrDepsLen hdr) bssymbs
- bsobjs = B.drop (fromIntegral $ hdrIdxLen hdr) bsidx
- in readObjectKeys' name p (getSymbolTable bssymbs) bsidx bsobjs
-
-readObjectKeys' :: HasDebugCallStack
- => String
- -> (Int -> [FastString] -> Bool)
- -> Dictionary
- -> ByteString
- -> ByteString
- -> IO [ObjUnit]
-readObjectKeys' name p st bsidx bsobjs = do
- idx <- getIndex name st bsidx
- catMaybes <$> zipWithM readObj [0..] idx
- where
- readObj n (x,off)
- | p n x = do
- (ci, si, s, sraw, fe, fi) <- runGetS name st getOU (B.drop off bsobjs)
- return $ Just (ObjUnit x ci si s sraw fe fi)
- | otherwise = return Nothing
- getOU bh = (,,,,,) <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-
-getSymbolTable :: HasDebugCallStack => ByteString -> Dictionary
-getSymbolTable bs = listArray (0,n-1) xs
+-- | Reads only the part necessary to get the dependencies
+readObjectDeps :: FilePath -> IO Deps
+readObjectDeps file = do
+ bh <- readBinMem file
+ obj <- getObject bh
+ pure $! objDeps obj
+
+
+-- | Get units in the object file, using the given filtering function
+getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
+getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..])
where
- (n,xs) = DB.runGet getter bs
- getter :: DB.Get (Int, [FastString])
- getter = do
- l <- DB.getWord32le
- let l' = fromIntegral l
- (l',) <$> replicateM l' DB.get
-
-putSymbolTable :: SymbolTable -> ByteString
-putSymbolTable (SymbolTable _ hm) = st
- where
- st = DB.runPut $ do
- DB.putWord32le (fromIntegral $ length xs)
- mapM_ DB.put xs
- xs :: [FastString]
- xs = map fst . sortBy (compare `on` snd) . nonDetEltsUniqMap $ hm
- -- We can use `nonDetEltsUniqMap` because the paired `Int`s introduce ordering.
-
-headerLength :: Int
-headerLength = 32 + versionTagLength + moduleNameLength
-
--- human readable version string in object
-versionTag :: ByteString
-versionTag = B.take 32 . C8.pack $ show hiVersion ++ replicate versionTagLength ' '
-
-versionTagLength :: Int
-versionTagLength = 32
-
--- last part of the module name, to disambiguate files
-moduleNameLength :: Int
-moduleNameLength = 128
-
-getHeader :: HasDebugCallStack => ByteString -> Either String Header
-getHeader bs
- | B.length bs < fromIntegral headerLength = Left "not enough input, file truncated?"
- | magic /= "GHCJSOBJ" = Left $ "magic number incorrect, not a JavaScript .o file?"
- | tag /= versionTag = Left $ "incorrect version, expected " ++ show hiVersion ++
- " but got " ++ (trim . C8.unpack $ tag)
- | otherwise = Right (Header mn sl dl il)
- where
- g = fromIntegral <$> DB.getWord64le
- (magic, tag, mn, sl, dl, il) = DB.runGet ((,,,,,) <$> DB.getByteString 8
- <*> DB.getLazyByteString (fromIntegral versionTagLength)
- <*> DB.getByteString (fromIntegral moduleNameLength)
- <*> g
- <*> g
- <*> g
- ) bs
-
-putHeader :: Header -> ByteString
-putHeader (Header mn sl dl il) = DB.runPut $ do
- DB.putByteString "GHCJSOBJ"
- DB.putLazyByteString versionTag
- DB.putByteString mn
- mapM_ (DB.putWord64le . fromIntegral) [sl, dl, il]
-
-tag :: BinHandle -> Word8 -> IO ()
-tag = put_
-
-getTag :: BinHandle -> IO Word8
-getTag = get
+ bh = objHandle obj
+ read_entry (e@(IndexEntry syms offset),i)
+ | pred i e = do
+ seekBin bh offset
+ Just <$> getObjUnit syms bh
+ | otherwise = pure Nothing
+
+-- | Read units in the object file, using the given filtering function
+readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
+readObjectUnits file pred = do
+ obj <- readObject file
+ getObjectUnits obj pred
instance Binary JStat where
- put_ bh (DeclStat i) = tag bh 1 >> put_ bh i
- put_ bh (ReturnStat e) = tag bh 2 >> put_ bh e
- put_ bh (IfStat e s1 s2) = tag bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2
- put_ bh (WhileStat b e s) = tag bh 4 >> put_ bh b >> put_ bh e >> put_ bh s
- put_ bh (ForInStat b i e s) = tag bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s
- put_ bh (SwitchStat e ss s) = tag bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s
- put_ bh (TryStat s1 i s2 s3) = tag bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3
- put_ bh (BlockStat xs) = tag bh 8 >> put_ bh xs
- put_ bh (ApplStat e es) = tag bh 9 >> put_ bh e >> put_ bh es
- put_ bh (UOpStat o e) = tag bh 10 >> put_ bh o >> put_ bh e
- put_ bh (AssignStat e1 e2) = tag bh 11 >> put_ bh e1 >> put_ bh e2
+ put_ bh (DeclStat i) = putByte bh 1 >> put_ bh i
+ put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e
+ put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2
+ put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s
+ put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s
+ put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s
+ put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3
+ put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs
+ put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es
+ put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e
+ put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2
put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock"
- put_ bh (LabelStat l s) = tag bh 12 >> put_ bh l >> put_ bh s
- put_ bh (BreakStat ml) = tag bh 13 >> put_ bh ml
- put_ bh (ContinueStat ml) = tag bh 14 >> put_ bh ml
- get bh = getTag bh >>= \case
+ put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s
+ put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml
+ put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml
+ get bh = getByte bh >>= \case
1 -> DeclStat <$> get bh
2 -> ReturnStat <$> get bh
3 -> IfStat <$> get bh <*> get bh <*> get bh
@@ -550,15 +364,15 @@ instance Binary JStat where
n -> error ("Binary get bh JStat: invalid tag: " ++ show n)
instance Binary JExpr where
- put_ bh (ValExpr v) = tag bh 1 >> put_ bh v
- put_ bh (SelExpr e i) = tag bh 2 >> put_ bh e >> put_ bh i
- put_ bh (IdxExpr e1 e2) = tag bh 3 >> put_ bh e1 >> put_ bh e2
- put_ bh (InfixExpr o e1 e2) = tag bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2
- put_ bh (UOpExpr o e) = tag bh 5 >> put_ bh o >> put_ bh e
- put_ bh (IfExpr e1 e2 e3) = tag bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3
- put_ bh (ApplExpr e es) = tag bh 7 >> put_ bh e >> put_ bh es
+ put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v
+ put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i
+ put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2
+ put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2
+ put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e
+ put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3
+ put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es
put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr"
- get bh = getTag bh >>= \case
+ get bh = getByte bh >>= \case
1 -> ValExpr <$> get bh
2 -> SelExpr <$> get bh <*> get bh
3 -> IdxExpr <$> get bh <*> get bh
@@ -569,16 +383,16 @@ instance Binary JExpr where
n -> error ("Binary get bh JExpr: invalid tag: " ++ show n)
instance Binary JVal where
- put_ bh (JVar i) = tag bh 1 >> put_ bh i
- put_ bh (JList es) = tag bh 2 >> put_ bh es
- put_ bh (JDouble d) = tag bh 3 >> put_ bh d
- put_ bh (JInt i) = tag bh 4 >> put_ bh i
- put_ bh (JStr xs) = tag bh 5 >> put_ bh xs
- put_ bh (JRegEx xs) = tag bh 6 >> put_ bh xs
- put_ bh (JHash m) = tag bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m)
- put_ bh (JFunc is s) = tag bh 8 >> put_ bh is >> put_ bh s
+ put_ bh (JVar i) = putByte bh 1 >> put_ bh i
+ put_ bh (JList es) = putByte bh 2 >> put_ bh es
+ put_ bh (JDouble d) = putByte bh 3 >> put_ bh d
+ put_ bh (JInt i) = putByte bh 4 >> put_ bh i
+ put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs
+ put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs
+ put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m)
+ put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s
put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal"
- get bh = getTag bh >>= \case
+ get bh = getByte bh >>= \case
1 -> JVar <$> get bh
2 -> JList <$> get bh
3 -> JDouble <$> get bh
@@ -596,12 +410,12 @@ instance Binary Ident where
-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
instance Binary SaneDouble where
put_ bh (SaneDouble d)
- | isNaN d = tag bh 1
- | isInfinite d && d > 0 = tag bh 2
- | isInfinite d && d < 0 = tag bh 3
- | isNegativeZero d = tag bh 4
- | otherwise = tag bh 5 >> put_ bh (castDoubleToWord64 d)
- get bh = getTag bh >>= \case
+ | isNaN d = putByte bh 1
+ | isInfinite d && d > 0 = putByte bh 2
+ | isInfinite d && d < 0 = putByte bh 3
+ | isNegativeZero d = putByte bh 4
+ | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
+ get bh = getByte bh >>= \case
1 -> pure $ SaneDouble (0 / 0)
2 -> pure $ SaneDouble (1 / 0)
3 -> pure $ SaneDouble ((-1) / 0)
@@ -623,9 +437,9 @@ instance Binary VarType where
get bh = getEnum bh
instance Binary CIRegs where
- put_ bh CIRegsUnknown = tag bh 1
- put_ bh (CIRegs skip types) = tag bh 2 >> put_ bh skip >> put_ bh types
- get bh = getTag bh >>= \case
+ put_ bh CIRegsUnknown = putByte bh 1
+ put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types
+ get bh = getByte bh >>= \case
1 -> pure CIRegsUnknown
2 -> CIRegs <$> get bh <*> get bh
n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n)
@@ -640,29 +454,29 @@ instance Binary JUOp where
-- 16 bit sizes should be enough...
instance Binary CILayout where
- put_ bh CILayoutVariable = tag bh 1
- put_ bh (CILayoutUnknown size) = tag bh 2 >> put_ bh size
- put_ bh (CILayoutFixed size types) = tag bh 3 >> put_ bh size >> put_ bh types
- get bh = getTag bh >>= \case
+ put_ bh CILayoutVariable = putByte bh 1
+ put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size
+ put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types
+ get bh = getByte bh >>= \case
1 -> pure CILayoutVariable
2 -> CILayoutUnknown <$> get bh
3 -> CILayoutFixed <$> get bh <*> get bh
n -> error ("Binary get bh CILayout: invalid tag: " ++ show n)
instance Binary CIStatic where
- put_ bh (CIStaticRefs refs) = tag bh 1 >> put_ bh refs
- get bh = getTag bh >>= \case
+ put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs
+ get bh = getByte bh >>= \case
1 -> CIStaticRefs <$> get bh
n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n)
instance Binary CIType where
- put_ bh (CIFun arity regs) = tag bh 1 >> put_ bh arity >> put_ bh regs
- put_ bh CIThunk = tag bh 2
- put_ bh (CICon conTag) = tag bh 3 >> put_ bh conTag
- put_ bh CIPap = tag bh 4
- put_ bh CIBlackhole = tag bh 5
- put_ bh CIStackFrame = tag bh 6
- get bh = getTag bh >>= \case
+ put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs
+ put_ bh CIThunk = putByte bh 2
+ put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag
+ put_ bh CIPap = putByte bh 4
+ put_ bh CIBlackhole = putByte bh 5
+ put_ bh CIStackFrame = putByte bh 6
+ get bh = getByte bh >>= \case
1 -> CIFun <$> get bh <*> get bh
2 -> pure CIThunk
3 -> CICon <$> get bh
@@ -675,37 +489,6 @@ instance Binary ExportedFun where
put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb
get bh = ExportedFun <$> get bh <*> get bh
-instance DB.Binary Module where
- put (Module unit mod_name) = DB.put unit >> DB.put mod_name
- get = Module <$> DB.get <*> DB.get
-
-instance DB.Binary ModuleName where
- put (ModuleName fs) = DB.put fs
- get = ModuleName <$> DB.get
-
-instance DB.Binary Unit where
- put = \case
- RealUnit (Definite uid) -> DB.put (0 :: Int) >> DB.put uid
- VirtUnit uid -> DB.put (1 :: Int) >> DB.put uid
- HoleUnit -> DB.put (2 :: Int)
- get = DB.get >>= \case
- (0 :: Int) -> RealUnit . Definite <$> DB.get
- 1 -> VirtUnit <$> DB.get
- _ -> pure HoleUnit
-
-instance DB.Binary UnitId where
- put (UnitId fs) = DB.put fs
- get = UnitId <$> DB.get
-
-instance DB.Binary InstantiatedUnit where
- put indef = do
- DB.put (instUnitInstanceOf indef)
- DB.put (instUnitInsts indef)
- get = mkInstantiatedUnitSorted <$> DB.get <*> DB.get
-
-instance DB.Binary FastString where
- put fs = DB.put (unpackFS fs)
- get = mkFastString <$> DB.get
putEnum :: Enum a => BinHandle -> a -> IO ()
putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)
@@ -720,12 +503,12 @@ instance Binary StaticInfo where
get bh = StaticInfo <$> get bh <*> get bh <*> get bh
instance Binary StaticVal where
- put_ bh (StaticFun f args) = tag bh 1 >> put_ bh f >> put_ bh args
- put_ bh (StaticThunk t) = tag bh 2 >> put_ bh t
- put_ bh (StaticUnboxed u) = tag bh 3 >> put_ bh u
- put_ bh (StaticData dc args) = tag bh 4 >> put_ bh dc >> put_ bh args
- put_ bh (StaticList xs t) = tag bh 5 >> put_ bh xs >> put_ bh t
- get bh = getTag bh >>= \case
+ put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args
+ put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t
+ put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u
+ put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args
+ put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t
+ get bh = getByte bh >>= \case
1 -> StaticFun <$> get bh <*> get bh
2 -> StaticThunk <$> get bh
3 -> StaticUnboxed <$> get bh
@@ -734,12 +517,12 @@ instance Binary StaticVal where
n -> error ("Binary get bh StaticVal: invalid tag " ++ show n)
instance Binary StaticUnboxed where
- put_ bh (StaticUnboxedBool b) = tag bh 1 >> put_ bh b
- put_ bh (StaticUnboxedInt i) = tag bh 2 >> put_ bh i
- put_ bh (StaticUnboxedDouble d) = tag bh 3 >> put_ bh d
- put_ bh (StaticUnboxedString str) = tag bh 4 >> put_ bh str
- put_ bh (StaticUnboxedStringOffset str) = tag bh 5 >> put_ bh str
- get bh = getTag bh >>= \case
+ put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b
+ put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i
+ put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d
+ put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str
+ put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str
+ get bh = getByte bh >>= \case
1 -> StaticUnboxedBool <$> get bh
2 -> StaticUnboxedInt <$> get bh
3 -> StaticUnboxedDouble <$> get bh
@@ -748,24 +531,24 @@ instance Binary StaticUnboxed where
n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n)
instance Binary StaticArg where
- put_ bh (StaticObjArg i) = tag bh 1 >> put_ bh i
- put_ bh (StaticLitArg p) = tag bh 2 >> put_ bh p
- put_ bh (StaticConArg c args) = tag bh 3 >> put_ bh c >> put_ bh args
- get bh = getTag bh >>= \case
+ put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i
+ put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p
+ put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args
+ get bh = getByte bh >>= \case
1 -> StaticObjArg <$> get bh
2 -> StaticLitArg <$> get bh
3 -> StaticConArg <$> get bh <*> get bh
n -> error ("Binary get bh StaticArg: invalid tag " ++ show n)
instance Binary StaticLit where
- put_ bh (BoolLit b) = tag bh 1 >> put_ bh b
- put_ bh (IntLit i) = tag bh 2 >> put_ bh i
- put_ bh NullLit = tag bh 3
- put_ bh (DoubleLit d) = tag bh 4 >> put_ bh d
- put_ bh (StringLit t) = tag bh 5 >> put_ bh t
- put_ bh (BinLit b) = tag bh 6 >> put_ bh b
- put_ bh (LabelLit b t) = tag bh 7 >> put_ bh b >> put_ bh t
- get bh = getTag bh >>= \case
+ put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b
+ put_ bh (IntLit i) = putByte bh 2 >> put_ bh i
+ put_ bh NullLit = putByte bh 3
+ put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d
+ put_ bh (StringLit t) = putByte bh 5 >> put_ bh t
+ put_ bh (BinLit b) = putByte bh 6 >> put_ bh b
+ put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t
+ get bh = getByte bh >>= \case
1 -> BoolLit <$> get bh
2 -> IntLit <$> get bh
3 -> pure NullLit
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -250,7 +250,7 @@ data ForeignJSRef = ForeignJSRef
-- | data used to generate one ObjUnit in our object file
data LinkableUnit = LinkableUnit
- { luStat :: BS.ByteString -- ^ serialized JS AST
+ { luObjUnit :: ObjUnit -- ^ serializable unit info
, luIdExports :: [Id] -- ^ exported names from haskell identifiers
, luOtherExports :: [FastString] -- ^ other exports
, luIdDeps :: [Id] -- ^ identifiers this unit depends on
@@ -260,6 +260,39 @@ data LinkableUnit = LinkableUnit
, luForeignRefs :: [ForeignJSRef]
}
+-- one toplevel block in the object file
+data ObjUnit = ObjUnit
+ { oiSymbols :: ![FastString] -- toplevel symbols (stored in index)
+ , oiClInfo :: ![ClosureInfo] -- closure information of all closures in block
+ , oiStatic :: ![StaticInfo] -- static closure data
+ , oiStat :: !JStat -- the code
+ , oiRaw :: !BS.ByteString -- raw JS code
+ , oiFExports :: ![ExpFun]
+ , oiFImports :: ![ForeignJSRef]
+ }
+
+data ExpFun = ExpFun
+ { isIO :: !Bool
+ , args :: [JSFFIType]
+ , result :: !JSFFIType
+ } deriving (Eq, Ord, Show)
+
+data JSFFIType
+ = Int8Type
+ | Int16Type
+ | Int32Type
+ | Int64Type
+ | Word8Type
+ | Word16Type
+ | Word32Type
+ | Word64Type
+ | DoubleType
+ | ByteArrayType
+ | PtrType
+ | RefType
+ deriving (Show, Ord, Eq, Enum)
+
+
-- | Typed expression
data TypedExpr = TypedExpr
{ typex_typ :: !PrimRep
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Utils.Binary
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
- packBinBuffer, unpackBinBuffer,
+ packBinBuffer, unpackBinBuffer, unsafeUnpackBinBuffer,
openBinMem,
-- closeBin,
@@ -50,6 +50,7 @@ module GHC.Utils.Binary
readBinMem,
putAt, getAt,
+ forwardPut, forwardPut_, forwardGet,
-- * For writing instances
putByte,
@@ -72,8 +73,11 @@ module GHC.Utils.Binary
-- * User data
UserData(..), getUserData, setUserData,
- newReadState, newWriteState,
+ newReadState, newWriteState, defaultUserData,
+
+ -- * String table ("dictionary")
putDictionary, getDictionary, putFS,
+ BinDictionary, initBinDictionary, getDictFastString, putDictFastString,
) where
import GHC.Prelude
@@ -87,10 +91,11 @@ import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc
+import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import Control.DeepSeq
-import Foreign hiding (shiftL, shiftR)
+import Foreign hiding (shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
@@ -105,7 +110,7 @@ import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time
import Data.List (unfoldr)
-import Control.Monad ( when, (<$!>), unless, forM_ )
+import Control.Monad ( when, (<$!>), unless, forM_, void )
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
@@ -152,7 +157,7 @@ dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
szr <- newFastMutInt size
binr <- newIORef bin
- return (BinMem noUserData ixr szr binr)
+ return (BinMem defaultUserData ixr szr binr)
handleData :: BinHandle -> IO BinData
handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
@@ -163,7 +168,7 @@ handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef
data BinHandle
= BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
+ bh_usr :: !UserData, -- sigh, need parameterized modules :-)
_off_r :: !FastMutInt, -- the current offset
_sz_r :: !FastMutInt, -- size of the array (cached)
_arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
@@ -202,6 +207,13 @@ unpackBinBuffer n from = do
seekBin bh (BinPtr 0)
return bh
+unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
+unsafeUnpackBinBuffer (BS.BS arr len) = do
+ arr_r <- newIORef arr
+ ix_r <- newFastMutInt 0
+ sz_r <- newFastMutInt len
+ return (BinMem defaultUserData ix_r sz_r arr_r)
+
---------------------------------------------------------------
-- Bin
---------------------------------------------------------------
@@ -237,13 +249,13 @@ getAt bh p = do seekBin bh p; get bh
openBinMem :: Int -> IO BinHandle
openBinMem size
- | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
+ | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"
| otherwise = do
arr <- mallocForeignPtrBytes size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (BinMem defaultUserData ix_r sz_r arr_r)
tellBin :: BinHandle -> IO (Bin a)
tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
@@ -255,6 +267,14 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
+-- | SeekBin but without calling expandBin
+seekBinNoExpand :: BinHandle -> Bin a -> IO ()
+seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
+ sz <- readFastMutInt sz_r
+ if (p >= sz)
+ then panic "seekBinNoExpand: seek out of range"
+ else writeFastMutInt ix_r p
+
writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
@@ -277,7 +297,7 @@ readBinMem filename = do
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt filesize
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (BinMem defaultUserData ix_r sz_r arr_r)
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
@@ -572,7 +592,9 @@ getSLEB128 bh = do
-- | Encode the argument in it's full length. This is different from many default
-- binary instances which make no guarantee about the actual encoding and
-- might do things use variable length encoding.
-newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a }
+newtype FixedLengthEncoding a
+ = FixedLengthEncoding { unFixedLength :: a }
+ deriving (Eq,Ord,Show)
instance Binary (FixedLengthEncoding Word8) where
put_ h (FixedLengthEncoding x) = putByte h x
@@ -934,6 +956,45 @@ instance Binary (Bin a) where
get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))
+-- -----------------------------------------------------------------------------
+-- Forward reading/writing
+
+-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B
+-- by using a forward reference
+forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)
+forwardPut bh put_A put_B = do
+ -- write placeholder pointer to A
+ pre_a <- tellBin bh
+ put_ bh pre_a
+
+ -- write B
+ r_b <- put_B
+
+ -- update A's pointer
+ a <- tellBin bh
+ putAt bh pre_a a
+ seekBinNoExpand bh a
+
+ -- write A
+ r_a <- put_A r_b
+ pure (r_a,r_b)
+
+forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()
+forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B
+
+-- | Read a value stored using a forward reference
+forwardGet :: BinHandle -> IO a -> IO a
+forwardGet bh get_A = do
+ -- read forward reference
+ p <- get bh -- a BinPtr
+ -- store current position
+ p_a <- tellBin bh
+ -- go read the forward value, then seek back
+ seekBinNoExpand bh p
+ r <- get_A
+ seekBinNoExpand bh p_a
+ pure r
+
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
@@ -1041,8 +1102,14 @@ newWriteState put_nonbinding_name put_binding_name put_fs
ud_put_fs = put_fs
}
-noUserData :: a
-noUserData = undef "UserData"
+defaultUserData :: UserData
+defaultUserData = UserData
+ { ud_get_name = undef "get_name"
+ , ud_get_fs = undef "get_fs"
+ , ud_put_nonbinding_name = undef "put_nonbinding_name"
+ , ud_put_binding_name = undef "put_binding_name"
+ , ud_put_fs = undef "put_fs"
+ }
undef :: String -> a
undef s = panic ("Binary.UserData: no " ++ s)
@@ -1070,6 +1137,56 @@ getDictionary bh = do
writeArray mut_arr i fs
unsafeFreeze mut_arr
+getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString dict bh = do
+ j <- get bh
+ return $! (dict ! fromIntegral (j :: Word32))
+
+
+initBinDictionary :: BinHandle -> IO (BinHandle, BinDictionary, IO Int)
+initBinDictionary bh = do
+ dict_next_ref <- newFastMutInt 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict = BinDictionary
+ { bin_dict_next = dict_next_ref
+ , bin_dict_map = dict_map_ref
+ }
+ let put_dict = do
+ fs_count <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
+ putDictionary bh fs_count dict_map
+ pure fs_count
+
+ -- BinHandle with FastString writing support
+ let ud = getUserData bh
+ let ud_fs = ud { ud_put_fs = putDictFastString bin_dict }
+ let bh_fs = setUserData bh ud_fs
+
+ return (bh_fs,bin_dict,put_dict)
+
+putDictFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
+
+allocateFastString :: BinDictionary -> FastString -> IO Word32
+allocateFastString BinDictionary { bin_dict_next = j_r,
+ bin_dict_map = out_r} f = do
+ out <- readIORef out_r
+ let !uniq = getUnique f
+ case lookupUFM_Directly out uniq of
+ Just (j, _) -> return (fromIntegral j :: Word32)
+ Nothing -> do
+ j <- readFastMutInt j_r
+ writeFastMutInt j_r (j + 1)
+ writeIORef out_r $! addToUFM_Directly out uniq (j, f)
+ return (fromIntegral j :: Word32)
+
+data BinDictionary = BinDictionary {
+ bin_dict_next :: !FastMutInt, -- The next index to use
+ bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
+ -- indexed by FastString
+ }
+
+
---------------------------------------------------------
-- The Symbol Table
---------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a606f87203a1c249437b1f182df091743e6c3194...24773ce87a251951727a62a2d49343a7c9954af6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a606f87203a1c249437b1f182df091743e6c3194...24773ce87a251951727a62a2d49343a7c9954af6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220906/2bdeffb7/attachment-0001.html>
More information about the ghc-commits
mailing list