[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 21:10:36 UTC 2023
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
3229473c by Sebastian Graf at 2023-10-28T23:10:29+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.
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/CoreToStg/Prep.hs
- testsuite/tests/simplStg/should_compile/T15226b.stderr
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.
-}
@@ -2103,6 +2106,18 @@ Implementing seq#. The compiler has magic for SeqOp in
- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+- GHC.CoreToStg.Prep: 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 (as implemented in StgToCmm below).
+ 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.
+
- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
- Simplify.addEvals records evaluated-ness for the result; see
=====================================
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
+ = 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/simplStg/should_compile/T15226b.stderr
=====================================
@@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
:: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b
[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []] =
{} \r [conrep conrep1]
- case conrep of conrep2 [Occ=Once1] {
+ case conrep of conrep2 [Occ=Once1, Dmd=SL] {
__DEFAULT ->
- case conrep1 of conrep3 [Occ=Once1] {
+ case conrep1 of conrep3 [Occ=Once1, Dmd=SL] {
__DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3];
};
};
@@ -21,15 +21,15 @@ T15226b.testFun1
{} \r [x y void]
case seq# [x GHC.Prim.void#] of {
Solo# ipv1 [Occ=Once1] ->
+ case y of conrep [Occ=Once1, Dmd=SL] {
+ __DEFAULT ->
let {
- sat [Occ=Once1] :: T15226b.StrictPair a b
- [LclId] =
- {ipv1, y} \u []
- case y of conrep [Occ=Once1] {
- __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep];
- };
+ sat [Occ=Once1, Dmd=SL] :: T15226b.StrictPair a b
+ [LclId, Unf=OtherCon []] =
+ T15226b.MkStrictPair! [ipv1 conrep];
} in seq# [sat GHC.Prim.void#];
};
+ };
T15226b.testFun
:: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3229473c482e8348c69cd0b241611408d8ae5849
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3229473c482e8348c69cd0b241611408d8ae5849
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/d6b022e9/attachment-0001.html>
More information about the ghc-commits
mailing list