Use Binary in GHC API for serialization (#553)

asterius/app/ahc-dist.hs

@@ -1,8 +1,10 @@
-import Asterius.Internals
+import Asterius.Binary.File
+import Asterius.Binary.NameCache
 import Asterius.Main
 
 main :: IO ()
 main = do
+  ncu <- newNameCacheUpdater
   task <- getTask
-  ld_result <- decodeFile $ inputHS task
+  ld_result <- getFile ncu $ inputHS task
   ahcDistMain putStrLn task ld_result

asterius/package.yaml

@@ -49,7 +49,6 @@ _exe-ghc-options: &exe-ghc-options
 dependencies:
   - base
   - binary
-  - binaryen
   - bytestring
   - Cabal
   - containers
@@ -70,27 +69,16 @@ dependencies:
   - transformers
   - wasm-toolkit
 
+internal-libraries:
+  asterius-types:
+    source-dirs: src-types
+
 library:
   source-dirs: src
   generated-other-modules: Paths_asterius
-  other-extensions:
-    - DeriveGeneric
-    - DeriveDataTypeable
-    - FlexibleContexts
-    - GADTs
-    - GeneralizedNewtypeDeriving
-    - LambdaCase
-    - MagicHash
-    - NamedFieldPuns
-    - OverloadedLists
-    - OverloadedStrings
-    - RecordWildCards
-    - ScopedTypeVariables
-    - StandaloneDeriving
-    - StrictData
-    - TemplateHaskell
-    - TypeFamilies
-    - UnboxedTuples
+  dependencies:
+    - asterius-types
+    - binaryen
 
 executables:
   ahc:

asterius/src-types/Asterius/Binary/Orphans.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Asterius.Binary.Orphans
+  (
+  )
+where
+
+import qualified Binary as GHC
+import Control.Monad
+import Data.Foldable
+import qualified Data.Map.Lazy as M
+import GHC.Float
+
+instance GHC.Binary Float where
+  put_ bh = GHC.put_ bh . castFloatToWord32
+  get bh = castWord32ToFloat <$> GHC.get bh
+
+instance GHC.Binary Double where
+  put_ bh = GHC.put_ bh . castDoubleToWord64
+  get bh = castWord64ToDouble <$> GHC.get bh
+
+instance (GHC.Binary k, GHC.Binary v) => GHC.Binary (M.Map k v) where
+  put_ bh m =
+    GHC.put_ bh (M.size m)
+      *> for_ (M.toAscList m) (\(k, v) -> GHC.put_ bh k *> GHC.lazyPut bh v)
+  get bh =
+    fmap M.fromDistinctAscList $
+      GHC.get bh
+        >>= flip
+          replicateM
+          ((,) <$> GHC.get bh <*> GHC.lazyGet bh)

asterius/src-types/Asterius/Binary/TH.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Asterius.Binary.TH
+  ( genBinary,
+  )
+where
+
+import qualified Binary as GHC
+import Data.Foldable
+import Data.Word
+import Language.Haskell.TH
+
+genBinary :: Name -> Q [Dec]
+genBinary ty = do
+  TyConI dec <- reify ty
+  case dec of
+    DataD [] ((== ty) -> True) [] Nothing (zip [0 ..] -> cons) _
+      | length cons <= 0xFF ->
+        pure
+          [ InstanceD
+              Nothing
+              []
+              (AppT (ConT ''GHC.Binary) (ConT ty))
+              [ FunD
+                  'GHC.put_
+                  [ Clause
+                      [ VarP $ mkName "bh",
+                        ConP
+                          con_name
+                          [VarP $ mkName $ "a" <> show j | j <- [1 .. con_fields]]
+                      ]
+                      ( NormalB
+                          $ DoE
+                          $ map
+                            ( NoBindS
+                                . AppE (AppE (VarE 'GHC.put_) (VarE $ mkName "bh"))
+                            )
+                          $ [SigE (LitE (IntegerL i)) (ConT ''Word8) | length cons > 1]
+                            <> [VarE $ mkName $ "a" <> show j | j <- [1 .. con_fields]]
+                      )
+                      []
+                    | (i, con) <- cons,
+                      let con_name = dataConName con
+                          con_fields = dataConFields con
+                  ],
+                FunD
+                  'GHC.get
+                  [ Clause
+                      [VarP $ mkName "bh"]
+                      ( NormalB $
+                          case length cons of
+                            1 ->
+                              DoE $
+                                [ BindS
+                                    (VarP $ mkName $ "a" <> show j)
+                                    (AppE (VarE 'GHC.get) (VarE $ mkName "bh"))
+                                  | j <- [1 .. con_fields]
+                                ]
+                                  <> [ NoBindS
+                                         $ AppE (VarE 'pure)
+                                         $ foldl'
+                                           AppE
+                                           (ConE con_name)
+                                           [ VarE $ mkName $ "a" <> show j
+                                             | j <- [1 .. con_fields]
+                                           ]
+                                     ]
+                              where
+                                [(0, con)] = cons
+                                con_name = dataConName con
+                                con_fields = dataConFields con
+                            _ ->
+                              DoE
+                                [ BindS
+                                    (SigP (VarP (mkName "t")) (ConT ''Word8))
+                                    (AppE (VarE 'GHC.get) (VarE $ mkName "bh")),
+                                  NoBindS $
+                                    CaseE
+                                      (VarE $ mkName "t")
+                                      [ Match
+                                          (LitP (IntegerL i))
+                                          ( NormalB
+                                              ( DoE $
+                                                  [ BindS
+                                                      (VarP $ mkName $ "a" <> show j)
+                                                      ( AppE
+                                                          (VarE 'GHC.get)
+                                                          (VarE $ mkName "bh")
+                                                      )
+                                                    | j <- [1 .. con_fields]
+                                                  ]
+                                                    <> [ NoBindS
+                                                           $ AppE (VarE 'pure)
+                                                           $ foldl'
+                                                             AppE
+                                                             (ConE con_name)
+                                                             [ VarE $ mkName $ "a" <> show j
+                                                               | j <- [1 .. con_fields]
+                                                             ]
+                                                       ]
+                                              )
+                                          )
+                                          []
+                                        | (i, con) <- cons,
+                                          let con_name = dataConName con
+                                              con_fields = dataConFields con
+                                      ]
+                                ]
+                      )
+                      []
+                  ]
+              ]
+          ]
+    _ -> fail $ "Asterius.Binary.TH.genBinary: " <> show dec
+
+dataConName :: Con -> Name
+dataConName (NormalC n _) = n
+dataConName (RecC n _) = n
+dataConName c = error $ "Asterius.Binary.TH.dataConName: " <> show c
+
+dataConFields :: Con -> Int
+dataConFields (NormalC _ fs) = length fs
+dataConFields (RecC _ fs) = length fs
+dataConFields c = error $ "Asterius.Binary.TH.dataConFields: " <> show c

asterius/src-types/Asterius/Types.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
 module Asterius.Types
   ( BinaryenIndex,
@@ -48,15 +50,15 @@ module Asterius.Types
   )
 where
 
-import Asterius.Internals.Binary
+import Asterius.Binary.Orphans ()
+import Asterius.Binary.TH
 import Asterius.Types.EntitySymbol
+import qualified Binary as GHC
 import Control.Exception
-import Data.Binary
 import qualified Data.ByteString as BS
 import Data.Data
 import qualified Data.Map.Lazy as LM
 import Foreign
-import GHC.Generics
 
 type BinaryenIndex = Word32
 
@@ -71,9 +73,7 @@ data AsteriusCodeGenError
   | UnsupportedCmmSectionType BS.ByteString
   | UnsupportedImplicitCasting Expression ValueType ValueType
   | AssignToImmutableGlobalReg UnresolvedGlobalReg
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary AsteriusCodeGenError
+  deriving (Show, Data)
 
 instance Exception AsteriusCodeGenError
 
@@ -81,27 +81,21 @@ data AsteriusStatic
   = SymbolStatic EntitySymbol Int
   | Uninitialized Int
   | Serialized BS.ByteString
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary AsteriusStatic
+  deriving (Show, Data)
 
 data AsteriusStaticsType
   = ConstBytes
   | Bytes
   | InfoTable
   | Closure
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary AsteriusStaticsType
+  deriving (Eq, Show, Data)
 
 data AsteriusStatics
   = AsteriusStatics
       { staticsType :: AsteriusStaticsType,
         asteriusStatics :: [AsteriusStatic]
       }
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary AsteriusStatics
+  deriving (Show, Data)
 
 data AsteriusModule
   = AsteriusModule
@@ -111,22 +105,7 @@ data AsteriusModule
         sptMap :: LM.Map EntitySymbol (Word64, Word64),
         ffiMarshalState :: FFIMarshalState
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary AsteriusModule where
-  put AsteriusModule {..} =
-    lazyMapPut staticsMap
-      *> lazyMapPut staticsErrorMap
-      *> lazyMapPut functionMap
-      *> lazyMapPut sptMap
-      *> put ffiMarshalState
-  get =
-    AsteriusModule
-      <$> lazyMapGet
-      <*> lazyMapGet
-      <*> lazyMapGet
-      <*> lazyMapGet
-      <*> get
+  deriving (Show, Data)
 
 instance Semigroup AsteriusModule where
   AsteriusModule sm0 se0 fm0 spt0 mod_ffi_state0 <> AsteriusModule sm1 se1 fm1 spt1 mod_ffi_state1 =
@@ -145,9 +124,7 @@ data AsteriusModuleSymbol
       { unitId :: BS.ByteString,
         moduleName :: [BS.ByteString]
       }
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary AsteriusModuleSymbol
+  deriving (Eq, Ord, Show, Data)
 
 data UnresolvedLocalReg
   = UniqueLocalReg Int ValueType
@@ -155,9 +132,7 @@ data UnresolvedLocalReg
   | QuotRemI32Y
   | QuotRemI64X
   | QuotRemI64Y
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary UnresolvedLocalReg
+  deriving (Eq, Ord, Show, Data)
 
 data UnresolvedGlobalReg
   = VanillaReg Int
@@ -176,26 +151,20 @@ data UnresolvedGlobalReg
   | GCEnter1
   | GCFun
   | BaseReg
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary UnresolvedGlobalReg
+  deriving (Show, Data)
 
 data ValueType
   = I32
   | I64
   | F32
   | F64
-  deriving (Enum, Eq, Ord, Show, Generic, Data)
-
-instance Binary ValueType
+  deriving (Eq, Ord, Enum, Show, Data)
 
 data FunctionType
   = FunctionType
       { paramTypes, returnTypes :: [ValueType]
       }
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary FunctionType
+  deriving (Eq, Ord, Show, Data)
 
 data UnaryOp
   = ClzInt32
@@ -245,9 +214,7 @@ data UnaryOp
   | DemoteFloat64
   | ReinterpretInt32
   | ReinterpretInt64
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary UnaryOp
+  deriving (Show, Data)
 
 data BinaryOp
   = AddInt32
@@ -326,16 +293,12 @@ data BinaryOp
   | LeFloat64
   | GtFloat64
   | GeFloat64
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary BinaryOp
+  deriving (Show, Data)
 
 data HostOp
   = CurrentMemory
   | GrowMemory
-  deriving (Eq, Ord, Show, Generic, Data)
-
-instance Binary HostOp
+  deriving (Show, Data)
 
 data Expression
   = Block
@@ -444,9 +407,7 @@ data Expression
       { barfMessage :: BS.ByteString,
         barfReturnTypes :: [ValueType]
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary Expression
+  deriving (Show, Data)
 
 data Function
   = Function
@@ -454,76 +415,60 @@ data Function
         varTypes :: [ValueType],
         body :: Expression
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary Function
+  deriving (Show, Data)
 
 data FunctionImport
   = FunctionImport
       { internalName, externalModuleName, externalBaseName :: BS.ByteString,
         functionType :: FunctionType
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary FunctionImport
+  deriving (Show, Data)
 
 data TableImport
   = TableImport
       { externalModuleName, externalBaseName :: BS.ByteString
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary TableImport
+  deriving (Show, Data)
 
 data MemoryImport
   = MemoryImport
       { externalModuleName, externalBaseName :: BS.ByteString
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary MemoryImport
+  deriving (Show, Data)
 
 data FunctionExport
   = FunctionExport
       { internalName, externalName :: BS.ByteString
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary FunctionExport
+  deriving (Show, Data)
 
 newtype TableExport
   = TableExport
       { externalName :: BS.ByteString
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary TableExport
+  deriving (Show, Data)
+  deriving newtype (GHC.Binary)
 
 newtype MemoryExport
   = MemoryExport
       { externalName :: BS.ByteString
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary MemoryExport
+  deriving (Show, Data)
+  deriving newtype (GHC.Binary)
 
 data FunctionTable
   = FunctionTable
       { tableFunctionNames :: [BS.ByteString],
         tableOffset :: BinaryenIndex
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary FunctionTable
+  deriving (Show, Data)
 
 data DataSegment
   = DataSegment
       { content :: BS.ByteString,
         offset :: Int32
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary DataSegment
+  deriving (Show, Data)
 
 data Module
   = Module
@@ -539,9 +484,7 @@ data Module
         memoryExport :: MemoryExport,
         memoryMBlocks :: Int
       }
-  deriving (Eq, Show, Data, Generic)
-
-instance Binary Module
+  deriving (Show, Data)
 
 data RelooperAddBlock
   = AddBlock
@@ -550,9 +493,7 @@ data RelooperAddBlock
   | AddBlockWithSwitch
       { code, condition :: Expression
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary RelooperAddBlock
+  deriving (Show, Data)
 
 data RelooperAddBranch
   = AddBranch
@@ -563,18 +504,14 @@ data RelooperAddBranch
       { to :: BS.ByteString,
         indexes :: [BinaryenIndex]
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary RelooperAddBranch
+  deriving (Show, Data)
 
 data RelooperBlock
   = RelooperBlock
       { addBlock :: RelooperAddBlock,
         addBranches :: [RelooperAddBranch]
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary RelooperBlock
+  deriving (Show, Data)
 
 data RelooperRun
   = RelooperRun
@@ -582,9 +519,7 @@ data RelooperRun
         blockMap :: LM.Map BS.ByteString RelooperBlock,
         labelHelper :: BinaryenIndex
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary RelooperRun
+  deriving (Show, Data)
 
 data FFIValueTypeRep
   = FFILiftedRep
@@ -595,35 +530,27 @@ data FFIValueTypeRep
   | FFIAddrRep
   | FFIFloatRep
   | FFIDoubleRep
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFIValueTypeRep
+  deriving (Show, Data)
 
 data FFIValueType
   = FFIValueType
       { ffiValueTypeRep :: FFIValueTypeRep,
         hsTyCon :: BS.ByteString
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFIValueType
+  deriving (Show, Data)
 
 data FFIFunctionType
   = FFIFunctionType
       { ffiParamTypes, ffiResultTypes :: [FFIValueType],
         ffiInIO :: Bool
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFIFunctionType
+  deriving (Show, Data)
 
 data FFISafety
   = FFIUnsafe
   | FFISafe
   | FFIInterruptible
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFISafety
+  deriving (Eq, Show, Data)
 
 data FFIImportDecl
   = FFIImportDecl
@@ -631,38 +558,94 @@ data FFIImportDecl
         ffiSafety :: FFISafety,
         ffiSourceText :: BS.ByteString
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFIImportDecl
+  deriving (Show, Data)
 
 data FFIExportDecl
   = FFIExportDecl
       { ffiFunctionType :: FFIFunctionType,
         ffiExportClosure :: EntitySymbol
       }
-  deriving (Eq, Show, Generic, Data)
-
-instance Binary FFIExportDecl
+  deriving (Show, Data)
 
 data FFIMarshalState
   = FFIMarshalState
       { ffiImportDecls :: LM.Map EntitySymbol FFIImportDecl,
         ffiExportDecls :: LM.Map EntitySymbol FFIExportDecl
       }
-  deriving (Eq, Show, Data)
+  deriving (Show, Data)
 
 instance Semigroup FFIMarshalState where
-  s0 <> s1 = FFIMarshalState
-    { ffiImportDecls = ffiImportDecls s0 <> ffiImportDecls s1,
-      ffiExportDecls = ffiExportDecls s0 <> ffiExportDecls s1
-    }
+  s0 <> s1 =
+    FFIMarshalState
+      { ffiImportDecls = ffiImportDecls s0 <> ffiImportDecls s1,
+        ffiExportDecls = ffiExportDecls s0 <> ffiExportDecls s1
+      }
 
 instance Monoid FFIMarshalState where
   mempty = FFIMarshalState {ffiImportDecls = mempty, ffiExportDecls = mempty}
 
-instance Binary FFIMarshalState where
+$(genBinary ''AsteriusCodeGenError)
 
-  put FFIMarshalState {..} =
-    lazyMapPut ffiImportDecls *> lazyMapPut ffiExportDecls
+$(genBinary ''AsteriusStatic)
 
-  get = FFIMarshalState <$> lazyMapGet <*> lazyMapGet
+$(genBinary ''AsteriusStaticsType)
+
+$(genBinary ''AsteriusStatics)
+
+$(genBinary ''AsteriusModule)
+
+$(genBinary ''AsteriusModuleSymbol)
+
+$(genBinary ''UnresolvedLocalReg)
+
+$(genBinary ''UnresolvedGlobalReg)
+
+$(genBinary ''ValueType)
+
+$(genBinary ''FunctionType)
+
+$(genBinary ''UnaryOp)
+
+$(genBinary ''BinaryOp)
+
+$(genBinary ''HostOp)
+
+$(genBinary ''Expression)
+
+$(genBinary ''Function)
+
+$(genBinary ''FunctionImport)
+
+$(genBinary ''TableImport)
+
+$(genBinary ''MemoryImport)
+
+$(genBinary ''FunctionExport)
+
+$(genBinary ''FunctionTable)
+
+$(genBinary ''DataSegment)
+
+$(genBinary ''Module)
+
+$(genBinary ''RelooperAddBlock)
+
+$(genBinary ''RelooperAddBranch)
+
+$(genBinary ''RelooperBlock)
+
+$(genBinary ''RelooperRun)
+
+$(genBinary ''FFIValueTypeRep)
+
+$(genBinary ''FFIValueType)
+
+$(genBinary ''FFIFunctionType)
+
+$(genBinary ''FFISafety)
+
+$(genBinary ''FFIImportDecl)
+
+$(genBinary ''FFIExportDecl)
+
+$(genBinary ''FFIMarshalState)

asterius/src-types/Asterius/Types/EntitySymbol.hs

@@ -9,14 +9,14 @@ module Asterius.Types.EntitySymbol
   )
 where
 
-import Data.Binary
+import qualified Binary as GHC
 import qualified Data.ByteString as BS
 import Data.Data
 import Data.String
 import qualified GhcPlugins as GHC
 
 newtype EntitySymbol = EntitySymbol GHC.FastString
-  deriving newtype (Eq, Ord, Show, IsString, Semigroup, Monoid)
+  deriving newtype (Eq, Ord, Show, IsString, Semigroup, Monoid, GHC.Binary)
   deriving stock (Data)
 
 {-# INLINE entityName #-}
@@ -26,9 +26,3 @@ entityName (EntitySymbol k) = GHC.fastStringToByteString k
 {-# INLINE mkEntitySymbol #-}
 mkEntitySymbol :: BS.ByteString -> EntitySymbol
 mkEntitySymbol = EntitySymbol . GHC.mkFastStringByteString
-
-instance Binary EntitySymbol where
-  {-# INLINE put #-}
-  put = put . entityName
-  {-# INLINE get #-}
-  get = mkEntitySymbol <$> get

asterius/src-types/Asterius/Types/LinkReport.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Asterius.Types.LinkReport
+  ( LinkReport (..),
+  )
+where
+
+import Asterius.Binary.TH
+import Asterius.Types
+import Data.Int
+import qualified Data.Map.Lazy as M
+import Data.Word
+
+data LinkReport
+  = LinkReport
+      { staticsSymbolMap, functionSymbolMap :: M.Map EntitySymbol Int64,
+        infoTableSet :: [Int64],
+        tableSlots, staticMBlocks :: Int,
+        sptEntries :: M.Map EntitySymbol (Word64, Word64),
+        bundledFFIMarshalState :: FFIMarshalState
+      }
+  deriving (Show)
+
+$(genBinary ''LinkReport)
+
+instance Semigroup LinkReport where
+  r0 <> r1 =
+    LinkReport
+      { staticsSymbolMap = staticsSymbolMap r0 <> staticsSymbolMap r1,
+        functionSymbolMap = functionSymbolMap r0 <> functionSymbolMap r1,
+        infoTableSet = infoTableSet r0 <> infoTableSet r1,
+        tableSlots = 0,
+        staticMBlocks = 0,
+        sptEntries = sptEntries r0 <> sptEntries r1,
+        bundledFFIMarshalState =
+          bundledFFIMarshalState r0
+            <> bundledFFIMarshalState r1
+      }
+
+instance Monoid LinkReport where
+  mempty =
+    LinkReport
+      { staticsSymbolMap = mempty,
+        functionSymbolMap = mempty,
+        infoTableSet = mempty,
+        tableSlots = 0,
+        staticMBlocks = 0,
+        sptEntries = mempty,
+        bundledFFIMarshalState = mempty
+      }

asterius/src/Asterius/Ar.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -8,19 +8,18 @@ module Asterius.Ar
 where
 
 import qualified Ar as GHC
-import Asterius.Internals.Binary
+import Asterius.Binary.ByteString
 import Asterius.Types
-import Control.Exception
-import Data.List
+import Data.Foldable
+import qualified IfaceEnv as GHC
 
-loadAr :: FilePath -> IO AsteriusModule
-loadAr p = do
+loadAr :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusModule
+loadAr ncu p = do
   GHC.Archive entries <- GHC.loadAr p
-  evaluate $
-    foldl'
-      ( \acc GHC.ArchiveEntry {..} -> case decodeMaybe filedata of
-          Just m -> m <> acc
-          _ -> acc
-      )
-      mempty
-      entries
+  foldlM
+    ( \acc GHC.ArchiveEntry {..} -> tryGetBS ncu filedata >>= \case
+        Left _ -> pure acc
+        Right m -> pure $ m <> acc
+    )
+    mempty
+    entries

asterius/src/Asterius/Binary/ByteString.hs

@@ -0,0 +1,31 @@
+module Asterius.Binary.ByteString
+  ( tryGetBS,
+  )
+where
+
+import qualified BinIface as GHC
+import qualified Binary as GHC
+import Control.Exception
+import qualified Data.ByteString.Internal as BS
+import qualified Data.ByteString.Unsafe as BS
+import Foreign.Ptr
+import qualified IfaceEnv as GHC
+
+binHandleFromBS :: BS.ByteString -> IO GHC.BinHandle
+binHandleFromBS bs = BS.unsafeUseAsCStringLen bs $ \(src_p, l) -> do
+  bh <- GHC.openBinMem l
+  GHC.withBinBuffer bh $ flip BS.unsafeUseAsCStringLen $ \(dest_p, _) ->
+    BS.memcpy (castPtr dest_p) (castPtr src_p) l
+  pure bh
+
+getBS :: GHC.Binary a => GHC.NameCacheUpdater -> BS.ByteString -> IO a
+getBS ncu bs = do
+  bh <- binHandleFromBS bs
+  GHC.getWithUserData ncu bh
+
+tryGetBS ::
+  GHC.Binary a =>
+  GHC.NameCacheUpdater ->
+  BS.ByteString ->
+  IO (Either SomeException a)
+tryGetBS ncu = try . getBS ncu

asterius/src/Asterius/Binary/File.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Asterius.Binary.File
+  ( putFile,
+    getFile,
+    tryGetFile,
+  )
+where
+
+import qualified BinIface as GHC
+import qualified Binary as GHC
+import Control.Exception
+import qualified IfaceEnv as GHC
+
+putFile :: GHC.Binary a => FilePath -> a -> IO ()
+putFile p a = do
+  bh <- GHC.openBinMem 1048576
+  GHC.putWithUserData (const (pure ())) bh a
+  GHC.writeBinMem bh p
+
+getFile :: GHC.Binary a => GHC.NameCacheUpdater -> FilePath -> IO a
+getFile ncu p = do
+  bh <- GHC.readBinMem p
+  GHC.getWithUserData ncu bh
+
+tryGetFile ::
+  GHC.Binary a =>
+  GHC.NameCacheUpdater ->
+  FilePath ->
+  IO (Either SomeException a)
+tryGetFile ncu = try . getFile ncu

asterius/src/Asterius/Binary/NameCache.hs

@@ -0,0 +1,16 @@
+module Asterius.Binary.NameCache
+  ( newNameCacheUpdater,
+  )
+where
+
+import Data.IORef
+import qualified GhcPlugins as GHC
+import qualified IfaceEnv as GHC
+import qualified NameCache as GHC
+import qualified PrelInfo as GHC
+
+newNameCacheUpdater :: IO GHC.NameCacheUpdater
+newNameCacheUpdater = do
+  us <- GHC.mkSplitUniqSupply 'r'
+  nc <- newIORef (GHC.initNameCache us GHC.knownKeyNames)
+  pure $ GHC.NCU $ atomicModifyIORef' nc

asterius/src/Asterius/Boot.hs

@@ -11,10 +11,10 @@ module Asterius.Boot
   )
 where
 
+import Asterius.Binary.File
 import Asterius.BuildInfo
 import Asterius.Builtins
 import Asterius.CodeGen
-import Asterius.Internals
 import Asterius.Internals.Directory
 import Asterius.TypesConv
 import Control.Exception
@@ -130,7 +130,7 @@ bootRTSCmm BootArgs {..} =
              in runCodeGen (marshalCmmIR ms_mod ir) dflags ms_mod >>= \case
                   Left err -> throwIO err
                   Right m -> do
-                    encodeFile obj_path m
+                    putFile obj_path m
                     modifyIORef' obj_paths_ref (obj_path :)
                     when is_debug $ do
                       let p = (obj_path -<.>)

asterius/src/Asterius/FrontendPlugin.hs

@@ -6,12 +6,12 @@ module Asterius.FrontendPlugin
   )
 where
 
+import Asterius.Binary.File
 import Asterius.BuildInfo
 import Asterius.CodeGen
 import Asterius.Foreign.DsForeign
 import Asterius.Foreign.TcForeign
 import Asterius.GHCi.Internals
-import Asterius.Internals
 import Asterius.JSFFI
 import Asterius.TypesConv
 import Control.Exception
@@ -82,7 +82,7 @@ frontendPlugin = makeFrontendPlugin $ do
               Left err -> throwIO err
               Right m' -> do
                 let m = ffi_mod <> m'
-                encodeFile obj_path m
+                putFile obj_path m
                 when is_debug $ do
                   let p = (obj_path -<.>)
                   writeFile (p "dump-wasm-ast") $ show m
@@ -99,7 +99,7 @@ frontendPlugin = makeFrontendPlugin $ do
             runCodeGen (marshalCmmIR ms_mod ir) dflags ms_mod >>= \case
               Left err -> throwIO err
               Right m -> do
-                encodeFile obj_path m
+                putFile obj_path m
                 when is_debug $ do
                   let p = (obj_path -<.>)
                   writeFile (p "dump-wasm-ast") $ show m

asterius/src/Asterius/GHCi/Internals.hs

@@ -15,6 +15,8 @@ module Asterius.GHCi.Internals
 where
 
 import Asterius.Ar
+import Asterius.Binary.File
+import Asterius.Binary.NameCache
 import Asterius.BuildInfo
 import Asterius.CodeGen
 import Asterius.Internals ((!))
@@ -82,10 +84,12 @@ import qualified UniqFM as GHC
 import qualified UniqSupply as GHC
 import Unsafe.Coerce
 import qualified VarEnv as GHC
+import qualified IfaceEnv as GHC
 
 data GHCiState
   = GHCiState
       { ghciUniqSupply :: GHC.UniqSupply,
+        ghciNameCacheUpdater :: GHC.NameCacheUpdater,
         ghciLibs :: AsteriusModule,
         ghciObjs :: M.Map FilePath AsteriusModule,
         ghciCompiledCoreExprs :: IM.IntMap (EntitySymbol, AsteriusModule),
@@ -97,8 +101,10 @@ data GHCiState
 globalGHCiState :: MVar GHCiState
 globalGHCiState = unsafePerformIO $ do
   us <- GHC.mkSplitUniqSupply 'A'
+  ncu <- newNameCacheUpdater
   newMVar GHCiState
     { ghciUniqSupply = us,
+      ghciNameCacheUpdater = ncu,
       ghciLibs = mempty,
       ghciObjs = M.empty,
       ghciCompiledCoreExprs = IM.empty,
@@ -176,10 +182,10 @@ asteriusIservCall hsc_env _ msg = do
     GHC.InitLinker -> pure ()
     GHC.LoadDLL _ -> pure Nothing
     GHC.LoadArchive p -> modifyMVar_ globalGHCiState $ \s -> do
-      lib <- loadAr p
+      lib <- loadAr (ghciNameCacheUpdater s) p
       evaluate s {ghciLibs = lib <> ghciLibs s}
     GHC.LoadObj p -> modifyMVar_ globalGHCiState $ \s -> do
-      obj <- decodeFile p
+      obj <- getFile (ghciNameCacheUpdater s) p
       evaluate s {ghciObjs = M.insert p obj $ ghciObjs s}
     GHC.AddLibrarySearchPath _ -> pure $ GHC.RemotePtr 0
     GHC.RemoveLibrarySearchPath _ -> pure True

asterius/src/Asterius/Internals.hs

@@ -6,17 +6,12 @@
 module Asterius.Internals
   ( encodeStorable,
     reinterpretCast,
-    encodeFile,
-    decodeFile,
-    tryDecodeFile,
     showBS,
     c8BS,
     (!),
   )
 where
 
-import Control.Exception
-import qualified Data.Binary as Binary
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Char8 as CBS
 import qualified Data.Map.Lazy as LM
@@ -49,23 +44,6 @@ reinterpretCast a =
     ) of
     (# _, r #) -> r
 
-{-# INLINE encodeFile #-}
-encodeFile :: Binary.Binary a => FilePath -> a -> IO ()
-encodeFile = Binary.encodeFile
-
-{-# INLINE decodeFile #-}
-decodeFile :: Binary.Binary a => FilePath -> IO a
-decodeFile = Binary.decodeFile
-
-{-# INLINE tryDecodeFile #-}
-tryDecodeFile :: Binary.Binary a => FilePath -> IO (Either SomeException a)
-tryDecodeFile p = do
-  r <- try $ Binary.decodeFileOrFail p
-  pure $ case r of
-    Left err -> Left err
-    Right (Left err) -> Left $ toException $ userError $ show err
-    Right (Right v) -> Right v
-
 {-# INLINE showBS #-}
 showBS :: Show a => a -> BS.ByteString
 showBS = fromString . show

asterius/src/Asterius/Internals/Binary.hs

@@ -1,44 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Asterius.Internals.Binary
-  ( decodeMaybe,
-    lazyMapPut,
-    lazyMapGet,
-  )
-where
-
-import Control.Monad
-import Data.Binary
-import Data.Binary.Get
-import qualified Data.ByteString as BS
-import Data.Map.Lazy (Map)
-import qualified Data.Map.Lazy as LMap
-
-{-# INLINE decode' #-}
-decode' :: Binary a => BS.ByteString -> a
-decode' buf = case runGetIncremental get of
-  Partial k -> case k (Just buf) of
-    Done _ _ r -> r
-    _ -> error "Asterius.Internals.Binary.decode': failed to deserialize"
-  _ ->
-    error "Asterius.Internals.Binary.decode': failed to start deserialization"
-
-{-# INLINE decodeMaybe #-}
-decodeMaybe :: Binary a => BS.ByteString -> Maybe a
-decodeMaybe buf = case runGetIncremental get of
-  Partial k -> case k (Just buf) of
-    Done _ _ !r -> Just r
-    _ -> Nothing
-  _ -> Nothing
-
-{-# INLINE lazyMapPut #-}
-lazyMapPut :: (Binary k, Binary v) => Map k v -> Put
-lazyMapPut m =
-  put (LMap.size m)
-    *> LMap.foldrWithKey' (\k v acc -> put k *> put (encode v) *> acc) mempty m
-
-{-# INLINE lazyMapGet #-}
-lazyMapGet :: (Binary k, Binary v) => Get (Map k v)
-lazyMapGet = do
-  n <- get
-  LMap.fromDistinctAscList <$> replicateM n ((,) <$> get <*> (decode' <$> get))

asterius/src/Asterius/Internals/FList.hs

@@ -1,110 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Asterius.Internals.FList
-  ( FList,
-    cons,
-    snoc,
-    concat,
-  )
-where
-
-import Data.Binary
-import GHC.Exts
-import Prelude hiding (concat)
-
-data FList a where
-  Empty :: FList a
-  Singleton :: a -> FList a
-  Cons :: a -> FList a -> FList a
-  Snoc :: FList a -> a -> FList a
-  Append :: FList a -> FList a -> FList a
-  FromFoldable :: Foldable t => t a -> FList a
-  Map :: (a -> b) -> FList a -> FList b
-  Join :: FList (FList a) -> FList a
-
-instance Semigroup (FList a) where
-  {-# INLINE (<>) #-}
-  Empty <> l1 = l1
-  l0 <> Empty = l0
-  Singleton a <> l1 = Cons a l1
-  l0 <> Singleton a = Snoc l0 a
-  l0 <> l1 = Append l0 l1
-
-instance Monoid (FList a) where
-  {-# INLINE mempty #-}
-  mempty = Empty
-
-instance Foldable FList where
-
-  foldr f b l = case l of
-    Empty -> b
-    Singleton a -> f a b
-    Cons a l0 -> f a (foldr f b l0)
-    Snoc l0 a -> foldr f (f a b) l0
-    Append l0 l1 -> foldr f (foldr f b l1) l0
-    FromFoldable l0 -> Prelude.foldr f b l0
-    Map g l0 -> foldr (f . g) b l0
-    Join l0 -> foldr (flip (foldr f)) b l0
-
-  null l = case l of
-    Empty -> True
-    Singleton {} -> False
-    Cons {} -> False
-    Snoc {} -> False
-    Append l0 l1 -> null l0 && null l1
-    FromFoldable l0 -> null l0
-    Map _ l0 -> null l0
-    Join l0 -> and (fmap null l0)
-
-instance Functor FList where
-  {-# INLINE fmap #-}
-  fmap f l = case l of
-    Empty -> Empty
-    Singleton a -> Singleton (f a)
-    Map g l0 -> Map (f . g) l0
-    _ -> Map f l
-
-instance Applicative FList where
-
-  {-# INLINE pure #-}
-  pure = Singleton
-
-  {-# INLINE (<*>) #-}
-  f <*> a = Join (fmap (`fmap` a) f)
-
-instance Monad FList where
-  {-# INLINE (>>=) #-}
-  l >>= f = Join (fmap f l)
-
-instance IsList (FList a) where
-
-  type Item (FList a) = a
-
-  {-# INLINE fromList #-}
-  fromList = FromFoldable
-
-  {-# INLINE toList #-}
-  toList = foldr (:) []
-
-instance Show a => Show (FList a) where
-  {-# INLINE showsPrec #-}
-  showsPrec i = showsPrec i . toList
-
-instance Binary a => Binary (FList a) where
-
-  get = fromList <$> get
-
-  put = put . toList
-
-{-# INLINE cons #-}
-cons :: a -> FList a -> FList a
-cons = Cons
-
-{-# INLINE snoc #-}
-snoc :: FList a -> a -> FList a
-snoc = Snoc
-
-{-# INLINE concat #-}
-concat :: FList (FList a) -> FList a
-concat = Join

asterius/src/Asterius/Ld.hs

@@ -14,9 +14,10 @@ module Asterius.Ld
 where
 
 import Asterius.Ar
+import Asterius.Binary.File
+import Asterius.Binary.NameCache
 import Asterius.Builtins
 import Asterius.Builtins.Main
-import Asterius.Internals
 import Asterius.Resolve
 import Asterius.Types
 import Control.Exception
@@ -38,8 +39,9 @@ data LinkTask
 
 loadTheWorld :: LinkTask -> IO AsteriusModule
 loadTheWorld LinkTask {..} = do
-  lib <- mconcat <$> for linkLibs loadAr
-  objrs <- for linkObjs tryDecodeFile
+  ncu <- newNameCacheUpdater
+  lib <- mconcat <$> for linkLibs (loadAr ncu)
+  objrs <- for linkObjs (tryGetFile ncu)
   let objs = rights objrs
   evaluate $ linkModule <> mconcat objs <> lib
 
@@ -117,7 +119,7 @@ linkExeInMemory ld_task = do
 linkExe :: LinkTask -> IO ()
 linkExe ld_task@LinkTask {..} = do
   (pre_m, m, link_report) <- linkExeInMemory ld_task
-  encodeFile linkOutput (m, link_report)
+  putFile linkOutput (m, link_report)
   case outputIR of
-    Just p -> encodeFile p pre_m
+    Just p -> putFile p pre_m
     _ -> pure ()

asterius/src/Asterius/Main.hs

@@ -13,6 +13,8 @@ where
 
 import qualified Asterius.Backends.Binaryen as Binaryen
 import qualified Asterius.Backends.WasmToolkit as WasmToolkit
+import Asterius.Binary.File
+import Asterius.Binary.NameCache
 import Asterius.BuildInfo
 import Asterius.Foreign.ExportStatic
 import Asterius.Internals
@@ -276,7 +278,8 @@ ahcLink task = do
          ]
       <> ["-optl--prog-name=" <> takeBaseName (inputHS task)]
       <> ["-o", ld_output, inputHS task]
-  r <- decodeFile ld_output
+  ncu <- newNameCacheUpdater
+  r <- getFile ncu ld_output
   removeFile ld_output
   pure r
 

asterius/src/Asterius/Resolve.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StrictData #-}
@@ -11,6 +10,7 @@ module Asterius.Resolve
   )
 where
 
+import Asterius.Binary.Orphans ()
 import Asterius.Builtins
 import Asterius.Internals.MagicNumber
 import Asterius.JSFFI
@@ -19,12 +19,11 @@ import Asterius.Passes.DataSymbolTable
 import Asterius.Passes.FunctionSymbolTable
 import Asterius.Passes.GCSections
 import Asterius.Types
-import Data.Binary
+import Asterius.Types.LinkReport
 import qualified Data.ByteString as BS
 import qualified Data.Map.Lazy as LM
 import qualified Data.Set as S
 import Foreign
-import GHC.Generics
 import Language.Haskell.GHC.Toolkit.Constants
 
 unresolvedGlobalRegType :: UnresolvedGlobalReg -> ValueType
@@ -33,44 +32,6 @@ unresolvedGlobalRegType gr = case gr of
   DoubleReg _ -> F64
   _ -> I64
 
-data LinkReport
-  = LinkReport
-      { staticsSymbolMap, functionSymbolMap :: LM.Map EntitySymbol Int64,
-        infoTableSet :: [Int64],
-        tableSlots, staticMBlocks :: Int,
-        sptEntries :: LM.Map EntitySymbol (Word64, Word64),
-        bundledFFIMarshalState :: FFIMarshalState
-      }
-  deriving (Generic, Show)
-
-instance Binary LinkReport
-
-instance Semigroup LinkReport where
-  r0 <> r1 =
-    LinkReport
-      { staticsSymbolMap = staticsSymbolMap r0 <> staticsSymbolMap r1,
-        functionSymbolMap = functionSymbolMap r0 <> functionSymbolMap r1,
-        infoTableSet = infoTableSet r0 <> infoTableSet r1,
-        tableSlots = 0,
-        staticMBlocks = 0,
-        sptEntries = sptEntries r0 <> sptEntries r1,
-        bundledFFIMarshalState =
-          bundledFFIMarshalState r0
-            <> bundledFFIMarshalState r1
-      }
-
-instance Monoid LinkReport where
-  mempty =
-    LinkReport
-      { staticsSymbolMap = mempty,
-        functionSymbolMap = mempty,
-        infoTableSet = mempty,
-        tableSlots = 0,
-        staticMBlocks = 0,
-        sptEntries = mempty,
-        bundledFFIMarshalState = mempty
-      }
-
 makeInfoTableSet ::
   AsteriusModule -> LM.Map EntitySymbol Int64 -> [Int64]
 makeInfoTableSet AsteriusModule {..} sym_map =
@@ -154,7 +115,7 @@ linkStart debug gc_sections verbose_err store root_syms export_funcs =
       { staticsSymbolMap = ss_sym_map,
         functionSymbolMap = func_sym_map,
         infoTableSet = makeInfoTableSet merged_m ss_sym_map,
-        Asterius.Resolve.tableSlots = tbl_slots,
+        Asterius.Types.LinkReport.tableSlots = tbl_slots,
         staticMBlocks = static_mbs,
         sptEntries = sptMap merged_m,
         bundledFFIMarshalState = bundled_ffi_state

asterius/test/node-compile.hs

@@ -225,5 +225,5 @@ testNodeCompileBoth s m =
 
 main :: IO ()
 main = do
-  m_fib <- decodeFile $ "test" </> "fib" </> "fib.bin"
+  m_fib <- getFile $ "test" </> "fib" </> "fib.bin"
   quickCheck $ testNodeCompileBoth shrinkModule m_fib

asterius/test/nomain.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+import Asterius.Binary.File
+import Asterius.Binary.NameCache
 import Asterius.JSRun.NonMain
-import Data.Binary
 import qualified Data.ByteString.Lazy as LBS
 import Language.JavaScript.Inline.Core
 import System.Environment
@@ -19,7 +20,8 @@ main = do
       "--extra-root-symbol=NoMain_x_closure"
     ]
       <> args
-  m <- decodeFile "test/nomain/NoMain.unlinked.bin"
+  ncu <- newNameCacheUpdater
+  m <- getFile ncu "test/nomain/NoMain.unlinked.bin"
   withJSSession
     defJSSessionOpts
       { nodeExtraArgs = ["--experimental-wasm-return-call"],

stack-profile.yaml

@@ -8,7 +8,7 @@ build:
 
 resolver: lts-15.7
 extra-deps:
-  - https://github.com/tweag/binaryen/archive/32a70339b3f4ecf91e827e8059c5d179ffb76da4.tar.gz
+  - https://github.com/tweag/binaryen/archive/e2eed3661781de680617425b1081a396bc50c504.tar.gz
   - url: https://github.com/tweag/inline-js/archive/f192891283e21f8af9bb4dc07d3b36d59c658e2f.tar.gz
     subdirs:
       - inline-js-core

stack.yaml

@@ -1,6 +1,6 @@
 resolver: lts-15.7
 extra-deps:
-  - https://github.com/tweag/binaryen/archive/32a70339b3f4ecf91e827e8059c5d179ffb76da4.tar.gz
+  - https://github.com/tweag/binaryen/archive/e2eed3661781de680617425b1081a396bc50c504.tar.gz
   - url: https://github.com/tweag/inline-js/archive/f192891283e21f8af9bb4dc07d3b36d59c658e2f.tar.gz
     subdirs:
       - inline-js-core

utils/ghcid.sh

@@ -7,8 +7,10 @@ cd asterius
 stack exec ghci -- \
   -package ghc \
   -Wall \
+  -Wno-overflowed-literals \
   -j \
   -fno-code \
   +RTS -N -A64m -n2m -RTS \
+  $(echo src-types/**/*.hs) \
   $(echo src/**/*.hs) \
   $(echo $(stack path --dist-dir)/build/autogen/**/*.hs)