WIP (bulk)

asterius/src/Asterius/Ar.hs

@@ -21,7 +21,8 @@
 -- roll out our own implementation of @loadArchive@/@createArchive@ (based on
 -- that of GHC).
 module Asterius.Ar
-  ( loadArchive,
+  ( loadArchiveRep,
+    loadArchiveFile,
     createArchive,
   )
 where
@@ -127,7 +128,7 @@ putGNUArch (Archive as) = do
 -- | Create a library archive from a bunch of object files. Though the name of
 -- each object file is preserved, we set the timestamp, owner ID, group ID, and
 -- file mode to default values (0, 0, 0, and 0644, respectively). When we
--- deserialize (see 'loadArchive'), the metadata is ignored anyway.
+-- deserialize (see 'loadArchiveRep'), the metadata is ignored anyway.
 createArchive :: FilePath -> [FilePath] -> IO ()
 createArchive arFile objFiles = do
   blobs <- for objFiles (unsafeDupableInterleaveIO . BS.readFile)
@@ -150,18 +151,27 @@ writeGNUAr fp = LBS.writeFile fp . runPut . putGNUArch
 
 -------------------------------------------------------------------------------
 
--- | Load the contents of an archive (@.a@) file. 'loadArchive' ignores (@.o@)
+-- | Load the contents of an archive (@.a@) file. 'loadArchiveRep' ignores (@.o@)
 -- files in the archive that cannot be parsed. Also, the metadata of the
 -- contained files are ignored ('createArchive' always sets them to default
 -- values anyway).
-loadArchive :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusRepModule
-loadArchive ncu path = do
+loadArchiveRep :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusRepModule
+loadArchiveRep ncu path = do
   Archive entries <- parseAr <$> BS.readFile path
   ms <- for entries $ \ArchiveEntry {..} -> tryGetBS ncu filedata >>= \case
     Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld
     Right m -> pure m {moduleSources = [(ArchiveFile, path)]}
   pure $ mconcat ms
 
+loadArchiveFile :: GHC.NameCacheUpdater -> FilePath -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule
+loadArchiveFile ncu path fn = do
+  -- TODO: Make real incremental.
+  Archive entries <- parseAr <$> BS.readFile path
+  ms <- for entries $ \ArchiveEntry {..} -> tryGetBS ncu filedata >>= \case
+    Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld
+    Right m -> pure $ fn m
+  pure $ mconcat ms
+
 getAllArEntryFields :: Get (CBS.ByteString, Int, Int, Int, Int, Int, CBS.ByteString)
 getAllArEntryFields = do
   name <- getByteString 16

asterius/src/Asterius/GHCi/Internals.hs

@@ -24,6 +24,7 @@ import Asterius.Internals.Temp
 import Asterius.JSRun.NonMain
 import Asterius.Ld
 import Asterius.Resolve
+import Asterius.Passes.GCSections (fromAsteriusRepModule)
 import Asterius.Types
 import Asterius.Types.SymbolMap
 import Asterius.TypesConv
@@ -93,7 +94,7 @@ data GHCiState
         ghciNameCacheUpdater :: GHC.NameCacheUpdater,
         ghciLibs :: AsteriusRepModule,
         ghciObjs :: M.Map FilePath AsteriusRepModule,
-        ghciCompiledCoreExprs :: IM.IntMap (EntitySymbol, AsteriusRepModule),
+        ghciCompiledCoreExprs :: IM.IntMap (EntitySymbol, AsteriusModule),
         ghciLastCompiledCoreExpr :: Int,
         ghciJSSession :: ~(JSSession, Pipe, JSVal)
       }
@@ -192,7 +193,7 @@ asteriusIservCall hsc_env _ msg = do
     GHC.InitLinker -> pure ()
     GHC.LoadDLL _ -> pure Nothing
     GHC.LoadArchive p -> modifyMVar_ globalGHCiState $ \s -> do
