diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs index 9ec188715d805ffed7282d4756621e20cb0008dd..5a6ff33692e922cfaa174706637bcd8ac8ee01e8 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 7b6f20a2b8362f5f9fe3a0e710d1b5fc27ff7eaa..90c4a45e8dafc941be35093a800e28c934fd7204 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