Refactor

asterius/rts/rts.constants.mjs

@@ -13,6 +13,7 @@ export const sizeof_first_mblock = 0xfc000;
 export const offset_bdescr_start = 0x0;
 export const offset_bdescr_free = 0x8;
 export const offset_bdescr_link = 0x10;
+export const offset_bdescr_gen_no = 0x28;
 export const offset_bdescr_node = 0x2c;
 export const offset_bdescr_flags = 0x2e;
 export const offset_bdescr_blocks = 0x30;

asterius/src/Asterius/Builtins.hs

@@ -170,11 +170,9 @@ rtsAsteriusModule opts =
     <> fromJSArrayFunction opts
     <> threadPausedFunction opts
     <> dirtyMutVarFunction opts
-    <> dirtyMVarFunction opts
-    <> updateMVarFunction opts
     <> dirtyStackFunction opts
-    <> recordMutableCapFunction opts
-    <> recordClosureMutatedFunction opts
+    <> dirtyTSOFunction opts
+    <> recordMutatedFunction opts
     <> tryWakeupThreadFunction opts
     <> raiseExceptionHelperFunction opts
     <> barfFunction opts
@@ -937,11 +935,9 @@ hsInitFunction,
   fromJSArrayFunction,
   threadPausedFunction,
   dirtyMutVarFunction,
-  dirtyMVarFunction,
-  updateMVarFunction,
   dirtyStackFunction,
-  recordMutableCapFunction,
-  recordClosureMutatedFunction,
+  dirtyTSOFunction,
+  recordMutatedFunction,
   raiseExceptionHelperFunction,
   barfFunction,
   getProgArgvFunction,
@@ -1018,26 +1014,6 @@ rtsCheckSchedStatusFunction _ = runEDSL "rts_checkSchedStatus" $ do
     $ emit
     $ emitErrorMessage [] "IllegalSchedulerStatusCode"
 
-dirtyTSO :: Expression -> Expression -> EDSL ()
-dirtyTSO _ tso =
-  if'
-    []
-    (eqZInt32 $ loadI32 tso offset_StgTSO_dirty)
-    (do
-      storeI32 tso offset_StgTSO_dirty $ constI32 1
-      recordMutated tso)
-    mempty
-
-dirtySTACK :: Expression -> Expression -> EDSL ()
-dirtySTACK _ stack =
-  if'
-    []
-    (eqZInt32 $ loadI32 stack offset_StgStack_dirty)
-    (do
-      storeI32 stack offset_StgStack_dirty $ constI32 1
-      recordMutated stack)
-    mempty
-
 -- `_scheduleTSO(tso,func)` executes the given tso starting at the given
 -- function
 scheduleTSOFunction BuiltinsOptions {} = runEDSL "scheduleTSO" $ do
@@ -1052,8 +1028,8 @@ scheduleTSOFunction BuiltinsOptions {} = runEDSL "scheduleTSO" $ do
     tso
   storeI32 mainCapability offset_Capability_interrupt $ constI32 0
   storeI32 mainCapability offset_Capability_idle $ constI32 0
-  dirtyTSO mainCapability tso
-  dirtySTACK mainCapability (loadI64 tso offset_StgTSO_stackobj)
+  dirtyTSO tso
+  dirtySTACK (loadI64 tso offset_StgTSO_stackobj)
   -- execute the TSO (using stgRun trampolining machinery)
   stgRun func
   -- indicate in the Capability that we are not running anything
@@ -1448,41 +1424,63 @@ threadPausedFunction _ = runEDSL "threadPaused" $ do
   _ <- params [I64, I64]
   pure ()
 
-recordMutated :: Expression -> EDSL ()
+-- | Helper functions for the write barrier.
+-- | See also Cmm.h, Capability.h, Updates.h, PrimOps.cmm.
+
 recordMutated p =
   callImport "__asterius_recordMutated" [convertUInt64ToFloat64 p]
 
