[Git][ghc/ghc][wip/T23479] JS: Re-add optimization for literal strings (fixes #23479)

[Serge S. Gulin (@gulin.serge)]

Serge S. Gulin pushed to branch wip/T23479 at Glasgow Haskell Compiler / GHC


Commits:
12e72c68 by Serge S. Gulin at 2024-08-24T00:45:08+03:00
JS: Re-add optimization for literal strings (fixes #23479)

- - - - -


1 changed file:

- compiler/GHC/StgToJS/Apply.hs


Changes:

=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -51,6 +52,7 @@ import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.CostCentre
 import GHC.Types.RepType (mightBeFunTy)
+import GHC.Types.Name (nameModule_maybe, OccName (occNameFS), nameOccName)
 
 import GHC.Stg.Syntax
 
@@ -60,6 +62,8 @@ import GHC.Core.TyCon
 import GHC.Core.DataCon
 import GHC.Core.Type hiding (typeSize)
 
+import GHC.Unit.Module (moduleNameFS, GenModule (moduleName), unitIdString, moduleUnitId)
+
 import GHC.Utils.Misc
 import GHC.Utils.Monad
 import GHC.Utils.Panic
@@ -69,6 +73,7 @@ import GHC.Data.FastString
 import qualified Data.Bits as Bits
 import Data.Monoid
 import Data.Array
+import Data.List (isPrefixOf)
 
 -- | Pre-generated functions for fast Apply.
 -- These are bundled with the RTS.
@@ -86,6 +91,13 @@ rtsApply cfg = jBlock
      , moveRegs2
      ]
 
+matchVarName :: String -> FastString -> FastString -> Id -> Bool
+matchVarName pkg modu occ (idName -> n)
+  | Just m <- nameModule_maybe n =
+    occ  == occNameFS (nameOccName n) &&
+    modu == moduleNameFS (moduleName m) &&
+    pkg `isPrefixOf` unitIdString (moduleUnitId m)
+  | otherwise = False
 
 -- | Generate an application of some args to an Id.
 --
@@ -98,6 +110,13 @@ genApp
   -> [StgArg]
   -> G (JStgStat, ExprResult)
 genApp ctx i args
+    -- special cases for JSString literals
+    -- we could handle unpackNBytes# here, but that's probably not common
+    -- enough to warrant a special case
+    | [StgVarArg v] <- args
+    , [top] <- concatMap typex_expr (ctxTarget ctx)
+    , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i
+    = (,ExprInline) . (|=) top . app "h$decodeUtf8z" <$> varsForId v
 
     -- let-no-escape
     | Just n <- ctxLneBindingStackSize ctx i



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12e72c6827c312ac3d7c489a9af48aee7f302e3f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12e72c6827c312ac3d7c489a9af48aee7f302e3f
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/20240823/1c80e529/attachment-0001.html>