-      lib <- loadArchive (ghciNameCacheUpdater s) p
+      lib <- loadArchiveRep (ghciNameCacheUpdater s) p
       evaluate s {ghciLibs = lib <> ghciLibs s}
     GHC.LoadObj p -> modifyMVar_ globalGHCiState $ \s -> do
       obj <- getFile (ghciNameCacheUpdater s) p
@@ -283,14 +284,15 @@ asteriusWriteIServ hsc_env i a
             this_id = remoteRefToInt q
             (sym, m) = ghciCompiledCoreExprs s IM.! this_id
             (js_s, p, _) = ghciJSSession s
+        link_mod <- fmap (m <>) $ fromAsteriusRepModule (M.foldr' (<>) (ghciLibs s) (ghciObjs s))
         (_, final_m, link_report) <-
           linkExeInMemory
             LinkTask
               { progName = "",
                 linkOutput = "",
                 linkObjs = [],
                 linkLibs = [],
-                linkModule = m <> M.foldr' (<>) (ghciLibs s) (ghciObjs s),
+                linkModule = link_mod,
                 hasMain = False,
                 debug = False,
                 gcSections = True,
@@ -488,7 +490,7 @@ asteriusHscCompileCoreExpr hsc_env srcspan ds_expr = do
     pure
       ( s
           { ghciCompiledCoreExprs =
-              IM.insert this_id (sym, inMemoryToRepModule m) $
+              IM.insert this_id (sym, m) $
                 ghciCompiledCoreExprs s,
             ghciLastCompiledCoreExpr = this_id
           },

asterius/src/Asterius/Ld.hs

@@ -24,13 +24,12 @@ import Asterius.Types
 import qualified Asterius.Types.SymbolSet as SS
 import Control.Exception
 import Data.Traversable
-import qualified IfaceEnv as GHC
 
 data LinkTask
   = LinkTask
       { progName, linkOutput :: FilePath,
         linkObjs, linkLibs :: [FilePath],
-        linkModule :: AsteriusRepModule,
+        linkModule :: AsteriusModule,
         hasMain, debug, gcSections, verboseErr :: Bool,
         outputIR :: Maybe FilePath,
         rootSymbols, exportFunctions :: [EntitySymbol]
@@ -52,15 +51,9 @@ well so far.
 loadTheWorld :: LinkTask -> IO AsteriusRepModule
 loadTheWorld LinkTask {..} = do
   ncu <- newNameCacheUpdater
-  libs <- for linkLibs (loadArchive ncu)
-  objs <- for linkObjs (loadObjectFile ncu)
-  evaluate $ linkModule <> mconcat objs <> mconcat libs
-
--- | Load the representation of an object file from disk.
-loadObjectFile :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusRepModule
-loadObjectFile ncu path = tryGetFile ncu path >>= \case
-  Left {} -> pure mempty -- Note [Malformed object files]
-  Right m -> pure m {moduleSources = [(ObjectFile, path)]}
+  libs <- for linkLibs (loadArchiveRep ncu)
+  objs <- for linkObjs (loadObjectRep ncu)
+  evaluate $ inMemoryToRepModule linkModule <> mconcat objs <> mconcat libs
 
 -- | The *_info are generated from Cmm using the INFO_TABLE macro.
 -- For example, see StgMiscClosures.cmm / Exception.cmm

asterius/src/Asterius/Passes/GCSections.hs

@@ -7,15 +7,18 @@
 
 module Asterius.Passes.GCSections
   ( gcSections,
+    fromAsteriusRepModule,
   )
 where
 
+import Asterius.Ar
+import Asterius.Binary.NameCache
 import Asterius.Types
 import Asterius.Types.EntitySymbol
 import qualified Asterius.Types.SymbolMap as SM
 import qualified Asterius.Types.SymbolSet as SS
-import Data.Foldable
 import Data.Maybe
+import Data.Traversable
 
 -- TODO: Add a couple of comments about why we create the final
 -- @ffiImportDecls@ the way we do:
@@ -97,12 +100,29 @@ gcModule mod_syms export_funcs m =
               }
         }
 
+-- TODO: NOTE: FILTER PER MODULE.
+loadFilterEverything :: AsteriusRepModule -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule
+loadFilterEverything AsteriusRepModule{..} fn = do
+  ncu <- newNameCacheUpdater
+  mods <- for moduleSources $ \case
+    (ObjectFile, path) -> fn <$> loadObjectFile ncu path
+    (ArchiveFile, path) -> loadArchiveFile ncu path fn
+  pure $ fn inMemoryModule <> mconcat mods
+
+-- | Convert an 'AsteriusRepModule' to a self-contained 'AsteriusModule' by
+-- loading everything remaining from disk and combining it with the parts of
+-- 'AsteriusModule' we have in memory (in 'inMemoryModule').
+fromAsteriusRepModule :: AsteriusRepModule -> IO AsteriusModule
+fromAsteriusRepModule m = loadFilterEverything m id
+
 buildGCModule :: SS.SymbolSet -> SS.SymbolSet -> AsteriusRepModule -> SS.SymbolSet -> IO AsteriusModule
 buildGCModule mod_syms err_syms module_rep export_funcs = do
-  -- 1. Build the statics and function maps
-  (statics, functions) <- SS.foldrM addEntry (mempty, mempty) mod_syms
-  -- 2. Add statics for barf-messages
-  let err_statics =
+  everything <- loadFilterEverything module_rep (gcModule mod_syms export_funcs)
+  -- Two more things remain to be done at this point:
+  --   a) Add the error statics
+  --   b) Filter the sptMap which you didn't do earlier.
+  let err_statics :: SM.SymbolMap AsteriusStatics
+      err_statics =
         SM.fromList
           [ ( "__asterius_barf_" <> sym,
               AsteriusStatics
@@ -112,34 +132,11 @@ buildGCModule mod_syms err_syms module_rep export_funcs = do
             )
             | sym <- SS.toList err_syms
           ]
