Implement MVar support

asterius/rts/rts.scheduler.mjs

@@ -19,7 +19,6 @@ export class Scheduler {
     this.lastTid = 0;
     this.tsos = new Map();         // all the TSOs
     this.runQueue = [];            // Runnable TSO IDs
-    this.blockedTSOs = new Set();  // Blocked TSO IDs
     this.completeTSOs = new Set(); // Finished TSO IDs
     this.exports = undefined;
     this.stablePtrManager = stablePtrManager;
@@ -130,7 +129,6 @@ export class Scheduler {
         break;
       }
       case 4: { // ThreadBlocked
-        this.blockedTSOs.add(tid);
 
         const why_blocked = Number(this.memory.i16Load(tso + rtsConstants.offset_StgTSO_why_blocked));
 
@@ -148,14 +146,12 @@ export class Scheduler {
                     // Store return block symbol
                     tso_info.ffiAsyncFunc = this.memory.i64Load(tso + rtsConstants.offset_StgTSO_ffi_func);
 
-                    this.blockedTSOs.delete(tid);
                     this.runQueue.push(tid);
                     this.submitCmdWakeUp();
                   }
               , e => {
                     tso_info.ffiRetErr = e;
                     //console.log(`Thread ${tid}: blocking FFI Promise rejected with ${e.stack}`);
-                    this.blockedTSOs.delete(tid);
                     this.runQueue.push(tid);
                     this.submitCmdWakeUp();
                   }
@@ -170,18 +166,20 @@ export class Scheduler {
               });
             // Wait for the timer blocking promise and then requeue the TSO
             tso_info.blockingPromise.then
-              ( () => { this.blockedTSOs.delete(tid);
-                        this.runQueue.push(tid);
+              ( () => { this.runQueue.push(tid);
                         this.submitCmdWakeUp();
                       }
               , e => { throw new WebAssembly.RuntimeError(`Scheduler: blocking TSO Promise rejected with ${e}`); }
               )
             break;
           }
 
-          case Blocked.NotBlocked:
           case Blocked.OnMVar:
-          case Blocked.OnMVarRead:
+          case Blocked.OnMVarRead: {
+            //console.log(`Thread ${tid}: blocked on MVar`);
+            break;
+          }
+          case Blocked.NotBlocked:
           case Blocked.OnBlackHole:
           case Blocked.OnRead:
           case Blocked.OnWrite:
@@ -393,12 +391,16 @@ export class Scheduler {
   }
 
   /**
-   * Add it into the run-queue
+   * Enqueue the TSO in the run-queue and wake-up the scheduler.
    */
   enqueueTSO(tso) {
     const tid = this.getTSOid(tso);
+
+    // When the TSO has just been created, we need to store its address
     const tso_info = this.tsos.get(tid);
-    tso_info.addr = Number(tso);
+    if (tso_info.addr == -1) {
+      tso_info.addr = Number(tso);
+    }
 
     // Add the thread into the run-queue
     this.runQueue.push(tid);

asterius/src/Asterius/Boot.hs

@@ -108,6 +108,8 @@ bootRTSCmm BootArgs {..} =
                          "rts",
                          "-dcmm-lint",
                          "-O2",
+                         "-DASTERIUS",
+                         "-optc=-DASTERIUS",
                          "-I" <> obj_topdir </> "include"
                          ]
             }

asterius/src/Asterius/Builtins.hs

@@ -143,6 +143,10 @@ rtsAsteriusModule opts =
        <> fromJSArrayFunction opts
        <> threadPausedFunction opts
        <> dirtyMutVarFunction opts
+       <> dirtyMVarFunction opts
+       <> dirtyStackFunction opts
+       <> recordClosureMutatedFunction opts
+       <> tryWakeupThreadFunction opts
        <> raiseExceptionHelperFunction opts
        <> barfFunction opts
        <> getProgArgvFunction opts
@@ -759,7 +763,7 @@ generateWrapperModule m = m
 
 
 
-hsInitFunction, rtsApplyFunction, rtsGetSchedStatusFunction, rtsCheckSchedStatusFunction, scheduleTSOFunction, createThreadFunction, createGenThreadFunction, createIOThreadFunction, createStrictIOThreadFunction, getThreadIdFunction, allocatePinnedFunction, newCAFFunction, stgReturnFunction, getStablePtrWrapperFunction, deRefStablePtrWrapperFunction, freeStablePtrWrapperFunction, rtsMkBoolFunction, rtsMkDoubleFunction, rtsMkCharFunction, rtsMkIntFunction, rtsMkWordFunction, rtsMkPtrFunction, rtsMkStablePtrFunction, rtsGetBoolFunction, rtsGetDoubleFunction, loadI64Function, printI64Function, assertEqI64Function, printF32Function, printF64Function, strlenFunction, memchrFunction, memcpyFunction, memsetFunction, memcmpFunction, fromJSArrayBufferFunction, toJSArrayBufferFunction, fromJSStringFunction, fromJSArrayFunction, threadPausedFunction, dirtyMutVarFunction, raiseExceptionHelperFunction, barfFunction, getProgArgvFunction, suspendThreadFunction, scheduleThreadFunction, scheduleThreadOnFunction, resumeThreadFunction, performMajorGCFunction, performGCFunction, localeEncodingFunction, isattyFunction, fdReadyFunction, rtsSupportsBoundThreadsFunction, readFunction, writeFunction ::
+hsInitFunction, rtsApplyFunction, rtsGetSchedStatusFunction, rtsCheckSchedStatusFunction, scheduleTSOFunction, createThreadFunction, createGenThreadFunction, createIOThreadFunction, createStrictIOThreadFunction, getThreadIdFunction, allocatePinnedFunction, newCAFFunction, stgReturnFunction, getStablePtrWrapperFunction, deRefStablePtrWrapperFunction, freeStablePtrWrapperFunction, rtsMkBoolFunction, rtsMkDoubleFunction, rtsMkCharFunction, rtsMkIntFunction, rtsMkWordFunction, rtsMkPtrFunction, rtsMkStablePtrFunction, rtsGetBoolFunction, rtsGetDoubleFunction, loadI64Function, printI64Function, assertEqI64Function, printF32Function, printF64Function, strlenFunction, memchrFunction, memcpyFunction, memsetFunction, memcmpFunction, fromJSArrayBufferFunction, toJSArrayBufferFunction, fromJSStringFunction, fromJSArrayFunction, threadPausedFunction, dirtyMutVarFunction, dirtyMVarFunction, dirtyStackFunction, recordClosureMutatedFunction, raiseExceptionHelperFunction, barfFunction, getProgArgvFunction, suspendThreadFunction, scheduleThreadFunction, scheduleThreadOnFunction, resumeThreadFunction, performMajorGCFunction, performGCFunction, localeEncodingFunction, isattyFunction, fdReadyFunction, rtsSupportsBoundThreadsFunction, readFunction, writeFunction, tryWakeupThreadFunction ::
      BuiltinsOptions -> AsteriusModule
 
 initCapability :: EDSL ()
@@ -1272,6 +1276,26 @@ dirtyMutVarFunction _ =
       (storeI64 p 0 $ symbol "stg_MUT_VAR_DIRTY_info")
       mempty
 
+dirtyMVarFunction _ =
+  runEDSL "dirty_MVAR" $ do
+    [_basereg,_mvar] <- params [I64,I64]
+    mempty
+
+dirtyStackFunction _ =
+  runEDSL "dirty_STACK" $ do
+    [cap,stack] <- params [I64,I64]
+    dirtySTACK cap stack
+
+recordClosureMutatedFunction _ =
+  runEDSL "recordClosureMutated" $ do
+    [_cap,_closure] <- params [I64,I64]
+    mempty
+
+tryWakeupThreadFunction _ =
+  runEDSL "tryWakeupThread" $ do
+    [_cap, tso] <- params [I64, I64]
+    callImport "__asterius_enqueueTSO" [convertUInt64ToFloat64 tso]
+
 raiseExceptionHelperFunction _ =
   runEDSL "raiseExceptionHelper" $ do
     setReturnTypes [I64]

asterius/test/rts.hs

@@ -4,6 +4,8 @@ import System.Process
 main :: IO ()
 main = do
   args <- getArgs
+  callProcess "ahc-link" $
+    ["--input-hs", "test/rts/MVar.hs", "--run"] <> args
   callProcess "ahc-link" $
     ["--input-hs", "test/rts/FFI.hs", "--run"] <> args
   callProcess "ahc-link" $

asterius/test/rts/MVar.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE LambdaCase #-}
+
+import Asterius.Types
+import Data.Coerce
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad
+import System.Mem
+
+foreign import javascript "console.log(${1})" js_print :: JSVal -> IO ()
+
+printString :: String -> IO ()
+printString s = js_print (coerce (toJSString s))
+
+main :: IO ()
+main = do
+   let ps s = do
+         tid <- myThreadId
+         printString (show tid <> ": " <> s)
+
+   mvar <- newEmptyMVar
+
+   ps "Creating workers"
+
+   forkIO $ do
+      ps "Working..."
+      threadDelay 4000000
+      ps "Writing result"
+      tid <- myThreadId
+      putMVar mvar tid
+
+   forkIO $ do
+      ps "Working..."
+      threadDelay 3000000
+      ps "Writing result"
+      tid <- myThreadId
+      putMVar mvar tid
+
+   ps "Waiting for results"
+
+   v1 <- takeMVar mvar
+   ps ("First result: " <> show v1)
+
+   v2 <- takeMVar mvar
+   ps ("Second result: " <> show v2)
+
+   forkIO $ do
+      v3 <- takeMVar mvar
+      ps ("WAT? " ++ show v3)
+
+   performGC