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

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

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


Commits:
4d49f47b by Serge S. Gulin at 2024-08-25T22:21:09+03:00
JS: Re-add optimization for literal strings in genApp (fixes #23479)

Based on https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/

- - - - -


6 changed files:

- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Symbols.hs
- testsuite/tests/javascript/Makefile
- + testsuite/tests/javascript/T23479.hs
- + testsuite/tests/javascript/T23479.stdout
- testsuite/tests/javascript/all.T


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,23 @@ genApp
   -> [StgArg]
   -> G (JStgStat, ExprResult)
 genApp ctx i args
+    -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876
+    -- Comment by Luite Stegeman <luite.stegeman at iohk.io>
+    -- Special cases for JSString literals.
+    -- We could handle unpackNBytes# here, but that's probably not common
+    -- enough to warrant a special case.
+    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978
+    -- Comment by Jeffrey Young  <jeffrey.young at iohk.io>
+    -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal,
+    -- if so then we convert the unsafeUnpack to a call to h$decode.
+    | [StgVarArg v] <- args
+    , matchVarName "ghc-internal" "GHC.Internal.JS.Prim" "unsafeUnpackJSStringUtf8##" i
+    -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588
+    -- Comment by Josh Meredith  <josh.meredith at iohk.io>
+    -- `typex_expr` can throw an error for certain bindings so it's important
+    -- that this condition comes after matching on the function name
+    , [top] <- concatMap typex_expr (ctxTarget ctx)
+    = (,ExprInline) . (|=) top . app hdDecodeUtf8Z <$> varsForId v
 
     -- let-no-escape
     | Just n <- ctxLneBindingStackSize ctx i


=====================================
compiler/GHC/StgToJS/Symbols.hs
=====================================
@@ -1212,3 +1212,8 @@ hdStlStr = fsLit "h$stl"
 
 hdStiStr :: FastString
 hdStiStr = fsLit "h$sti"
+
+------------------------------ Pack/Unpack --------------------------------------------
+
+hdDecodeUtf8Z :: FastString
+hdDecodeUtf8Z = fsLit "h$decodeUtf8z"


=====================================
testsuite/tests/javascript/Makefile
=====================================
@@ -7,3 +7,9 @@ T24495:
 	./T24495
 	# check that the optimization occurred
 	grep -c appendToHsStringA T24495.dump-js
+
+T23479:
+	'$(TEST_HC)' $(TEST_HC_OPTS) T23479.hs -v0 -O1 -dsuppress-uniques -ddump-js -ddump-to-file
+	./T23479
+	# check that the optimization occurred
+	grep -c " h\$$decodeUtf8z" T23479.dump-js


=====================================
testsuite/tests/javascript/T23479.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Prim
+
+import GHC.JS.Prim
+
+foreign import javascript "((x) => { console.log(x); })"
+  js_log1 :: JSVal -> IO ()
+
+main :: IO ()
+main = do
+  js_log1 (JSVal (unsafeUnpackJSStringUtf8## test_addr_1))
+  where
+    test_addr_1 :: Addr#
+    test_addr_1 = "test_val_1"#


=====================================
testsuite/tests/javascript/T23479.stdout
=====================================
@@ -0,0 +1,2 @@
+test_val_1
+1


=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -22,3 +22,5 @@ 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'])
+
+test('T23479', normal, makefile_test, ['T23479'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d49f47b27d36f39c2c2d00c6138cd93bb490aaa

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d49f47b27d36f39c2c2d00c6138cd93bb490aaa
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/20240825/6437093f/attachment-0001.html>