[WIP] NFData Instance for AsteriusModule

asterius/src/Asterius/NFData/TH.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Asterius.NFData.TH
+  ( genNFData,
+  )
+where
+
+import Control.DeepSeq
+import Data.List (foldl1')
+import Language.Haskell.TH
+
+genNFData :: Name -> Q [Dec]
+genNFData ty = do
+  TyConI dec <- reify ty
+  case dec of
+    DataD [] ((== ty) -> True) [] Nothing cons _
+      | length cons <= 0xFF ->
+        pure
+          [ InstanceD
+              Nothing
+              []
+              (AppT (ConT ''NFData) (ConT ty))
+              [ FunD
+                  'rnf
+                  [ Clause
+                      [ ConP
+                          (dataConName con)
+                          (map VarP vars)
+                      ]
+                      ( NormalB $
+                          if null vars
+                            then ConE '()
+                            else
+                              foldl1'
+                                (\acc x -> AppE (AppE (VarE 'seq) acc) x)
+                                (map (AppE (VarE 'rnf) . VarE) vars)
+                      )
+                      []
+                    | con <- cons,
+                      let vars = [mkName $ "a" <> show j | j <- [1 .. dataConFields con]]
+                  ]
+              ]
+          ]
+    _ -> fail $ "Asterius.NFData.TH.genNFData: " <> show dec
+
+dataConName :: Con -> Name
+dataConName (NormalC n _) = n
+dataConName (RecC n _) = n
+dataConName c = error $ "Asterius.NFData.TH.dataConName: " <> show c
+
+dataConFields :: Con -> Int
+dataConFields (NormalC _ fs) = length fs
+dataConFields (RecC _ fs) = length fs
+dataConFields c = error $ "Asterius.NFData.TH.dataConFields: " <> show c

asterius/src/Asterius/Resolve.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Asterius.Resolve
   ( unresolvedGlobalRegType,
@@ -22,6 +23,7 @@ import Asterius.Types
 import qualified Asterius.Types.SymbolMap as SM
 import qualified Asterius.Types.SymbolSet as SS
 import Asterius.Types.LinkReport
+import Control.DeepSeq
 import qualified Data.ByteString as BS
 import qualified Data.Map.Lazy as LM
 import Foreign
@@ -108,18 +110,19 @@ linkStart ::
   [EntitySymbol] ->
   (AsteriusModule, Module, LinkReport)
 linkStart debug gc_sections verbose_err store root_syms export_funcs =
-  ( merged_m,
-    result_m,
-    mempty
-      { staticsSymbolMap = ss_sym_map,
-        functionSymbolMap = func_sym_map,
-        infoTableSet = makeInfoTableSet merged_m ss_sym_map,
-        Asterius.Types.LinkReport.tableSlots = tbl_slots,
-        staticMBlocks = static_mbs,
-        sptEntries = sptMap merged_m,
-        bundledFFIMarshalState = bundled_ffi_state
-      }
-  )
+  rnf merged_m
+    `seq` ( merged_m,
+            result_m,
+            mempty
+              { staticsSymbolMap = ss_sym_map,
+                functionSymbolMap = func_sym_map,
+                infoTableSet = makeInfoTableSet merged_m ss_sym_map,
+                Asterius.Types.LinkReport.tableSlots = tbl_slots,
+                staticMBlocks = static_mbs,
+                sptEntries = sptMap merged_m,
+                bundledFFIMarshalState = bundled_ffi_state
+              }
+          )
   where
     merged_m0
       | gc_sections = gcSections verbose_err store root_syms export_funcs

asterius/src/Asterius/Types.hs

@@ -53,11 +53,13 @@ where
 
 import Asterius.Binary.Orphans ()
 import Asterius.Binary.TH
+import Asterius.NFData.TH
 import Asterius.Types.EntitySymbol
 import Asterius.Types.SymbolMap (SymbolMap)
 import qualified Asterius.Types.SymbolMap as SM
 import Asterius.Types.SymbolSet (SymbolSet)
 import qualified Asterius.Types.SymbolSet as SS
+import Control.DeepSeq
 import Control.Exception
 import qualified Data.ByteString as BS
 import Data.Data
@@ -609,6 +611,74 @@ instance Semigroup FFIMarshalState where
 instance Monoid FFIMarshalState where
   mempty = FFIMarshalState {ffiImportDecls = mempty, ffiExportDecls = mempty}
 
+-- NFData instances
+
+$(genNFData ''AsteriusCodeGenError)
+
+$(genNFData ''AsteriusStatic)
+
+$(genNFData ''AsteriusStaticsType)
+
+$(genNFData ''AsteriusStatics)
+
+$(genNFData ''AsteriusModule)
+
+$(genNFData ''AsteriusCachedModule)
+
+$(genNFData ''UnresolvedLocalReg)
+
+$(genNFData ''UnresolvedGlobalReg)
+
+$(genNFData ''ValueType)
+
+$(genNFData ''FunctionType)
+
+$(genNFData ''UnaryOp)
+
+$(genNFData ''BinaryOp)
+
+$(genNFData ''Expression)
+
+$(genNFData ''Function)
+
+$(genNFData ''FunctionImport)
+
+$(genNFData ''TableImport)
+
+$(genNFData ''MemoryImport)
+
+$(genNFData ''FunctionExport)
+
+$(genNFData ''FunctionTable)
+
+$(genNFData ''DataSegment)
+
+$(genNFData ''Module)
+
+$(genNFData ''RelooperAddBlock)
+
+$(genNFData ''RelooperAddBranch)
+
+$(genNFData ''RelooperBlock)
+
+$(genNFData ''RelooperRun)
+
+$(genNFData ''FFIValueTypeRep)
+
+$(genNFData ''FFIValueType)
+
+$(genNFData ''FFIFunctionType)
+
+$(genNFData ''FFISafety)
+
+$(genNFData ''FFIImportDecl)
+
+$(genNFData ''FFIExportDecl)
+
+$(genNFData ''FFIMarshalState)
+
+-- Binary instances
+
 $(genBinary ''AsteriusCodeGenError)
 
 $(genBinary ''AsteriusStatic)

asterius/src/Asterius/Types/EntitySymbol.hs

@@ -11,6 +11,7 @@ module Asterius.Types.EntitySymbol
 where
 
 import qualified Binary as GHC
+import Control.DeepSeq
 import qualified Data.ByteString as BS
 import Data.Data
 import Data.String
@@ -21,6 +22,9 @@ newtype EntitySymbol = EntitySymbol GHC.FastString
   deriving newtype (Eq, Ord, Show, IsString, Semigroup, Monoid, GHC.Binary, GHC.Uniquable)
   deriving stock (Data)
 
+instance NFData EntitySymbol where
+  rnf = rwhnf -- TODO: Not entirely sure about this.
+
 -- | Convert an 'EntitySymbol' to a 'BS.ByteString'.
 {-# INLINE entityName #-}
 entityName :: EntitySymbol -> BS.ByteString

asterius/src/Asterius/Types/SymbolMap.hs

@@ -62,6 +62,7 @@ where
 import Asterius.Types.EntitySymbol
 import qualified Asterius.Types.SymbolSet as SS
 import Binary
+import Control.DeepSeq
 import Control.Monad
 import Data.Data
 import qualified Data.IntMap.Lazy as IM
@@ -75,6 +76,9 @@ newtype SymbolMap a = SymbolMap (IM.IntMap (EntitySymbol, a))
   deriving newtype (Eq, Semigroup, Monoid)
   deriving stock (Data)
 
+instance NFData a => NFData (SymbolMap a) where
+  rnf = rwhnf
+
 instance Show a => Show (SymbolMap a) where
   showsPrec d m =
     showParen (d > 10) $

asterius/src/Asterius/Types/SymbolSet.hs

@@ -48,6 +48,7 @@ where
 
 import Asterius.Types.EntitySymbol
 import Binary
+import Control.DeepSeq
 import Control.Monad
 import Data.Coerce
 import Data.Data
@@ -67,6 +68,9 @@ instance Show SymbolSet where
     showParen (p > 10) $
       showString "fromList " . shows (toList s)
 
+instance NFData SymbolSet where
+  rnf = rwhnf
+
 instance Binary SymbolSet where
   put_ bh s =
     put_ bh (size s) *> forM_ (toListSS s) (put_ bh)