[Git][ghc/ghc][master] JS: fix thread-related primops

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00
JS: fix thread-related primops

- - - - -


6 changed files:

- compiler/GHC/StgToJS/Prim.hs
- libraries/base/tests/all.T
- + libraries/base/tests/listThreads1.hs
- + libraries/base/tests/listThreads1.stdout
- rts/js/mem.js
- rts/js/thread.js


Changes:

=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -925,7 +925,7 @@ genPrim prof bound ty op = case op of
   IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_
   NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing
   ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]
-  ListThreadsOp  -> \[r] [] -> PrimInline $ r |= var "h$threads"
+  ListThreadsOp  -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" []
   GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]
   LabelThreadOp    -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
 


=====================================
libraries/base/tests/all.T
=====================================
@@ -294,6 +294,7 @@ test('T19719', normal, compile_and_run, [''])
 test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring'])
 test('T22816', normal, compile_and_run, [''])
 test('trace', normal, compile_and_run, [''])
-test('listThreads', js_broken(22261), compile_and_run, [''])
+test('listThreads', normal, compile_and_run, [''])
+test('listThreads1', normal, compile_and_run, [''])
 test('inits1tails1', normal, compile_and_run, [''])
 test('CLC149', normal, compile, [''])


=====================================
libraries/base/tests/listThreads1.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import GHC.Conc.Sync
+
+main :: IO ()
+main = listThreads >>= print


=====================================
libraries/base/tests/listThreads1.stdout
=====================================
@@ -0,0 +1 @@
+[ThreadId 1]


=====================================
rts/js/mem.js
=====================================
@@ -1455,11 +1455,3 @@ function h$pext64(src_b, src_a, mask_b, mask_a) {
  }
  RETURN_UBX_TUP2(dst_b, dst_a);
 }
-
-function h$getThreadLabel(t) {
-  if (t.label) {
-    RETURN_UBX_TUP2(1, t.label);
-  } else {
-    RETURN_UBX_TUP2(0, 0);
-  }
-}


=====================================
rts/js/thread.js
=====================================
@@ -106,8 +106,8 @@ function h$Thread() {
 #endif
 }
 
-function h$rts_getThreadId(t) {
-  return t.tid;
+function h$rts_getThreadId(t) { // returns a CULLong
+  RETURN_UBX_TUP2((t.tid / Math.pow(2,32))>>>0, (t.tid & 0xFFFFFFFF)>>>0);
 }
 
 function h$cmp_thread(t1,t2) {
@@ -121,13 +121,35 @@ function h$threadString(t) {
   if(t === null) {
     return "<no thread>";
   } else if(t.label) {
-    var str = h$decodeUtf8z(t.label[0], t.label[1]);
+    var str = h$decodeUtf8z(t.label, 0);
     return str + " (" + t.tid + ")";
   } else {
     return (""+t.tid);
   }
 }
 
+function h$getThreadLabel(t) {
+  if (t.label) {
+    RETURN_UBX_TUP2(1, t.label);
+  } else {
+    RETURN_UBX_TUP2(0, 0);
+  }
+}
+
+function h$listThreads() {
+  var r = h$newArray(0,null);
+
+  if (h$currentThread) r.push(h$currentThread);
+
+  var threads_iter = h$threads.iter();
+  while ((t = threads_iter()) !== null) r.push(t);
+
+  var blocked_iter = h$blocked.iter();
+  while ((t = blocked_iter.next()) !== null) r.push(t);
+
+  return r;
+}
+
 function h$fork(a, inherit) {
   h$r1 = h$forkThread(a, inherit);
   return h$yield();
@@ -1134,7 +1156,7 @@ function h$main(a) {
   t.stack[8] = a;
   t.stack[9] = h$return;
   t.sp = 9;
-  t.label = [h$encodeUtf8("main"), 0];
+  t.label = h$encodeUtf8("main");
   h$wakeupThread(t);
   h$startMainLoop();
   return t;



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d442ac053f9ac7dbcc32318802daf686f377fe3d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d442ac053f9ac7dbcc32318802daf686f377fe3d
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230419/0fa8b67f/attachment-0001.html>