summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2023-04-18 18:19:46 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-04-19 20:04:35 -0400
commitd442ac053f9ac7dbcc32318802daf686f377fe3d (patch)
tree0052ad88f5ba0c63ed53cbf29a049a5c462034c6
parentdf1a581188694479a583270548896245fc23b525 (diff)
downloadhaskell-d442ac053f9ac7dbcc32318802daf686f377fe3d.tar.gz
JS: fix thread-related primops
-rw-r--r--compiler/GHC/StgToJS/Prim.hs2
-rw-r--r--libraries/base/tests/all.T3
-rw-r--r--libraries/base/tests/listThreads1.hs6
-rw-r--r--libraries/base/tests/listThreads1.stdout1
-rw-r--r--rts/js/mem.js8
-rw-r--r--rts/js/thread.js30
6 files changed, 36 insertions, 14 deletions
diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs
index 188d6167fa..94fbd7395d 100644
--- a/compiler/GHC/StgToJS/Prim.hs
+++ b/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
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index fbe628793c..d5eba40dff 100644
--- a/libraries/base/tests/all.T
+++ b/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, [''])
diff --git a/libraries/base/tests/listThreads1.hs b/libraries/base/tests/listThreads1.hs
new file mode 100644
index 0000000000..97e852b3ee
--- /dev/null
+++ b/libraries/base/tests/listThreads1.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import GHC.Conc.Sync
+
+main :: IO ()
+main = listThreads >>= print
diff --git a/libraries/base/tests/listThreads1.stdout b/libraries/base/tests/listThreads1.stdout
new file mode 100644
index 0000000000..d9ec042039
--- /dev/null
+++ b/libraries/base/tests/listThreads1.stdout
@@ -0,0 +1 @@
+[ThreadId 1]
diff --git a/rts/js/mem.js b/rts/js/mem.js
index 3dcdc7979f..2f91b80798 100644
--- a/rts/js/mem.js
+++ b/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);
- }
-}
diff --git a/rts/js/thread.js b/rts/js/thread.js
index 081749a015..1c51fa2569 100644
--- a/rts/js/thread.js
+++ b/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;