From 527616e950fd8942c182be903d176f4b9890ee5a Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 26 Mar 2024 14:55:33 +0100
Subject: [PATCH] JS: fix h$appendToHsString implementation (#24495)
h$appendToHsString needs to wrap its argument in an updatable thunk
to behave like unpackAppendCString#. Otherwise if a SingleEntry thunk is
passed, it is stored as-is in a CONS cell, making the resulting list
impossible to deepseq (forcing the thunk doesn't update the contents of
the CONS cell)!
The added test checks that the optimization kicks in and that
h$appendToHsString works as intended.
Fix #24495
---
compiler/GHC/StgToJS/Linker/Utils.hs | 3 +++
compiler/GHC/StgToJS/Rts/Rts.hs | 13 +++++++++++++
rts/js/string.js | 5 ++++-
testsuite/tests/javascript/Makefile | 9 +++++++++
testsuite/tests/javascript/T24495.hs | 22 ++++++++++++++++++++++
testsuite/tests/javascript/T24495.stdout | 2 ++
testsuite/tests/javascript/all.T | 1 +
7 files changed, 54 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/javascript/Makefile
create mode 100644 testsuite/tests/javascript/T24495.hs
create mode 100644 testsuite/tests/javascript/T24495.stdout
diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs
index 7acaadd2e395..de66e96be4ce 100644
--- a/compiler/GHC/StgToJS/Linker/Utils.hs
+++ b/compiler/GHC/StgToJS/Linker/Utils.hs
@@ -191,6 +191,9 @@ genCommonCppDefs profiling = mconcat
-- resumable thunks
, "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n"
+ -- making a thunk
+ , "#define MK_UPD_THUNK(closure) h$c1(h$upd_thunk_e,(closure))\n"
+
-- general deconstruction
, "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n"
, "#define CONSTR_TAG(x) ((x).f.a)\n"
diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs
index 78d43f196b8d..2297ec60bea7 100644
--- a/compiler/GHC/StgToJS/Rts/Rts.hs
+++ b/compiler/GHC/StgToJS/Rts/Rts.hs
@@ -448,6 +448,19 @@ rts_gen s = do
, r4 |= d4
, returnS (app "h$ap_3_3_fast" [])
])
+ , closure (ClosureInfo (TxtI "h$upd_thunk_e") (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ (jVar $ \t -> return $
+ mconcat [t |= closureField1 r1
+ , adjSp' 2
+ , stack .! (sp - 1) |= r1
+ , stack .! sp |= var "h$upd_frame"
+ , closureEntry r1 |= var "h$blackhole"
+ , closureField1 r1 |= var "h$currentThread"
+ , closureField2 r1 |= null_
+ , r1 |= t
+ , returnS (app "h$ap_0_0_fast" [])
+ ]
+ )
-- select first field
, closure (ClosureInfo (global "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar \t -> return $
diff --git a/rts/js/string.js b/rts/js/string.js
index 302ca55aa5c8..4797cb13b5ea 100644
--- a/rts/js/string.js
+++ b/rts/js/string.js
@@ -723,7 +723,10 @@ function h$appendToHsStringA(str, appendTo, cc) {
function h$appendToHsStringA(str, appendTo) {
#endif
var i = str.length - 1;
- var r = appendTo;
+ // we need to make an updatable thunk here
+ // if we embed the given closure in a CONS cell.
+ // (#24495)
+ var r = i == 0 ? appendTo : MK_UPD_THUNK(appendTo);
while(i>=0) {
r = MK_CONS_CC(str.charCodeAt(i), r, cc);
--i;
diff --git a/testsuite/tests/javascript/Makefile b/testsuite/tests/javascript/Makefile
new file mode 100644
index 000000000000..185dc8e117a1
--- /dev/null
+++ b/testsuite/tests/javascript/Makefile
@@ -0,0 +1,9 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T24495:
+ '$(TEST_HC)' $(TEST_HC_OPTS) T24495.hs -v0 -O1 -dsuppress-uniques -ddump-js -ddump-to-file
+ ./T24495
+ # check that the optimization occurred
+ grep -c appendToHsStringA T24495.dump-js
diff --git a/testsuite/tests/javascript/T24495.hs b/testsuite/tests/javascript/T24495.hs
new file mode 100644
index 000000000000..d2fd49312ae0
--- /dev/null
+++ b/testsuite/tests/javascript/T24495.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -O1 #-}
+-- -O1 required to make "rest" thunk SingleEntry
+
+module Main where
+
+import GHC.CString
+import GHC.JS.Prim (JSVal, toJSString)
+
+foo :: Double -> IO ()
+foo x = debugString (toJSString ("2 " ++ s))
+ where
+ x' = if x == 0 then "b" else "c"
+ y' = if x == 0 then "b" else "c"
+ s = "a" ++ x' ++ " " ++ y' ++ "d"
+
+main :: IO ()
+main = foo 0
+
+
+foreign import javascript "((s) => { console.log(s); })"
+ debugString :: JSVal -> IO ()
diff --git a/testsuite/tests/javascript/T24495.stdout b/testsuite/tests/javascript/T24495.stdout
new file mode 100644
index 000000000000..aa4a4fd55696
--- /dev/null
+++ b/testsuite/tests/javascript/T24495.stdout
@@ -0,0 +1,2 @@
+2 ab bd
+2
diff --git a/testsuite/tests/javascript/all.T b/testsuite/tests/javascript/all.T
index d79c01e72ea7..949222d0a296 100644
--- a/testsuite/tests/javascript/all.T
+++ b/testsuite/tests/javascript/all.T
@@ -21,3 +21,4 @@ test('js-mk_tup', extra_files(['test-mk_tup.js']), compile_and_run, ['test-mk_tu
test('T23346', normal, compile_and_run, [''])
test('T22455', normal, compile_and_run, ['-ddisable-js-minifier'])
test('T23565', normal, compile_and_run, [''])
+test('T24495', normal, makefile_test, ['T24495'])
--
GitLab