WIP (squash and rebase onto master)

asterius/src/Asterius/Ar.hs

@@ -19,7 +19,9 @@
 -- roll out our own implementation of @loadArchive@/@createArchive@ (based on
 -- that of GHC).
 module Asterius.Ar
-  ( loadArchive,
+  ( loadArchiveRep,
+    loadArchiveFile,
+    loadCompleteArchiveFile,
     createArchive,
   )
 where
@@ -32,7 +34,7 @@ import Data.Binary.Put
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as CBS
 import qualified Data.ByteString.Lazy as LBS
-import Data.Foldable
+import qualified Data.Set as Set
 import Data.Traversable
 import GHC.IO.Unsafe
 import qualified IfaceEnv as GHC
@@ -94,16 +96,38 @@ writeArchiveToFile fp = LBS.writeFile fp . runPut . putArchive
 -- 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 AsteriusCachedModule
-loadArchive ncu p = do
-  Archive entries <- walkArchiveFile p
-  foldlM
-    ( \acc entry -> tryGetBS ncu entry >>= \case
-        Left _ -> pure acc
-        Right m -> pure $ m <> acc
-    )
-    mempty
-    entries
+loadArchiveRep :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusRepModule
+loadArchiveRep ncu path = do
+  Archive entries <- walkArchiveFile path
+  ms <- for entries $ \entry -> tryGetBS ncu entry >>= \case
+    Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld
+    Right m -> pure
+                 AsteriusRepModule
+                   { dependencyMap = onDiskDependencyMap m,
+                     moduleExports = onDiskModuleExports m,
+                     objectSources = mempty, -- Set it once and for all afterwards
+                     archiveSources = mempty,
+                     inMemoryModule = mempty
+                   }
+  let combined = mconcat ms
+  pure combined {archiveSources = Set.singleton path}
+
+loadArchiveFile :: GHC.NameCacheUpdater -> FilePath -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule
+loadArchiveFile ncu path fn = do
+  Archive entries <- walkArchiveFile path
+  ms <- for entries $ \entry -> tryGetBS ncu entry >>= \case
+    Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld
+    Right m -> pure $ fn $ onDiskToInMemory m
+  pure $ mconcat ms
+
+-- could also be loadArchiveFile ncu path id, but let's see if this is more efficient.
+loadCompleteArchiveFile :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusModule
+loadCompleteArchiveFile ncu path = do
+  Archive entries <- walkArchiveFile path
+  ms <- for entries $ \entry -> tryGetBS ncu entry >>= \case
+    Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld
+    Right m -> pure $ onDiskToInMemory m
+  pure $ mconcat ms
 
 -- | Archives have numeric values padded with '\x20' to the right.
 getPaddedInt :: BS.ByteString -> Int

asterius/src/Asterius/Boot.hs

@@ -135,7 +135,7 @@ bootRTSCmm BootArgs {..} =
              in runCodeGen (marshalCmmIR ms_mod ir) dflags ms_mod >>= \case
                   Left err -> throwIO err
                   Right m -> do
-                    putFile obj_path $ toCachedModule m
+                    putFile obj_path $ inMemoryToOnDisk m
                     modifyIORef' obj_paths_ref (obj_path :)
                     when is_debug $ do
                       let p = (obj_path -<.>)

asterius/src/Asterius/Builtins.hs

@@ -799,6 +799,9 @@ generateRTSWrapper mod_sym func_sym param_vts ret_vts =
       [I64] -> ([F64], truncSFloat64ToInt64)
       _ -> (ret_vts, id)
 
+-- | Create a wrapper function for a JSFFI function import. The wrapper
+-- function takes care of the I64/F64 conversion for both the arguments and the
+-- results, and internally calls the function import.
 generateWrapperFunction :: EntitySymbol -> Function -> Function
 generateWrapperFunction func_sym Function {functionType = FunctionType {..}} =
   Function
@@ -835,8 +838,10 @@ generateWrapperFunction func_sym Function {functionType = FunctionType {..}} =
       [I64] -> ([F64], convertSInt64ToFloat64)
       _ -> (returnTypes, id)
 
--- Renames each function in the module to <name>_wrapper, and
--- edits their implementation using 'generateWrapperFunction'
+-- | Rename each function in the module to <name>_wrapper, and edit its
+-- implementation using 'generateWrapperFunction'. Essentially, for each JSFFI
+-- import we have two things: a Wasm function import, and a function wrapper
+-- that takes care of the I64/F64 conversion.
 generateWrapperModule :: AsteriusModule -> AsteriusModule
 generateWrapperModule m =
   m

asterius/src/Asterius/FrontendPlugin.hs

@@ -83,7 +83,7 @@ frontendPlugin = makeFrontendPlugin $ do
               Left err -> throwIO err
               Right m' -> do
                 let m = ffi_mod <> m'
-                putFile obj_path $ toCachedModule m
+                putFile obj_path $ inMemoryToOnDisk m
                 when is_debug $ do
                   let p = (obj_path -<.>)
                   writeFile (p "dump-wasm-ast") =<< prettyShow m
@@ -100,7 +100,7 @@ frontendPlugin = makeFrontendPlugin $ do
             runCodeGen (marshalCmmIR ms_mod ir) dflags ms_mod >>= \case
               Left err -> throwIO err
               Right m -> do
-                putFile obj_path $ toCachedModule m
+                putFile obj_path $ inMemoryToOnDisk m
                 when is_debug $ do
                   let p = (obj_path -<.>)
                   writeFile (p "dump-wasm-ast") =<< prettyShow m

asterius/src/Asterius/GHCi/Internals.hs

@@ -94,9 +94,9 @@ import qualified VarEnv as GHC
 data GHCiState = GHCiState
   { ghciUniqSupply :: GHC.UniqSupply,
     ghciNameCacheUpdater :: GHC.NameCacheUpdater,
-    ghciLibs :: AsteriusCachedModule,
-    ghciObjs :: M.Map FilePath AsteriusCachedModule,
-    ghciCompiledCoreExprs :: IM.IntMap (EntitySymbol, AsteriusCachedModule),
+    ghciLibs :: AsteriusRepModule,
+    ghciObjs :: M.Map FilePath AsteriusRepModule,
+    ghciCompiledCoreExprs :: IM.IntMap (EntitySymbol, AsteriusRepModule),
     ghciLastCompiledCoreExpr :: Int,
     ghciSession :: ~(Session, Pipe, JSVal)
   }
@@ -196,10 +196,10 @@ 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
+      obj <- onDiskToObjRep p <$> getFile (ghciNameCacheUpdater s) p
       evaluate s {ghciObjs = M.insert p obj $ ghciObjs s}
     GHC.AddLibrarySearchPath _ -> pure $ GHC.RemotePtr 0
     GHC.RemoveLibrarySearchPath _ -> pure True
@@ -490,7 +490,7 @@ asteriusHscCompileCoreExpr hsc_env srcspan ds_expr = do
     pure
       ( s
           { ghciCompiledCoreExprs =
-              IM.insert this_id (sym, toCachedModule m) $
+              IM.insert this_id (sym, toAsteriusRepModule m) $
                 ghciCompiledCoreExprs s,
             ghciLastCompiledCoreExpr = this_id
           },

asterius/src/Asterius/JSRun/NonMain.hs

@@ -17,33 +17,33 @@ import Asterius.Main.Task
 import Asterius.Resolve
 import Asterius.Types
   ( EntitySymbol,
-    AsteriusCachedModule,
+    AsteriusRepModule,
     Module,
   )
 import Data.String
 import Language.JavaScript.Inline.Core
 import System.FilePath
 
-linkNonMain :: AsteriusCachedModule -> [EntitySymbol] -> (Module, LinkReport)
-linkNonMain store_m extra_syms = (m, link_report)
-  where
-    (_, m, link_report) =
-      linkModules
-        LinkTask
-          { progName = "",
-            linkOutput = "",
-            linkObjs = [],
-            linkLibs = [],
-            linkModule = mempty,
-            Asterius.Ld.hasMain = False,
-            Asterius.Ld.debug = False,
-            Asterius.Ld.gcSections = True,
-            Asterius.Ld.verboseErr = True,
-            Asterius.Ld.outputIR = Nothing,
-            rootSymbols = extra_syms,
-            Asterius.Ld.exportFunctions = []
-          }
-        store_m
+linkNonMain :: AsteriusRepModule -> [EntitySymbol] -> IO (Module, LinkReport)
+linkNonMain module_rep extra_syms = do
+  (_, m, link_report) <-
+    linkModules
+      LinkTask
+        { progName = "",
+          linkOutput = "",
+          linkObjs = [],
+          linkLibs = [],
+          linkModule = mempty,
+          Asterius.Ld.hasMain = False,
+          Asterius.Ld.debug = False,
+          Asterius.Ld.gcSections = True,
+          Asterius.Ld.verboseErr = True,
+          Asterius.Ld.outputIR = Nothing,
+          rootSymbols = extra_syms,
+          Asterius.Ld.exportFunctions = []
+        }
+      module_rep
+  return (m, link_report)
 
 distNonMain ::
   FilePath -> [EntitySymbol] -> (Module, LinkReport) -> IO ()
@@ -68,10 +68,10 @@ newAsteriusInstanceNonMain ::
   Session ->
   FilePath ->
   [EntitySymbol] ->
-  AsteriusCachedModule ->
+  AsteriusRepModule ->
   IO JSVal
-newAsteriusInstanceNonMain s p extra_syms m = do
-  distNonMain p extra_syms $ linkNonMain m extra_syms
+newAsteriusInstanceNonMain s p extra_syms module_rep = do
+  linkNonMain module_rep extra_syms >>= distNonMain p extra_syms
   let rts_path = dataDir </> "rts" </> "rts.mjs"
       req_path = p -<.> "req.mjs"
       wasm_path = p -<.> "wasm"

asterius/src/Asterius/Ld.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -22,32 +23,37 @@ import Asterius.Resolve
 import Asterius.Types
 import qualified Asterius.Types.SymbolSet as SS
 import Control.Exception
-import Data.Either
 import Data.Traversable
 
 data LinkTask
   = LinkTask
       { progName, linkOutput :: FilePath,
         linkObjs, linkLibs :: [FilePath],
-        linkModule :: AsteriusCachedModule,
+        linkModule :: AsteriusRepModule,
         hasMain, debug, gcSections, verboseErr :: Bool,
         outputIR :: Maybe FilePath,
         rootSymbols, exportFunctions :: [EntitySymbol]
       }
   deriving (Show)
 
+{-
+Note [Malformed object files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Object files in Haskell package directories can also originate from gcc being
+called on cbits in packages. This in the past gave deserialization failures.
+Hence, when we deserialize objects to be linked in 'loadTheWorld', we choose to
+be overpermissive and silently ignore deserialization failures. This has worked
+well so far.
+-}
+
 -- | Load all the library and object dependencies for a 'LinkTask' into a
--- single module. NOTE: object files in Haskell package directories can also
--- originate from gcc being called on cbits in packages. This in the past gave
--- deserialization failures. Hence, when we deserialize objects to be linked in
--- 'loadTheWorld', we choose to be overpermissive and silently ignore
--- deserialization failures. This has worked well so far.
-loadTheWorld :: LinkTask -> IO AsteriusCachedModule
+-- single module.
+loadTheWorld :: LinkTask -> IO AsteriusRepModule
 loadTheWorld LinkTask {..} = do
   ncu <- newNameCacheUpdater
-  lib <- mconcat <$> for linkLibs (loadArchive ncu)
-  objs <- rights <$> for linkObjs (tryGetFile ncu)
-  evaluate $ linkModule <> mconcat objs <> lib
+  libs <- for linkLibs (loadArchiveRep ncu)
+  objs <- for linkObjs (loadObjectRep ncu)
+  evaluate $ linkModule <> mconcat objs <> mconcat libs
 
 -- | The *_info are generated from Cmm using the INFO_TABLE macro.
 -- For example, see StgMiscClosures.cmm / Exception.cmm
@@ -89,21 +95,21 @@ rtsPrivateSymbols =
     ]
 
 linkModules ::
-  LinkTask -> AsteriusCachedModule -> (AsteriusModule, Module, LinkReport)
-linkModules LinkTask {..} m =
+  LinkTask -> AsteriusRepModule -> IO (AsteriusModule, Module, LinkReport)
+linkModules LinkTask {..} module_rep =
   linkStart
     debug
     gcSections
     verboseErr
-    ( toCachedModule
+    ( toAsteriusRepModule
         ( (if hasMain then mainBuiltins else mempty)
             <> rtsAsteriusModule
               defaultBuiltinsOptions
                 { Asterius.Builtins.progName = progName,
                   Asterius.Builtins.debug = debug
                 }
         )
-        <> m
+        <> module_rep
     )
     ( SS.unions
         [ SS.fromList rootSymbols,
@@ -119,13 +125,13 @@ linkModules LinkTask {..} m =
 
 linkExeInMemory :: LinkTask -> IO (AsteriusModule, Module, LinkReport)
 linkExeInMemory ld_task = do
-  final_store <- loadTheWorld ld_task
-  evaluate $ linkModules ld_task final_store
+  module_rep <- loadTheWorld ld_task
+  linkModules ld_task module_rep
 
 linkExe :: LinkTask -> IO ()
 linkExe ld_task@LinkTask {..} = do
   (pre_m, m, link_report) <- linkExeInMemory ld_task
   putFile linkOutput (m, link_report)
   case outputIR of
-    Just p -> putFile p $ toCachedModule pre_m
+    Just p -> putFile p $ inMemoryToOnDisk pre_m
     _ -> pure ()