[Git][ghc/ghc][wip/clyring/seqHash-DmdTransformer] try being a bit less stupid about absent demands

[Matthew Craven (@clyring)]

Matthew Craven pushed to branch wip/clyring/seqHash-DmdTransformer at Glasgow Haskell Compiler / GHC


Commits:
3bd15939 by Matthew Craven at 2024-04-22T08:48:39-04:00
try being a bit less stupid about absent demands

- - - - -


4 changed files:

- compiler/GHC/Types/Demand.hs
- testsuite/tests/dmdanal/should_compile/all.T
- testsuite/tests/dmdanal/should_compile/DmdAnal_evaluate.hs → testsuite/tests/dmdanal/sigs/DmdAnal_evaluate.hs
- testsuite/tests/dmdanal/sigs/all.T


Changes:

=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -658,7 +658,7 @@ viewDmdPair (D n sd) = (n, sd)
 -- If the matched demand was 'BotDmd', it will match as @C_10 :* botSubDmd at .
 -- The builder of this pattern synonym simply /discards/ the 'SubDemand' if the
 -- 'Card' was absent and returns 'AbsDmd' or 'BotDmd' instead. It will assert
--- that the discarded sub-demand was 'seqSubDmd' and 'botSubDmd', respectively.
+-- that the discarded sub-demand was 'botSubDmd'.
 --
 -- Call sites should consider whether they really want to look at the
 -- 'SubDemand' of an absent demand and match on 'AbsDmd' and/or 'BotDmd'
@@ -2361,16 +2361,22 @@ dmdTransformSeqHash :: DmdTransformer
 dmdTransformSeqHash sd0 = let
   !(n1, sd1) = peelCallDmd sd0
   !(n2, sd2) = peelCallDmd sd1
-  !result_card = n1 `multCard` n2 `multCard` C_01
+  !num_calls = n1 `multCard` n2
+  arg_SubDmd = case viewProd 2 sd2 of
+    Just (_, [_state_token_dmd, result_dmd])
+      -> case trimBoxity result_dmd of
+           -- trimBoxity: We can't unbox through seq# yet. (But see #24334.)
+           AbsDmd -> seqSubDmd
+           _ :* result_SubDmd -> result_SubDmd
+    _ -> topSubDmd
+  !arg_dmd = num_calls `multDmd` (C_01 :* arg_SubDmd)
     -- Why C_01? A call to seq# always evaluates its argument exactly once,
     -- but since the evalaution it performs is well-sequenced
     -- we must not consider it strict. See Note [seq# magic], (SEQ3)
-  in case viewProd 2 sd2 of
-       Just (_, [_state_token_dmd, result_dmd])
-         | _ :* !result_SubDmd <- trimBoxity result_dmd
-           -- trimBoxity: We can't unbox through seq# yet. (But see #24334.)
-         -> DmdType nopDmdEnv [result_card :* result_SubDmd, topDmd]
-       _ -> DmdType nopDmdEnv [result_card  :*  topSubDmd  , topDmd]
+  !tok_dmd = num_calls `multDmd` topDmd
+  in --pprTrace "dmdTransformSeqHash"
+     --(ppr sd0 $$ ppr (num_calls, sd2) $$ ppr arg_dmd $$ ppr tok_dmd)
+     DmdType nopDmdEnv [arg_dmd, tok_dmd]
 
 {-
 Note [What are demand signatures?]


=====================================
testsuite/tests/dmdanal/should_compile/all.T
=====================================
@@ -16,7 +16,6 @@ test('test', normal, compile, [''])
 test('tst', normal, compile, [''])
 test('unu', normal, compile, [''])
 test('newtype', req_profiling, compile, ['-prof -fprof-auto'])
-test('DmdAnal_evaluate', normal, compile, ['-ddump-dmdanal -dsuppress-uniques -dno-typeable-binds'])
 test('T1988', normal, compile, [''])
 test('T8467', normal, compile, [''])
 test('T8037', normal, compile, [''])


=====================================
testsuite/tests/dmdanal/should_compile/DmdAnal_evaluate.hs → testsuite/tests/dmdanal/sigs/DmdAnal_evaluate.hs
=====================================
@@ -20,3 +20,9 @@ funD :: (Int, Int) -> IO Int
 funD p = do
   (x, y) <- evaluate p
   evaluate (x + y)
+
+funE :: a -> b -> IO a
+funE x y = do
+  x' <- evaluate x
+  _  <- evaluate y
+  pure x'


=====================================
testsuite/tests/dmdanal/sigs/all.T
=====================================
@@ -40,3 +40,4 @@ test('T21888', normal, compile, [''])
 test('T21888a', normal, compile, [''])
 test('T22241', normal, compile, [''])
 test('T21737', normal, compile, [''])
+test('DmdAnal_evaluate', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bd159396a4450ae074f013207e23dc729078fb2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bd159396a4450ae074f013207e23dc729078fb2
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/20240422/913067c1/attachment-0001.html>