-  -- 3. Create the FFI imports
-  let wrapper_fn_syms :: [EntitySymbol]
-      wrapper_fn_syms = catMaybes . map stripWrapperSuffix . SS.toList $ SM.keysSet functions
-  ffi_imports <- foldrM addFFIImportEntry mempty wrapper_fn_syms
-  -- 4. Create the FFI exports
-  let ffi_exports :: SM.SymbolMap FFIExportDecl
-      ffi_exports = getCompleteFFIExportDecls module_rep `SM.restrictKeys` export_funcs
-  -- 5. Create the static pointers map
-  let spt_map = getCompleteSptMap module_rep `SM.restrictKeys` SM.keysSet statics -- not the error ones.
-        -- Combine it all
-  pure $
-    AsteriusModule
-      { staticsMap = statics <> err_statics,
-        functionMap = functions,
-        sptMap = spt_map,
-        ffiMarshalState =
-          FFIMarshalState
-            { ffiImportDecls = ffi_imports,
-              ffiExportDecls = ffi_exports
-            }
-      }
-  where
-    addEntry sym (statics_map, function_map) = findEntity module_rep sym >>= \case
-      JustStatics statics -> pure (statics_map <> SM.singleton sym statics, function_map)
-      JustFunction function -> pure (statics_map, function_map <> SM.singleton sym function)
-      JustFFIImportDecl {} -> pure (statics_map, function_map) -- TODO: Do nothing (couldn't happen with original implementation)
-      JustFFIExportDecl {} -> pure (statics_map, function_map) -- TODO: Do nothing (couldn't happen with original implementation)
-      NoEntity -> pure (statics_map, function_map) -- Else, do nothing
-    addFFIImportEntry sym sm = findEntity module_rep sym >>= \case
-      JustFFIImportDecl ffiimport -> pure $ SM.insert sym ffiimport sm
-      _other -> pure sm -- TODO: think about this one
+
+      real_sptMap = sptMap everything `SM.restrictKeys` SM.keysSet (staticsMap everything) -- TODO: Can we do this also in a per-module fashion?
+      real_staticsMap = staticsMap everything <> err_statics
+
+  return $ everything
+    { sptMap = real_sptMap,
+      staticsMap = real_staticsMap
+    }