[Git][ghc/ghc][master] DmdAnal: Fast path for `multDmdType` (#25196)

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
1374349b by Sebastian Graf at 2024-09-13T07:52:11-04:00
DmdAnal: Fast path for `multDmdType` (#25196)

This is in order to counter a regression exposed by SpecConstr.

Fixes #25196.

- - - - -


5 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- + testsuite/tests/dmdanal/should_compile/T25196.hs
- + testsuite/tests/dmdanal/should_compile/T25196_aux.hs
- testsuite/tests/dmdanal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -426,7 +426,7 @@ dmdAnalStar env (n :* sd) e
   , n' <- anticipateANF e n
       -- See Note [Anticipating ANF in demand analysis]
       -- and Note [Analysing with absent demand]
-  = (discardArgDmds $ multDmdType n' dmd_ty, e')
+  = (multDmdEnv n' (discardArgDmds dmd_ty), e')
 
 -- Main Demand Analysis machinery
 dmdAnal, dmdAnal' :: AnalEnv


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Types.Demand (
 
     -- * Demand environments
     DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,
-    reuseEnv,
+    multDmdEnv, reuseEnv,
 
     -- * Demand types
     DmdType(..), dmdTypeDepth,
@@ -1910,7 +1910,8 @@ splitDmdTy ty at DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})
 splitDmdTy ty at DmdType{dt_env=env}       = (defaultArgDmd (de_div env), ty)
 
 multDmdType :: Card -> DmdType -> DmdType
-multDmdType n (DmdType fv args)
+multDmdType C_11 dmd_ty = dmd_ty -- a vital optimisation for T25196
+multDmdType n    (DmdType fv args)
   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $
     DmdType (multDmdEnv n fv)
             (strictMap (multDmd n) args)


=====================================
testsuite/tests/dmdanal/should_compile/T25196.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25196 where
+
+import T25196_aux
+
+bar = $(gen 10000)


=====================================
testsuite/tests/dmdanal/should_compile/T25196_aux.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25196_aux where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+
+gen :: Int -> Q Exp
+gen n = lamE (replicate n (newName "x" >>= varP)) [| () |]


=====================================
testsuite/tests/dmdanal/should_compile/all.T
=====================================
@@ -98,3 +98,5 @@ test('T22388', [ grep_errmsg(r'^\S+\$w\S+') ], compile, ['-dsuppress-uniques -dd
 test('T22997', normal, compile, [''])
 test('T23398', normal, compile, ['-dsuppress-uniques -ddump-simpl -dno-typeable-binds'])
 test('T24623', normal, compile, [''])
+test('T25196', [ req_th, collect_compiler_stats('bytes allocated', 10) ],
+               multimod_compile, ['T25196', '-v0'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1374349ba392c6354214dc2a1ceddbdcf4d65e53

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1374349ba392c6354214dc2a1ceddbdcf4d65e53
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/20240913/307e5fbd/attachment-0001.html>