[Git][ghc/ghc][master] 2 commits: JS: reenable h$appendToHsString optimization (#24495)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Apr 3 00:14:33 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b36ee57b by Sylvain Henry at 2024-04-02T20:13:46-04:00
JS: reenable h$appendToHsString optimization (#24495)
The optimization introducing h$appendToHsString wasn't kicking in
anymore (while it did in 9.8.1) because of the changes introduced in #23270 (7e0c8b3bab30).
This patch reenables the optimization by matching on case-expression, as
done in Cmm for unpackCString# standard thunks.
The test is also T24495 added in the next commits (two commits for ease
of backporting to 9.8).
- - - - -
527616e9 by Sylvain Henry at 2024-04-02T20:13:46-04:00
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
- - - - -
9 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- rts/js/string.js
- + testsuite/tests/javascript/Makefile
- + testsuite/tests/javascript/T24495.hs
- + testsuite/tests/javascript/T24495.stdout
- testsuite/tests/javascript/all.T
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -46,7 +46,6 @@ import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids
-import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
@@ -60,7 +59,6 @@ import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Type hiding (typeSize)
-import GHC.Utils.Encoding
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
@@ -100,22 +98,6 @@ genApp
-> G (JStgStat, ExprResult)
genApp ctx i args
- -- Case: unpackCStringAppend# "some string"# str
- --
- -- Generates h$appendToHsStringA(str, "some string"), which has a faster
- -- decoding loop.
- | [StgLitArg (LitString bs), x] <- args
- , [top] <- concatMap typex_expr (ctxTarget ctx)
- , getUnique i == unpackCStringAppendIdKey
- , d <- utf8DecodeByteString bs
- = do
- prof <- csProf <$> getSettings
- let profArg = if prof then [jCafCCS] else []
- a <- genArg x
- return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
- , ExprInline
- )
-
-- let-no-escape
| Just n <- ctxLneBindingStackSize ctx i
= do
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -60,11 +60,13 @@ import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Unique.FM
import GHC.Types.RepType
+import GHC.Types.Literal
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Builtin.PrimOps
+import GHC.Builtin.Names
import GHC.Core hiding (Var)
import GHC.Core.TyCon
@@ -73,6 +75,7 @@ import GHC.Core.Opt.Arity (isOneShotBndr)
import GHC.Core.Type hiding (typeSize)
import GHC.Utils.Misc
+import GHC.Utils.Encoding
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
@@ -555,6 +558,36 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ctx bnd e at alts l
+ -- For: unpackCStringAppend# "some string"# str
+ -- Generate: h$appendToHsStringA(str, "some string")
+ --
+ -- The latter has a faster decoding loop.
+ --
+ -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we
+ -- need to match the following instead:
+ --
+ -- case "some string"# of b {
+ -- DEFAULT -> unpackCStringAppend# b str
+ -- }
+ --
+ -- Wrinkle: it doesn't kick in when literals are floated out to the top level.
+ --
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , getUnique i == unpackCStringAppendIdKey
+ , [StgVarArg b',x] <- args
+ , bnd == b'
+ , d <- utf8DecodeByteString bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = do
+ prof <- csProf <$> getSettings
+ let profArg = if prof then [jCafCCS] else []
+ a <- genArg x
+ return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
+ , ExprInline
+ )
+
| isInlineExpr e = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
=====================================
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"
=====================================
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 $
=====================================
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;
=====================================
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
=====================================
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 ()
=====================================
testsuite/tests/javascript/T24495.stdout
=====================================
@@ -0,0 +1,2 @@
+2 ab bd
+2
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/817e89362e74b5177c02deee31f16cec862052cc...527616e950fd8942c182be903d176f4b9890ee5a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/817e89362e74b5177c02deee31f16cec862052cc...527616e950fd8942c182be903d176f4b9890ee5a
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/20240402/e0e8670c/attachment-0001.html>
More information about the ghc-commits
mailing list