-dirtyMutVarFunction _ = runEDSL "dirty_MUT_VAR" $ do
-  [_, p] <- params [I64, I64]
-  if' [] (loadI64 p 0 `eqInt64` symbol "stg_MUT_VAR_CLEAN_info")
+recordMutatedFunction _ =
+  runEDSL "recordMutated" $ param I64 >>= recordMutated
+
+recordMutatedCheckGen p = do
+  -- Duplicate of recordMutatedCheckGen macro in Cmm.h
+  -- Records the closure at p as mutated,
+  -- but only after checking that it belong
+  -- to the old generation.
+  -- 1. get block descriptor
+  let mb = p `subInt64` (p `andInt64` (constI64 $ mblock_size - 1))
+  let bd = mb `addInt64` constI64 offset_first_bdescr
+  -- 2. get generation number
+  let gen_no = loadI16 bd offset_bdescr_gen_no
+  if' [] (eqZInt32 $ gen_no)
+    mempty
+    (recordMutated p)
+
+dirtyTSO tso =
+  if'
+    []
+    (eqZInt32 $ loadI32 tso offset_StgTSO_dirty)
     (do
-      storeI64 p 0 $ symbol "stg_MUT_VAR_DIRTY_info"
-      recordMutated p)
+      storeI32 tso offset_StgTSO_dirty $ constI32 1
+      recordMutatedCheckGen tso)
     mempty
 
-dirtyMVarFunction _ = runEDSL "dirty_MVAR" $ do
-  [reg, p, old] <- params [I64, I64, I64]
-  call "update_MVAR" [reg, p, old]
+dirtyTSOFunction _ =
+  runEDSL "dirty_TSO" $ param I64 >>= dirtyTSO
 
-updateMVarFunction _ = runEDSL "update_MVAR" $ do 
-  [_, p, _old] <- params [I64, I64, I64]
-  if' [] (loadI64 p 0 `eqInt64` symbol "stg_MVAR_CLEAN_info")
+dirtySTACK stack =
+  if'
+    []
+    (eqZInt32 $ loadI32 stack offset_StgStack_dirty)
     (do
-      storeI64 p 0 $ symbol "stg_MVAR_DIRTY_info"
-      recordMutated p)
+      storeI32 stack offset_StgStack_dirty $ constI32 1
+      recordMutatedCheckGen stack)
     mempty
 
-dirtyStackFunction _ = runEDSL "dirty_STACK" $ do
-  [cap, stack] <- params [I64, I64]
-  dirtySTACK cap stack
-
-recordClosureMutatedFunction _ = runEDSL "recordClosureMutated" $ do
-  [_cap, p] <- params [I64, I64]
-  recordMutated p
+dirtyStackFunction _ =
+  runEDSL "dirty_STACK" $ param I64 >>= dirtySTACK
 
-recordMutableCapFunction _ = runEDSL "recordMutableCap" $ do
-  [p, _cap, _gen] <- params [I64, I64, I64]
-  recordMutated p
+dirtyMutVarFunction _ = runEDSL "dirty_MUT_VAR" $ do
+  -- duplicate of dirty_MUT_VAR macro in Cmm.h
+  [_, p] <- params [I64, I64]
+  if'
+    []
+    (loadI64 p 0 `eqInt64` symbol "stg_MUT_VAR_CLEAN_info")
+    (do
+      storeI64 p 0 $ symbol "stg_MUT_VAR_DIRTY_info"
+      recordMutatedCheckGen p)
+    mempty
 
 tryWakeupThreadFunction _ = runEDSL "tryWakeupThread" $ do
   [_cap, tso] <- params [I64, I64]

asterius/src/Asterius/JSGen/Constants.hs

@@ -45,6 +45,8 @@ rtsConstants =
       intHex offset_bdescr_free,
       ";\nexport const offset_bdescr_link = ",
       intHex offset_bdescr_link,
+      ";\nexport const offset_bdescr_gen_no = ",
+      intHex offset_bdescr_gen_no,
       ";\nexport const offset_bdescr_node = ",
       intHex offset_bdescr_node,
       ";\nexport const offset_bdescr_flags = ",