Fix blackholing behavior with multi-threading (#493)

.ghcid

@@ -0,0 +1 @@
+--command="utils/ghcid.sh"

asterius/rts/rts.scheduler.mjs

@@ -185,13 +185,13 @@ export class Scheduler {
             break;
           }
 
+          case Blocked.OnBlackHole:
           case Blocked.OnMVar:
           case Blocked.OnMVarRead: {
             //console.log(`Thread ${tid}: blocked on MVar`);
             break;
           }
           case Blocked.NotBlocked:
-          case Blocked.OnBlackHole:
           case Blocked.OnRead:
           case Blocked.OnWrite:
           case Blocked.OnSTM:

asterius/src/Asterius/Builtins.hs

@@ -18,6 +18,7 @@ module Asterius.Builtins
   )
 where
 
+import Asterius.Builtins.Blackhole
 import Asterius.Builtins.CMath
 import Asterius.Builtins.Hashable
 import Asterius.Builtins.Main
@@ -194,6 +195,7 @@ rtsAsteriusModule opts =
     -- the module wrapped by using `generateWrapperModule`.
     <> generateRtsExternalInterfaceModule opts
     <> generateWrapperModule (generateRtsExternalInterfaceModule opts)
+    <> blackholeCBits
     <> smCBits
     <> generateWrapperModule smCBits
     <> cmathCBits
@@ -1219,9 +1221,6 @@ rtsMkJSValFunction :: BuiltinsOptions -> AsteriusModule
 rtsMkJSValFunction opts =
   rtsMkHelper opts "rts_mkJSVal" "base_AsteriusziPrim_JSVal_con_info"
 
-unTagClosure :: Expression -> Expression
-unTagClosure p = p `andInt64` constI64 0xFFFFFFFFFFFFFFF8
-
 rtsGetBoolFunction :: BuiltinsOptions -> AsteriusModule
 rtsGetBoolFunction _ = runEDSL "rts_getBool" $ do
   setReturnTypes [I64]

asterius/src/Asterius/Builtins/Blackhole.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Asterius.Builtins.Blackhole
+  ( blackholeCBits,
+  )
+where
+
+import Asterius.EDSL
+import Asterius.Types
+import qualified Data.ByteString.Short as SBS
+import Data.List
+import Language.Haskell.GHC.Toolkit.Constants
+
+blackholeCBits :: AsteriusModule
+blackholeCBits = messageBlackHole <> updateThunk
+
+messageBlackHole :: AsteriusModule
+messageBlackHole = runEDSL "messageBlackHole" $ do
+  setReturnTypes [I64]
+  [_, msg] <- params [I64, I64]
+  bh <- i64Local $ unTagClosure $ loadI64 msg offset_MessageBlackHole_bh
+  p <- i64Local $ unTagClosure $ loadI64 bh offset_StgInd_indirectee
+  info <- i64Local $ loadI64 p 0
+  if'
+    []
+    (checkSymbol info ["stg_TSO_info"])
+    ( do
+        storeI64 msg offset_MessageBlackHole_link $
+          symbol "stg_END_TSO_QUEUE_closure"
+        bq <-
+          call'
+            "allocate"
+            [ mainCapability,
+              constI64 $ roundup_bytes_to_words sizeof_StgBlockingQueue
+            ]
+            I64
+        storeI64 bq 0 $ symbol "stg_BLOCKING_QUEUE_DIRTY_info"
+        storeI64 bq offset_StgBlockingQueue_link $
+          symbol "stg_END_TSO_QUEUE_closure"
+        storeI64 bq offset_StgBlockingQueue_bh bh
+        storeI64 bq offset_StgBlockingQueue_owner p
+        storeI64 bq offset_StgBlockingQueue_queue msg
+        storeI64 bh offset_StgInd_indirectee bq
+    )
+    ( if'
+        []
+        ( checkSymbol
+            info
+            ["stg_BLOCKING_QUEUE_CLEAN_info", "stg_BLOCKING_QUEUE_DIRTY_info"]
+        )
+        ( do
+            let bq = p
+            storeI64 msg offset_MessageBlackHole_link $
+              loadI64 bq offset_StgBlockingQueue_queue
+            storeI64 bq offset_StgBlockingQueue_queue msg
+        )
+        (barf "messageBlackHole: weird blackhole")
+    )
+  emit $ constI64 1
+
+updateThunk :: AsteriusModule
+updateThunk = runEDSL "updateThunk" $ do
+  [cap, tso, thunk, val] <- params [I64, I64, I64, I64]
+  thunk_info <- i64Local $ loadI64 thunk 0
+  if'
+    []
+    ( checkSymbol
+        thunk_info
+        ["__stg_EAGER_BLACKHOLE_info", "stg_CAF_BLACKHOLE_info"]
+    )
+    (pure ())
+    (barf "updateThunk: weird thunk")
+  bq <- i64Local $ unTagClosure $ loadI64 thunk offset_StgInd_indirectee
+  if'
+    []
+    ( checkSymbol
+        (loadI64 bq 0)
+        ["stg_BLOCKING_QUEUE_CLEAN_info", "stg_BLOCKING_QUEUE_DIRTY_info"]
+    )
+    (pure ())
+    (barf "updateThunk: weird thunk payload")
+  if'
+    []
+    (tso `eqInt64` loadI64 bq offset_StgBlockingQueue_owner)
+    (pure ())
+    (barf "updateThunk: not my thunk")
+  storeI64 thunk 0 $ symbol "stg_BLACKHOLE_info"
+  storeI64 thunk offset_StgInd_indirectee val
+  msg_p <- i64MutLocal
+  let msg = getLVal msg_p
+  putLVal msg_p $ loadI64 bq offset_StgBlockingQueue_queue
+  whileLoop (msg `neInt64` symbol "stg_END_TSO_QUEUE_closure") $ do
+    blocked_tso <- i64Local $ loadI64 msg offset_MessageBlackHole_tso
+    if'
+      []
+      (checkSymbol (loadI64 blocked_tso 0) ["stg_TSO_info"])
+      (pure ())
+      (barf "updateThunk: weird queued TSO")
+    call "tryWakeupThread" [cap, blocked_tso]
+    putLVal msg_p $ loadI64 msg offset_MessageBlackHole_link
+
+checkSymbol :: Expression -> [AsteriusEntitySymbol] -> Expression
+checkSymbol e syms = foldl1' orInt32 $ map ((e `eqInt64`) . symbol) syms
+
+barf :: SBS.ShortByteString -> EDSL ()
+barf msg = emit Barf {barfMessage = msg, barfReturnTypes = []}

