From b36ee57bfbecc628b7f0919e1e59b7066495034f Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 26 Mar 2024 17:36:47 +0100
Subject: [PATCH] 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).
---
compiler/GHC/StgToJS/Apply.hs | 18 ------------------
compiler/GHC/StgToJS/Expr.hs | 33 +++++++++++++++++++++++++++++++++
2 files changed, 33 insertions(+), 18 deletions(-)
diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs
index 9ec188715d80..5a6ff33692e9 100644
--- a/compiler/GHC/StgToJS/Apply.hs
+++ b/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
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
index 7b6f20a2b836..90c4a45e8daf 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ b/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
--
GitLab