mirror of
https://github.com/tweag/asterius.git
synced 2024-10-26 09:21:04 +03:00
Fix blackholing behavior with multi-threading (#493)
This commit is contained in:
parent
82f736073c
commit
2b053f1d8b
@ -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:
|
||||
|
@ -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]
|
||||
|
106
asterius/src/Asterius/Builtins/Blackhole.hs
Normal file
106
asterius/src/Asterius/Builtins/Blackhole.hs
Normal file
@ -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 = []}
|
@ -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)
|
||||
|
@ -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 ->
|
||||
|
@ -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); }
|
||||
|
@ -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"
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user