[Git][ghc/ghc][wip/T24124] CorePrep: Treat seq# and dataToTag# as strict functions (#24124)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Sat Oct 28 09:46:28 UTC 2023
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
a919e319 by Sebastian Graf at 2023-10-28T11:46:19+02:00
CorePrep: Treat seq# and dataToTag# as strict functions (#24124)
See the new `Note [seq# magic]`.
I also implemented a new `Note [Flatten case-bind]`.
Fixes #24124.
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/CoreToStg/Prep.hs
- + testsuite/tests/core-to-stg/T24124.hs
- + testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/core-to-stg/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2028,6 +2028,9 @@ is:
case e of <transformed alts>
by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]
+* Similar to Note [seq# magic], we case-bind the arg of dataToTag# in
+ GHC.CoreToStg.Prep.
+
See #15696 for a long saga.
-}
@@ -2108,6 +2111,19 @@ Implementing seq#. The compiler has magic for SeqOp in
- Simplify.addEvals records evaluated-ness for the result; see
Note [Adding evaluatedness info to pattern-bound variables]
in GHC.Core.Opt.Simplify.Iteration
+
+- GHC.CoreToStg.Prep: Finally case-bind the arg of seq#, e.g.,
+
+ case seq# (f 13) s of (# r, s' #) -> ...
+ ==>
+ case f 13 of sat of __DEFAULT ->
+ case seq# sat s of (# r, s' #) -> ...,
+
+ encoding its call-by-value nature. Note that strictness analysis and the
+ Simplifier will never see this case binding, so #5129 as above is not an
+ issue. Plus, CorePrep never case-binds an argument variable anyway.
+ (Exploiting CbV-ness for argument vars is a job for tag inference, see
+ #15226.)
-}
seqRule :: RuleM CoreExpr
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -70,6 +70,7 @@ import GHC.Types.Unique.Supply
import Data.List ( unfoldr )
import Control.Monad
+import GHC.Builtin.PrimOps
{-
Note [CorePrep Overview]
@@ -850,7 +851,12 @@ cpeRhsE env (Case scrut bndr ty alts)
where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
; alts'' <- mapM (sat_alt env') alts'
- ; return (floats, Case scrut' bndr2 ty alts'') }
+ ; case alts'' of
+ [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
+ | float <- mkNonRecFloat env evalDmd True bndr2 scrut'
+ -- True: is_unlifted, so that we don't float to top-level
+ -> return (snocFloat floats float, rhs)
+ _ -> return (floats, Case scrut' bndr2 ty alts'') }
where
sat_alt env (Alt con bs rhs)
= do { (env2, bs') <- cpCloneBndrs env bs
@@ -1089,16 +1095,24 @@ cpeApp top_env expr
; mb_saturate hd app floats unsat_ticks depth }
where
depth = val_args args
- stricts = case idDmdSig v of
- DmdSig (DmdType _ demands)
- | listLengthCmp demands depth /= GT -> demands
- -- length demands <= depth
- | otherwise -> []
- -- If depth < length demands, then we have too few args to
- -- satisfy strictness info so we have to ignore all the
- -- strictness info, e.g. + (error "urk")
- -- Here, we can't evaluate the arg strictly, because this
- -- partial application might be seq'd
+ stricts
+ | PrimOpId op _ <- idDetails v
+ , Just demands <- case op of
+ SeqOp -> Just [evalDmd,topDmd] -- See Note [seq# magic]
+ DataToTagOp -> Just [evalDmd] -- See Note [dataToTag# magic]
+ _ -> Nothing
+ , listLengthCmp demands depth /= GT -- length demands <= depth
+ = pprTrace "here" (ppr op $$ ppr args) demands
+
+ | DmdSig (DmdType _ demands) <- idDmdSig v
+ , listLengthCmp demands depth /= GT -- length demands <= depth
+ = demands
+ | otherwise
+ = [] -- If depth < length demands, then we have too few args to
+ -- satisfy strictness info so we have to ignore all the
+ -- strictness info, e.g. + (error "urk")
+ -- Here, we can't evaluate the arg strictly, because this
+ -- partial application might be seq'd
-- We inlined into something that's not a var and has no args.
-- Bounce it back up to cpeRhsE.
@@ -1719,12 +1733,13 @@ During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a
fresh binder `sat`.
Now there are two interesting cases:
- 1. When `e` is a value, we will float `sat=e` as far as possible, even to
- top-level. It is important that we mark `sat` as evaluated (via setting its
- unfolding to `evaldUnfolding`), otherwise we get a superfluous thunk to
- carry out the field set on T's field, because `exprIsHNF sat == False`:
+ 1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible,
+ to top-level, even. It is important that we mark `sat` as evaluated (via
+ setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous
+ thunk to carry out the field seq on T's field, because
+ `exprIsHNF sat == False`:
- let sat = e in
+ let sat = Just y in
let sat2 = case sat of x { __DEFAULT } -> T x in
-- NONONO, want just `sat2 = T x`
f sat2
@@ -1763,6 +1778,25 @@ an `evaldUnfolding` if either
1. `e` is a value, or
2. `sat=e` is case-bound, but won't float to top-level.
+Note [Flatten case-binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following program involving seq#:
+
+ data T a = T !a
+ ... seq# (case x of y { __DEFAULT -> T y }) s ...
+ ==> {ANFise, exploiting CbV-ness as in Note [seq# magic] and cpe_app}
+ ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> seq# sat s }
+
+(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy;
+see Note [seq# magic].)
+Note the case-of-case. This is not bad per sé, but we can easily flatten
+this situation by calling `mkNonRecFloat` to create strict binding `y=x`:
+
+ ... case x of y { __DEFAULT -> let sat = T y in seq# sat s } ...
+
+where `T y` is simply let-bound, thus far less likely to confuse passes
+downstream.
+
Note [Speculative evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since call-by-value is much cheaper than call-by-need, we case-bind arguments
=====================================
testsuite/tests/core-to-stg/T24124.hs
=====================================
@@ -0,0 +1,11 @@
+module T24124 where
+
+import Control.Exception
+
+data StrictPair a b = MkStrictPair !a !b
+
+testFun :: a -> b -> IO (StrictPair a b)
+testFun x y = do
+ x' <- evaluate x
+ evaluate (MkStrictPair x' y)
+ -- CorePrep should evaluate `MkStrictPair` and its fields strictly
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -0,0 +1,193 @@
+
+==================== CorePrep ====================
+Result size of CorePrep
+ = {terms: 119, types: 108, coercions: 22, joins: 0/1}
+
+-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0}
+T24124.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
+ :: forall a b. a %1 -> b %1 -> T24124.StrictPair a b
+[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []]
+T24124.$WMkStrictPair
+ = \ (@a)
+ (@b)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: b) ->
+ case conrep of conrep2 [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ case conrep1 of conrep3 [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ T24124.MkStrictPair @a @b conrep2 conrep3
+ }
+ }
+
+-- RHS size: {terms: 20, types: 27, coercions: 0, joins: 0/1}
+T24124.testFun1
+ :: forall a b.
+ a
+ -> b
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, T24124.StrictPair a b #)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []]
+T24124.testFun1
+ = \ (@a)
+ (@b)
+ (x [Occ=Once1] :: a)
+ (y [Occ=Once1, OS=OneShot] :: b)
+ (s [Occ=Once1, OS=OneShot]
+ :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+ case GHC.Prim.seq# @a @GHC.Prim.RealWorld x s of
+ { (# ipv [Occ=Once1], ipv1 [Occ=Once1] #) ->
+ case y of conrep [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ let {
+ sat [Occ=Once1, Dmd=SL] :: T24124.StrictPair a b
+ [LclId, Unf=OtherCon []]
+ sat = T24124.MkStrictPair @a @b ipv1 conrep } in
+ GHC.Prim.seq# @(T24124.StrictPair a b) @GHC.Prim.RealWorld sat ipv
+ }
+ }
+
+-- RHS size: {terms: 9, types: 8, coercions: 15, joins: 0/0}
+T24124.testFun
+ :: forall a b. a -> b -> GHC.Types.IO (T24124.StrictPair a b)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []]
+T24124.testFun
+ = (\ (@a)
+ (@b)
+ (eta [Occ=Once1] :: a)
+ (eta [Occ=Once1] :: b)
+ (eta [Occ=Once1] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+ T24124.testFun1 @a @b eta eta eta)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <a>_R
+ %<'GHC.Types.Many>_N ->_R <b>_R
+ %<'GHC.Types.Many>_N ->_R Sym (GHC.Types.N:IO[0]
+ <T24124.StrictPair a b>_R)
+ :: (forall a b.
+ a
+ -> b
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, T24124.StrictPair a b #))
+ ~R# (forall a b. a -> b -> GHC.Types.IO (T24124.StrictPair a b)))
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule3 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$trModule3 = GHC.Types.TrNameS T24124.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$trModule2 = "T24124"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$trModule1 = GHC.Types.TrNameS T24124.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule :: GHC.Types.Module
+[GblId, Unf=OtherCon []]
+T24124.$trModule
+ = GHC.Types.Module T24124.$trModule3 T24124.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1 = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair2 = "StrictPair"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair1 = GHC.Types.TrNameS T24124.$tcStrictPair2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair :: GHC.Types.TyCon
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair
+ = GHC.Types.TyCon
+ 9300255393514929474#Word64
+ 9110283622559092784#Word64
+ T24124.$trModule
+ T24124.$tcStrictPair1
+ 0#
+ GHC.Types.krep$*->*->*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2
+ = GHC.Types.:
+ @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep3 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep3 = GHC.Types.: @GHC.Types.KindRep $krep1 $krep2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep4 = GHC.Types.KindRepTyConApp T24124.$tcStrictPair $krep3
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep5 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep5 = GHC.Types.KindRepFun $krep $krep4
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair1 = GHC.Types.KindRepFun $krep1 $krep5
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair3 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair3 = "'MkStrictPair"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair2 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair2
+ = GHC.Types.TrNameS T24124.$tc'MkStrictPair3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair :: GHC.Types.TyCon
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair
+ = GHC.Types.TyCon
+ 2381261223169708323#Word64
+ 3151447712495713176#Word64
+ T24124.$trModule
+ T24124.$tc'MkStrictPair2
+ 2#
+ T24124.$tc'MkStrictPair1
+
+-- RHS size: {terms: 7, types: 6, coercions: 7, joins: 0/0}
+T24124.MkStrictPair [InlPrag=CONLIKE]
+ :: forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b
+[GblId[DataCon], Arity=2, Caf=NoCafRefs, Unf=OtherCon []]
+T24124.MkStrictPair
+ = (\ (@a[sk:1])
+ (@b[sk:1])
+ (eta [Occ=Once1] :: a)
+ (eta [Occ=Once1] :: b) ->
+ T24124.MkStrictPair @a[sk:1] @b[sk:1] eta eta)
+ `cast` (<forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b>_R
+ :: (forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b)
+ ~R# (forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b))
+
+
+
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -3,3 +3,4 @@
test('T19700', normal, compile, ['-O'])
test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep'])
test('T23914', normal, compile, ['-O'])
+test('T24124', [grep_errmsg(r'= .*MkStrictPair.*in')], compile, ['-O -dsuppress-uniques -ddump-prep'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a919e3194d0fc6e87ee20dcba1c586ab7aa84158
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a919e3194d0fc6e87ee20dcba1c586ab7aa84158
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/20231028/a4b7315a/attachment-0001.html>
More information about the ghc-commits
mailing list