Implement fully growable Haskell heap for both regular closures & all…

…ocate* invocations #44

asterius/app/ahc-link.hs

@@ -8,7 +8,7 @@ import System.FilePath
 
 parseTask :: Parser Task
 parseTask =
-  (\t i m_wasm m_js m_html m_report m_gv wasm_toolkit dbg ir r m_ns m_with_i ghc_flags export_funcs root_syms ->
+  (\t i m_wasm m_js m_html m_report m_gv wasm_toolkit dbg ir r m_with_i ghc_flags export_funcs root_syms ->
      Task
        { target = t
        , input = i
@@ -21,7 +21,6 @@ parseTask =
        , debug = dbg
        , outputIR = ir || dbg
        , run = r
-       , nurserySize = maybe 512 read m_ns
        , asteriusInstanceCallback =
            fromMaybe
              "i => {\ni.wasmInstance.exports.hs_init();\ni.wasmInstance.exports.main();\n}"
@@ -64,9 +63,6 @@ parseTask =
   switch (long "debug" <> help "Enable debug mode in the runtime") <*>
   switch (long "output-ir" <> help "Output Asterius IR of compiled modules") <*>
   switch (long "run" <> help "Run the compiled module with Node.js") <*>
-  optional
-    (strOption
-       (long "nursery-size" <> help "Nursery size in MBs, defaults to 512.")) <*>
   optional
     (strOption
        (long "asterius-instance-callback" <>

asterius/src/Asterius/Builtins.hs

@@ -665,16 +665,14 @@ initCapability = do
   storeI64 mainCapability (offset_Capability_r + offset_StgRegTable_rCurrentTSO) $
     constI64 0
 
-hsInitFunction BuiltinsOptions {..} =
+hsInitFunction _ =
   runEDSL [] $ do
     initCapability
-    bd_nursery <-
-      call' "allocGroup" [constI64 $ nurseryMBlocks * blocks_per_mblock] I64
-    putLVal hp $ loadI64 bd_nursery offset_bdescr_start
-    putLVal hpLim $
-      bd_nursery `addInt64`
-      constI64
-        (fromIntegral ((mblock_size * nurseryMBlocks) - offset_first_bdescr))
+    bd_nursery <- call' "allocGroup" [constI64 1] I64
+    block_nursery <- i64Local $ loadI64 bd_nursery offset_bdescr_start
+    putLVal hp block_nursery
+    putLVal hpLim $ block_nursery `addInt64` constI64 block_size
+    putLVal hpAlloc (constI64 0)
     putLVal cccs (constI64 0)
     putLVal currentNursery bd_nursery
     storeI64 (getLVal baseReg) offset_StgRegTable_rCurrentAlloc (constI64 0)
@@ -802,7 +800,22 @@ scheduleWaitThreadFunction _ =
           constI64 0
         switchI64 (extendUInt32 (getLVal ret)) $
           const
-            ( [ (ret_HeapOverflow, emit $ emitErrorMessage [] "HeapOverflow")
+            ( [ ( ret_HeapOverflow
+                , do bytes <- i64Local $ getLVal hpAlloc
+                     putLVal hpAlloc $ constI64 0
+                     if'
+                       []
+                       (eqZInt64 bytes)
+                       (emit $ emitErrorMessage [] "HeapOverflow with HpAlloc=0")
+                       mempty
+                     blocks <- i64Local $ bytesToBlocks bytes
+                     bd <- call' "allocGroup" [blocks] I64
+                     block <- i64Local $ loadI64 bd offset_bdescr_start
+                     putLVal currentNursery bd
+                     putLVal hp block
+                     putLVal hpLim $
+                       block `addInt64` (constI64 block_size `mulInt64` blocks)
+                     break' sched_loop_lbl Nothing)
               , (ret_StackOverflow, emit $ emitErrorMessage [] "StackOverflow")
               , (ret_ThreadYielding, break' sched_loop_lbl Nothing)
               , (ret_ThreadBlocked, emit $ emitErrorMessage [] "ThreadBlocked")
@@ -838,7 +851,6 @@ scheduleWaitThreadFunction _ =
                         break' sched_block_lbl Nothing))
               ]
             , emit $ emitErrorMessage [] "Illegal thread return code")
-        break' sched_loop_lbl Nothing
 
 createThreadFunction _ =
   runEDSL [I64] $ do
@@ -909,6 +921,10 @@ createStrictIOThreadFunction _ =
     , symbol "stg_enter_info"
     ]
 
+bytesToBlocks :: Expression -> Expression
+bytesToBlocks bytes =
+  (bytes `addInt64` constI64 (block_size - 1)) `divUInt64` constI64 block_size
+
 allocateFunction BuiltinsOptions {..} =
   runEDSL [I64] $ do
     setReturnTypes [I64]
@@ -917,13 +933,7 @@ allocateFunction BuiltinsOptions {..} =
     if'
       [I64]
       (bytes `geUInt64` constI64 block_size)
-      (do bd <-
-            call'
-              "allocGroup"
-              [ (bytes `addInt64` constI64 (block_size - 1)) `divUInt64`
-                constI64 block_size
-              ]
-              I64
+      (do bd <- call' "allocGroup" [bytesToBlocks bytes] I64
           emit $ loadI64 bd offset_bdescr_free)
       (do if'
             []

asterius/src/Asterius/Main.hs

@@ -60,7 +60,6 @@ data Task = Task
   , input, outputWasm, outputJS, outputHTML :: FilePath
   , outputLinkReport, outputGraphViz :: Maybe FilePath
   , binaryen, debug, outputIR, run :: Bool
-  , nurserySize :: Int
   , asteriusInstanceCallback :: String
   , extraGHCFlags :: [String]
   , exportFunctions, extraRootSymbols :: [AsteriusEntitySymbol]
@@ -146,8 +145,7 @@ ahcLinkMain task@Task {..} = do
        putStrLn $ "[INFO] Loading boot library store from " <> show store_path
        decodeStore store_path
   putStrLn "[INFO] Populating the store with builtin routines"
-  let builtins_opts =
-        defaultBuiltinsOptions {nurseryMBlocks = nurserySize, tracing = debug}
+  let builtins_opts = defaultBuiltinsOptions {tracing = debug}
       !orig_store = builtinsStore builtins_opts <> boot_store
   putStrLn $ "[INFO] Compiling " <> input <> " to Cmm"
   (c, get_ffi_mod) <- addFFIProcessor mempty

docs/ahc-link.md

@@ -10,9 +10,8 @@ ahc-link - Linker for the Asterius compiler
 Usage: ahc-link [--browser] --input ARG [--output-wasm ARG] [--output-js ARG]
                 [--output-html ARG] [--output-link-report ARG]
                 [--output-graphviz ARG] [--binaryen] [--debug] [--output-ir]
-                [--run] [--nursery-size ARG] [--asterius-instance-callback ARG]
-                [--ghc-option ARG] [--export-function ARG]
-                [--extra-root-symbol ARG]
+                [--run] [--asterius-instance-callback ARG] [--ghc-option ARG]
+                [--export-function ARG] [--extra-root-symbol ARG]
   Producing a standalone WebAssembly binary from Haskell
 
 Available options:
@@ -31,7 +30,6 @@ Available options:
   --debug                  Enable debug mode in the runtime
   --output-ir              Output Asterius IR of compiled modules
   --run                    Run the compiled module with Node.js
-  --nursery-size ARG       Nursery size in MBs, defaults to 512.
   --asterius-instance-callback ARG
                            Supply a JavaScript callback expression which will be
                            invoked on the initiated asterius instance. Defaults