[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 18:01:51 UTC 2023



Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC


Commits:
c500dcf8 by Sebastian Graf at 2023-10-28T20:00:16+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
+            = 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/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/c500dcf84e88e64facf81d62cba05a0250c86716

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c500dcf84e88e64facf81d62cba05a0250c86716
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/d52e7a46/attachment-0001.html>


More information about the ghc-commits mailing list