asterius/src/Asterius/Builtins/Hashable.hs

@@ -19,7 +19,7 @@ hashableFNVHash = runEDSL "hashable_fnv_hash" $ do
   putLVal hash salt
   i <- i64MutLocal
   putLVal i $ constI64 0
-  whileLoop [] (getLVal i `ltUInt64` len) $ do
+  whileLoop (getLVal i `ltUInt64` len) $ do
     putLVal hash $
       ( getLVal hash
           `xorInt64` extendUInt32 (loadI8 (str `addInt64` getLVal i) 0)

asterius/src/Asterius/EDSL.hs

@@ -50,6 +50,7 @@ module Asterius.EDSL
     storeI8,
     storeF64,
     storeF32,
+    unTagClosure,
     call,
     call',
     callImport,
@@ -316,6 +317,9 @@ storeF64 bp o = putLVal $ pointerF64 bp o
 storeF32 :: Expression -> Int -> Expression -> EDSL ()
 storeF32 bp o = putLVal $ pointerF32 bp o
 
+unTagClosure :: Expression -> Expression
+unTagClosure p = p `andInt64` constI64 0xFFFFFFFFFFFFFFF8
+
 call :: AsteriusEntitySymbol -> [Expression] -> EDSL ()
 call f xs = emit Call {target = f, operands = xs, callReturnTypes = []}
 
@@ -412,9 +416,9 @@ if' vts cond t f = do
 break' :: Label -> Maybe Expression -> EDSL ()
 break' (Label lbl) cond = emit Break {name = lbl, breakCondition = cond}
 
-whileLoop :: [ValueType] -> Expression -> EDSL () -> EDSL ()
-whileLoop vts cond body =
-  loop' vts $ \lbl -> if' vts cond (body *> break' lbl Nothing) mempty
+whileLoop :: Expression -> EDSL () -> EDSL ()
+whileLoop cond body =
+  loop' [] $ \lbl -> if' [] cond (body *> break' lbl Nothing) mempty
 
 switchI64 :: Expression -> (EDSL () -> ([(Int, EDSL ())], EDSL ())) -> EDSL ()
 switchI64 cond make_clauses = block' [] $ \switch_lbl ->

ghc-toolkit/cbits/ghc_constants.c

@@ -123,6 +123,23 @@ HsInt offset_Capability_free_trec_headers() {
 HsInt offset_Capability_transaction_tokens() {
   return offsetof(Capability, transaction_tokens);
 }
+
+HsInt sizeof_MessageBlackHole() {
+  return sizeof(MessageBlackHole);
+}
+
+HsInt offset_MessageBlackHole_link() {
+  return offsetof(MessageBlackHole, link);
+}
+
+HsInt offset_MessageBlackHole_tso() {
+  return offsetof(MessageBlackHole, tso);
+}
+
+HsInt offset_MessageBlackHole_bh() {
+  return offsetof(MessageBlackHole, bh);
+}
+
 HsInt sizeof_StgAP() { return sizeof(StgAP); }
 
 HsInt offset_StgAP_arity() { return offsetof(StgAP, arity); }
@@ -147,6 +164,26 @@ HsInt offset_StgArrBytes_bytes() { return offsetof(StgArrBytes, bytes); }
 
 HsInt offset_StgArrBytes_payload() { return offsetof(StgArrBytes, payload); }
 
+HsInt sizeof_StgBlockingQueue() {
+  return sizeof(StgBlockingQueue);
+}
+
+HsInt offset_StgBlockingQueue_link() {
+  return offsetof(StgBlockingQueue, link);
+}
+
+HsInt offset_StgBlockingQueue_bh() {
+  return offsetof(StgBlockingQueue, bh);
+}
+
+HsInt offset_StgBlockingQueue_owner() {
+  return offsetof(StgBlockingQueue, owner);
+}
+
+HsInt offset_StgBlockingQueue_queue() {
+  return offsetof(StgBlockingQueue, queue);
+}
+
 HsInt sizeof_StgClosure() { return sizeof(StgClosure); }
 
 HsInt offset_StgClosure_payload() { return offsetof(StgClosure, payload); }

ghc-toolkit/src/Language/Haskell/GHC/Toolkit/Constants.hs

@@ -118,6 +118,14 @@ foreign import ccall unsafe "offset_Capability_free_trec_headers"
 foreign import ccall unsafe "offset_Capability_transaction_tokens"
   offset_Capability_transaction_tokens :: Int
 
+foreign import ccall unsafe "sizeof_MessageBlackHole" sizeof_MessageBlackHole :: Int
+
+foreign import ccall unsafe "offset_MessageBlackHole_link" offset_MessageBlackHole_link :: Int
+
+foreign import ccall unsafe "offset_MessageBlackHole_tso" offset_MessageBlackHole_tso :: Int
+
+foreign import ccall unsafe "offset_MessageBlackHole_bh" offset_MessageBlackHole_bh :: Int
+
 foreign import ccall unsafe "sizeof_StgAP" sizeof_StgAP :: Int
 
 foreign import ccall unsafe "offset_StgAP_arity" offset_StgAP_arity :: Int
@@ -147,6 +155,16 @@ foreign import ccall unsafe "offset_StgArrBytes_bytes"
 foreign import ccall unsafe "offset_StgArrBytes_payload"
   offset_StgArrBytes_payload :: Int
 
+foreign import ccall unsafe "sizeof_StgBlockingQueue" sizeof_StgBlockingQueue :: Int
+
+foreign import ccall unsafe "offset_StgBlockingQueue_link" offset_StgBlockingQueue_link :: Int
+
+foreign import ccall unsafe "offset_StgBlockingQueue_bh" offset_StgBlockingQueue_bh :: Int
+
+foreign import ccall unsafe "offset_StgBlockingQueue_owner" offset_StgBlockingQueue_owner :: Int
+
+foreign import ccall unsafe "offset_StgBlockingQueue_queue" offset_StgBlockingQueue_queue :: Int
+
 foreign import ccall unsafe "sizeof_StgClosure" sizeof_StgClosure :: Int
 
 foreign import ccall unsafe "offset_StgClosure_payload"

utils/ghcid.sh

@@ -4,4 +4,11 @@ shopt -s globstar
 
 cd asterius
 
-ghcid --command="stack exec ghci -- -package ghc -Wall -j -fno-code +RTS -N -A64m -n2m -RTS $(echo src/**/*.hs) $(echo $(stack path --dist-dir)/build/autogen/**/*.hs)"
+stack exec ghci -- \
+  -package ghc \
+  -Wall \
+  -j \
+  -fno-code \
+  +RTS -N -A64m -n2m -RTS \
+  $(echo src/**/*.hs) \
+  $(echo $(stack path --dist-dir)/build/autogen/**/*.hs)

utils/readme.md

@@ -8,11 +8,12 @@ These scripts are meant to be called at the project root directory.
 
 * `utils/clean.sh`: Clean up the `ghc-toolkit` and `asterius` packages, removing
   the source & compiled objects of the boot libs.
-* `utils/ghcid.sh`: Call `ghcid` on `asterius`. Modify the script to add the
-  source of an executable/test target when needed. This doesn't require a
-  previous boot, but does require a `stack build` of `asterius`, even if it
-  fails midway, since it treats the auto-generated `Paths_asterius.hs` as an
-  input source file as well.
+* `utils/ghcid.sh`: The script used by `ghcid` for `asterius`; do not run it
+  directly, instead just run `ghcid` from the project root directory. Modify the
+  script to add the source of an executable/test target when needed. This
+  doesn't require a previous boot, but does require a `stack build` of
+  `asterius`, even if it fails midway, since it treats the auto-generated
+  `Paths_asterius.hs` as an input source file as well.
 * `utils/reboot.sh`: Do the cleanup, rebuild and reboot, using all CPU cores. If
   you touch the source of boot libs in `ghc-toolkit/` or modify the IR/codegen
   of `asterius`, the boot cache may be out-of-sync so you need to run this