diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs index 7acaadd2e395abe1fecf4e3a70cca534ba1e0de1..de66e96be4ce38407fe928c743c6b995bf7de8a8 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 78d43f196b8d787e0e8508a371da36c4aa9ed07e..2297ec60bea77b067a983c01c7a16af17a207a59 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 302ca55aa5c8aa07e744e2ce2a2f36f02285bccd..4797cb13b5eaaa370082589dd42e737611141adc 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 0000000000000000000000000000000000000000..185dc8e117a12831205c74b0499dab4f97484682 --- /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 0000000000000000000000000000000000000000..d2fd49312ae089718e6531e49e8015eb4e47efd0 --- /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 0000000000000000000000000000000000000000..aa4a4fd556966387f1fdfcfbe98db0eb98cd4682 --- /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 d79c01e72ea7e3080de8173e920c46b45f95a4f2..949222d0a2965ced498a20fffb0921336a4e67d8 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'])