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 (7e0c8b3b).
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

@@ -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