[Git][ghc/ghc][wip/T23479] 7 commits: simplifier: Fix space leak during demand analysis
Serge S. Gulin (@gulin.serge)
gitlab at gitlab.haskell.org
Thu Aug 29 08:42:09 UTC 2024
Serge S. Gulin pushed to branch wip/T23479 at Glasgow Haskell Compiler / GHC
Commits:
3a5bebf8 by Matthew Pickering at 2024-08-28T14:16:42-04:00
simplifier: Fix space leak during demand analysis
The lazy structure (a list) in a strict field in `DmdType` is not fully
forced which leads to a very large thunk build-up.
It seems there is likely still more work to be done here as it seems we
may be trading space usage for work done. For now, this is the right
choice as rather than using all the memory on my computer, compilation
just takes a little bit longer.
See #25196
- - - - -
c2525e9e by Ryan Scott at 2024-08-28T14:17:17-04:00
Add missing parenthesizeHsType in cvtp's InvisP case
We need to ensure that when we convert an `InvisP` (invisible type pattern) to
a `Pat`, we parenthesize it (at precedence `appPrec`) so that patterns such as
`@(a :: k)` will parse correctly when roundtripped back through the parser.
Fixes #25209.
- - - - -
90445c1f by Serge S. Gulin at 2024-08-29T11:41:45+03:00
JS: Re-add optimization for literal strings in genApp (fixes 23479 (muted temporary))
Based on https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/
- - - - -
85688483 by Serge S. Gulin at 2024-08-29T11:41:45+03:00
Use name defined at `GHC.Builtin.Names`
- - - - -
9890b69f by Serge S. Gulin at 2024-08-29T11:41:45+03:00
Apply 1 suggestion(s) to 1 file(s)
Co-authored-by: Sylvain Henry <sylvain at haskus.fr>
- - - - -
71d59e76 by Serge S. Gulin at 2024-08-29T11:41:45+03:00
Attempt to take 805 for id
- - - - -
03767c62 by Serge S. Gulin at 2024-08-29T11:41:45+03:00
Attempt to add to basicKnownKeyNames
Co-authored-by: Andrei Borzenkov <root at sandwitch.dev>
Co-authored-by: Danil Berestov <goosedb at yandex.ru>
- - - - -
12 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Symbols.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Demand.hs
- testsuite/tests/javascript/Makefile
- + testsuite/tests/javascript/T23479.hs
- + testsuite/tests/javascript/T23479.stdout
- testsuite/tests/javascript/all.T
- + testsuite/tests/th/T25209.hs
- + testsuite/tests/th/T25209.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -522,6 +522,8 @@ basicKnownKeyNames
, unsafeEqualityTyConName
, unsafeReflDataConName
, unsafeCoercePrimName
+
+ , unsafeUnpackJSStringUtf8ShShName
]
genericTyConNames :: [Name]
@@ -592,7 +594,8 @@ gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,
gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST,
gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL,
gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL,
- gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR :: Module
+ gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR,
+ gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module
gHC_INTERNAL_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Base")
gHC_INTERNAL_ENUM = mkGhcInternalModule (fsLit "GHC.Internal.Enum")
gHC_INTERNAL_GHCI = mkGhcInternalModule (fsLit "GHC.Internal.GHCi")
@@ -635,7 +638,7 @@ gHC_INTERNAL_RANDOM = mkGhcInternalModule (fsLit "GHC.Internal.S
gHC_INTERNAL_EXTS = mkGhcInternalModule (fsLit "GHC.Internal.Exts")
gHC_INTERNAL_IS_LIST = mkGhcInternalModule (fsLit "GHC.Internal.IsList")
gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")
-gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")
+gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")
gHC_INTERNAL_GENERICS = mkGhcInternalModule (fsLit "GHC.Internal.Generics")
gHC_INTERNAL_TYPEERROR = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")
gHC_INTERNAL_TYPELITS = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")
@@ -646,6 +649,8 @@ gHC_INTERNAL_DATA_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.D
gHC_INTERNAL_DEBUG_TRACE = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace")
gHC_INTERNAL_UNSAFE_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce")
gHC_INTERNAL_FOREIGN_C_CONSTPTR = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr")
+gHC_INTERNAL_JS_PRIM = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim")
+gHC_INTERNAL_WASM_PRIM_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")
gHC_INTERNAL_SRCLOC :: Module
gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc")
@@ -1679,7 +1684,10 @@ constPtrConName =
tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey
jsvalTyConName :: Name
-jsvalTyConName = tcQual (mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")) (fsLit "JSVal") jsvalTyConKey
+jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey
+
+unsafeUnpackJSStringUtf8ShShName :: Name
+unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey
{-
************************************************************************
@@ -2082,6 +2090,7 @@ typeSymbolKindConNameKey, typeCharKindConNameKey,
, typeNatLogTyFamNameKey
, typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey
, typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey
+ , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey
:: Unique
typeSymbolKindConNameKey = mkPreludeTyConUnique 400
typeCharKindConNameKey = mkPreludeTyConUnique 401
@@ -2104,9 +2113,10 @@ constPtrTyConKey = mkPreludeTyConUnique 417
jsvalTyConKey = mkPreludeTyConUnique 418
-exceptionContextTyConKey :: Unique
exceptionContextTyConKey = mkPreludeTyConUnique 420
+unsafeUnpackJSStringUtf8ShShKey = mkPreludeMiscIdUnique 805
+
{-
************************************************************************
* *
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -86,7 +87,6 @@ rtsApply cfg = jBlock
, moveRegs2
]
-
-- | Generate an application of some args to an Id.
--
-- The case where args is null is common as it's used to generate the evaluation
@@ -98,6 +98,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
+ , idName i == unsafeUnpackJSStringUtf8ShShName
+ -- 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"
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1519,7 +1519,7 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; wrapParLA gParPat $ ViewPat noAnn e' p'}
cvtp (TypeP t) = do { t' <- cvtType t
; return $ EmbTyPat noAnn (mkHsTyPat t') }
-cvtp (InvisP t) = do { t' <- cvtType t
+cvtp (InvisP t) = do { t' <- parenthesizeHsType appPrec <$> cvtType t
; pure (InvisPat noAnn (mkHsTyPat t'))}
cvtp (OrP ps) = do { ps' <- cvtPats ps
; pure (OrPat noExtField ps')}
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -1913,7 +1913,7 @@ multDmdType :: Card -> DmdType -> DmdType
multDmdType n (DmdType fv args)
= -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $
DmdType (multDmdEnv n fv)
- (map (multDmd n) args)
+ (strictMap (multDmd n) args)
peelFV :: DmdType -> Var -> (DmdType, Demand)
peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
=====================================
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'])
=====================================
testsuite/tests/th/T25209.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeAbstractions #-}
+module T25209 where
+
+import Data.Proxy
+
+$([d| f :: Proxy a -> Proxy a
+ f @(a :: k) p = p
+ |])
=====================================
testsuite/tests/th/T25209.stderr
=====================================
@@ -0,0 +1,6 @@
+T25209.hs:(7,2)-(9,7): Splicing declarations
+ [d| f :: Proxy a -> Proxy a
+ f @(a :: k) p = p |]
+ ======>
+ f :: Proxy a -> Proxy a
+ f @(a :: k) p = p
=====================================
testsuite/tests/th/all.T
=====================================
@@ -622,4 +622,5 @@ test('T24572a', normal, compile, [''])
test('T24572b', normal, compile_fail, [''])
test('T24572c', normal, compile_fail, [''])
test('T24572d', normal, compile, [''])
+test('T25209', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_MultilineStrings', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b2e31d47519c29c98f35a1e3e2110ad83d18e24d...03767c627c5b81b1a3f6c8ee6481fd77e581916b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b2e31d47519c29c98f35a1e3e2110ad83d18e24d...03767c627c5b81b1a3f6c8ee6481fd77e581916b
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/20240829/511952b0/attachment-0001.html>
More information about the ghc-commits
mailing list