[Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124)

Sebastian Graf (@sgraf812) gitlab at gitlab.haskell.org
Wed Dec 13 13:11:52 UTC 2023



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


Commits:
e89883d1 by Sebastian Graf at 2023-12-13T14:11:33+01:00
Make `seq#` a magic Id and inline it in CorePrep (#24124)

We can save much code and explanation in Tag Inference and StgToCmm by giving
`seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in
CorePrep. See the updated `Note [seq# magic]`.
I also implemented a new `Note [Flatten case-bind]` to get better code for
otherwise nested case scrutinees.

I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to
resolve the clash between `type CpeApp = CoreExpr` and the data constructor of
`ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`.

Fixes #24252 and #24124.

- - - - -


16 changed files:

- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/Utils.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-prim/GHC/Magic.hs
- testsuite/tests/simplStg/should_compile/T15226b.stderr


Changes:

=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique
 rootMainKey                   = mkPreludeMiscIdUnique 101
 runMainKey                    = mkPreludeMiscIdUnique 102
 
-thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique
+thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique
 thenIOIdKey                   = mkPreludeMiscIdUnique 103
 lazyIdKey                     = mkPreludeMiscIdUnique 104
 assertErrorIdKey              = mkPreludeMiscIdUnique 105
@@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
 rationalToFloatIdKey   = mkPreludeMiscIdUnique 132
 rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133
 
+seqHashIdKey                  = mkPreludeMiscIdUnique 134
+
 coerceKey :: Unique
 coerceKey                     = mkPreludeMiscIdUnique 157
 


=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -916,10 +916,9 @@ instance Outputable PrimCall where
         = text "__primcall" <+> ppr pkgId <+> ppr lbl
 
 -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it
--- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument
+-- isn't DataToTagOp which are two primops that evaluate their argument
 -- hence induce thread/stack/heap changes.
 primOpIsReallyInline :: PrimOp -> Bool
 primOpIsReallyInline = \case
-  SeqOp       -> False
   DataToTagOp -> False
   p           -> not (primOpOutOfLine p)


=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp
    with effect = ReadWriteEffect
    code_size = { primOpCodeSizeForeignCall }
 
--- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
-primop SeqOp "seq#" GenPrimOp
-   a -> State# s -> (# State# s, a #)
-   with
-   effect = ThrowsException
-   work_free = True -- seq# does work iff its lifted arg does work
-
 primop GetSparkOp "getSpark#" GenPrimOp
    State# s -> (# State# s, Int#, a #)
    with


=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Prelude
 
 import GHC.Platform
 
-import GHC.Types.Id.Make ( unboxedUnitExpr )
+import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName )
 import GHC.Types.Id
 import GHC.Types.Literal
 import GHC.Types.Name.Occurrence ( occNameFS )
@@ -821,7 +821,6 @@ primOpRules nm = \case
 
    AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
 
-   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]
    SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]
 
    _          -> Nothing
@@ -2038,7 +2037,7 @@ unsafeEqualityProofRule
 
 {- Note [seq# magic]
 ~~~~~~~~~~~~~~~~~~~~
-The primop
+The magic Id (See Note [magicIds])
    seq# :: forall a s . a -> State# s -> (# State# s, a #)
 
 is /not/ the same as the Prelude function seq :: a -> b -> b
@@ -2048,13 +2047,18 @@ mechanism for 'evaluate'
    evaluate :: a -> IO a
    evaluate a = IO $ \s -> seq# a s
 
-The semantics of seq# is
+Its (NOINLINE) definition in GHC.Magic is simply
+   seq# a s = a `seq` (# s, a #),
+but the precise semantics of seq# exported to the user is
+  * wait for all earlier actions in the State#-token-thread to complete
   * evaluate its first argument
   * and return it
 
 Things to note
 
-* Why do we need a primop at all?  That is, instead of
+(SEQ1)
+  Clearly, the definition given above satisfies the precise semantics,
+  but why is it NOINLINE?  That is, instead of
       case seq# x s of (# x, s #) -> blah
   why not instead say this?
       case x of { DEFAULT -> blah }
@@ -2069,25 +2073,50 @@ Things to note
   In short, we /always/ evaluate the first argument and never
   just discard it.
 
-* Why return the value?  So that we can control sharing of seq'd
+  However, we *do* inline most applications of `seq#` in CorePrep, where
+  evaluation order is fixed; see the implementation notes below.
+  This is one reason why we need `seq#` to be known-key.
+
+(SEQ2)
+  `seq#` evaluates its argument and demand analysis would report it as strict,
+  <1L><L>. But it is important that we do /not/ expose that strictness
+  in its strictness signature. Why not? Because `seq#` is intended to mean
+  "evaluate this argument now -- not earlier". For example:
+    do { evaluate x; evaluate y }
+  should evaluate `x` and then `y`.  If `seq#` was visibly strict, they
+  might be evaluated in the opposite order.
+  Easily achieved for a magic Id, in GHC.Types.Id.Make.
+
+(SEQ3)
+  Why return the value?  So that we can control sharing of seq'd
   values: in
      let x = e in x `seq` ... x ...
   We don't want to inline x, so better to represent it as
        let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
   also it matches the type of rseq in the Eval monad.
 
-Implementing seq#.  The compiler has magic for SeqOp in
+Implementing seq#.  The compiler has magic for `seq#` in
 
-- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2))
 
-- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
+- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
 
 - Simplify.addEvals records evaluated-ness for the result; see
   Note [Adding evaluatedness info to pattern-bound variables]
   in GHC.Core.Opt.Simplify.Iteration
 
-- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a
-  properly-tagged pointer inside of its unboxed-tuple result.
+- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g.,
+
+    seq# (f 13) s
+    ==>
+    case f 13 of sat of __DEFAULT -> (# s, sat #)
+
+  This is implemented in `cpeApp`, not unlike Note [runRW magic].
+
+  Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`.
+  That's OK, because the telescope of Floats always stays in the same order
+  and won't be floated out of binders, so all guarantees of evaluation order
+  provided by seq# are upheld.
 -}
 
 seqRule :: RuleM CoreExpr
@@ -2177,7 +2206,9 @@ builtinRules
           platform <- getPlatform
           return $ Var (primOpId IntAndOp)
             `App` arg `App` mkIntVal platform (d - 1)
-        ]
+        ],
+
+     mkBasicRule seqHashIdName 4 seqRule
      ]
  ++ builtinBignumRules
 {-# NOINLINE builtinRules #-}


=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey )
 import GHC.Types.Basic
 import GHC.Types.Tickish
 import GHC.Types.Var    ( isTyCoVar )
-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
 import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
-import GHC.Builtin.Names( runRWKey )
+import GHC.Builtin.Names( runRWKey, seqHashIdKey )
 
 import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )
 import GHC.Data.FastString
@@ -3370,7 +3369,7 @@ addEvals scrut con vs
     -- Use stripNArgs rather than collectArgsTicks to avoid building
     -- a list of arguments only to throw it away immediately.
   , Just (Var f) <- stripNArgs 4 scr
-  , Just SeqOp <- isPrimOpId_maybe f
+  , f `hasKey` seqHashIdKey
   , let x' = zapIdOccInfoAndSetEvald MarkedStrict x
   = [s, x']
 


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -157,19 +157,19 @@ Note [CorePrep invariants]
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions
-       arg ::= lit |  var
-              | arg ty  |  /\a. arg
-              | truv co  |  /\c. arg  |  arg |> co
+       arg ::= lit     |  var
+            |  arg ty  |  /\a. arg
+            |  co      |  arg |> co
 
     Applications
-       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co
+       app ::= lit  |  var  |  app arg  |  app ty  |  app co  |  app |> co
 
     Expressions
        body ::= app
-              | let(rec) x = rhs in body     -- Boxed only
-              | case app of pat -> body
-              | /\a. body | /\c. body
-              | body |> co
+             |  let(rec) x = rhs in body     -- Boxed only
+             |  case body of pat -> body
+             |  /\a. body | /\c. body
+             |  body |> co
 
     Right hand sides (only place where value lambdas can occur)
        rhs ::= /\a.rhs  |  \x.rhs  |  body
@@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type:
     bind the unsafe coercion field of the Refl constructor.
   * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep].
 
+It is quite essential that CorePrep *does not* rearrange the order in which
+evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers
+the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does
+not attempt to reorder the telescope of Floats or float out out of non-floated
+binding sites (such as Case alts) in the first place; for that it would have to
+do some kind of data dependency analysis.
+
 Note [Floating out of top level bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 NB: we do need to float out of top-level bindings
@@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
                      | otherwise
                      = snocFloat floats new_float
 
-             new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1
+             new_float = mkNonRecFloat env is_unlifted bndr1 rhs1
 
        ; return (env2, floats1, Nothing) }
 
@@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs)
     -- group into a single giant Rec
     add_float (Float bind bound _) prs2
       | bound /= CaseBound
-      || all (definitelyLiftedType . idType) (bindersOf bind)
+      || all (not . isUnliftedType . idType) (bindersOf bind)
            -- The latter check is hit in -O0 (i.e., flavours quick, devel2)
            -- for dictionary args which haven't been floated out yet, #24102.
            -- They are preferably CaseBound, but since they are lifted we may
@@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
                else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
-                        ; let float = mkNonRecFloat env topDmd False v rhs2
+                        ; let float = mkNonRecFloat env False v rhs2
                         ; return ( snocFloat floats2 float
                                  , cpeEtaExpand arity (Var v)) })
 
@@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts)
        ; (env', bndr2) <- cpCloneBndr env bndr
        ; let alts'
                | cp_catchNonexhaustiveCases $ cpe_config env
+                 -- Suppose the alternatives do not cover all the data constructors of the type.
+                 -- That may be fine: perhaps an earlier case has dealt with the missing cases.
+                 -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag
+                 -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases
+                 -- (This alternative will only be taken if there is a bug in GHC.)
                , not (altsAreExhaustive alts)
                = addDefault alts (Just err)
                | otherwise = 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]
+             | let is_unlifted = isUnliftedType (idType bndr2)
+             , let float = mkCaseFloat is_unlifted bndr2 scrut'
+             -> 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
@@ -937,14 +954,14 @@ and it's extra work.
 --              CpeApp: produces a result satisfying CpeApp
 -- ---------------------------------------------------------------------------
 
-data ArgInfo = CpeApp  CoreArg
-             | CpeCast Coercion
-             | CpeTick CoreTickish
+data ArgInfo = AIApp  CoreArg -- NB: Not a CpeApp yet
+             | AICast Coercion
+             | AITick CoreTickish
 
 instance Outputable ArgInfo where
-  ppr (CpeApp arg) = text "app" <+> ppr arg
-  ppr (CpeCast co) = text "cast" <+> ppr co
-  ppr (CpeTick tick) = text "tick" <+> ppr tick
+  ppr (AIApp arg) = text "app" <+> ppr arg
+  ppr (AICast co) = text "cast" <+> ppr co
+  ppr (AITick tick) = text "tick" <+> ppr tick
 
 {- Note [Ticks and mandatory eta expansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression
 body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
 -}
 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
--- May return a CpeRhs because of saturating primops
+-- May return a CpeRhs (instead of CpeApp) because of saturating primops
 cpeApp top_env expr
   = do { let (terminal, args) = collect_args expr
       --  ; pprTraceM "cpeApp" $ (ppr expr)
@@ -1005,9 +1022,9 @@ cpeApp top_env expr
     collect_args e = go e []
       where
         go (App fun arg)      as
-            = go fun (CpeApp arg : as)
+            = go fun (AIApp arg : as)
         go (Cast fun co)      as
-            = go fun (CpeCast co : as)
+            = go fun (AICast co : as)
         go (Tick tickish fun) as
             -- Profiling ticks are slightly less strict so we expand their scope
             -- if they cover partial applications of things like primOps.
@@ -1020,7 +1037,7 @@ cpeApp top_env expr
             , etaExpansionTick head' tickish
             = (head,as')
             where
-              (head,as') = go fun (CpeTick tickish : as)
+              (head,as') = go fun (AITick tickish : as)
 
         -- Terminal could still be an app if it's wrapped by a tick.
         -- E.g. Tick<foo> (f x) can give us (f x) as terminal.
@@ -1030,7 +1047,7 @@ cpeApp top_env expr
             -> CoreExpr -- The thing we are calling
             -> [ArgInfo]
             -> UniqSM (Floats, CpeRhs)
-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)
+    cpe_app env (Var f) (AIApp Type{} : AIApp arg : args)
         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
             -- See Note [lazyId magic] in GHC.Types.Id.Make
        || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey
@@ -1056,24 +1073,36 @@ cpeApp top_env expr
           in cpe_app env terminal (args' ++ args)
 
     -- runRW# magic
-    cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest)
+    cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest)
         | f `hasKey` runRWKey
         -- N.B. While it may appear that n == 1 in the case of runRW#
         -- applications, keep in mind that we may have applications that return
-        , has_value_arg (CpeApp arg : rest)
+        , has_value_arg (AIApp arg : rest)
         -- See Note [runRW magic]
         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
         -- is why we return a CorePrepEnv as well)
         = case arg of
             Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest
-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)
+            _          -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest)
              -- TODO: What about casts?
         where
           has_value_arg [] = False
-          has_value_arg (CpeApp arg:_rest)
+          has_value_arg (AIApp arg:_rest)
             | not (isTyCoArg arg) = True
           has_value_arg (_:rest) = has_value_arg rest
 
+    -- See Note [seq# magic]. This is step (1) for CorePrep
+    cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)]
+        | f `hasKey` seqHashIdKey
+        -- seq# thing token   ==>   case thing of res { __DEFAULT -> (# token, res#) },
+        -- allocating a Float for (case thing of res { __DEFAULT -> _ })
+        = do { (floats, thing) <- cpeBody env thing
+             ; case_bndr <- newVar ty
+             ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr]
+             ; let is_unlifted = False -- otherwise seq# would not type-check
+             ; let float = mkCaseFloat is_unlifted case_bndr thing
+             ; return (floats `snocFloat` float, tup) }
+
     cpe_app env (Var v) args
       = do { v1 <- fiddleCCall v
            ; let e2 = lookupCorePrepEnv env v1
@@ -1120,13 +1149,13 @@ cpeApp top_env expr
         go [] !n = n
         go (info:infos) n =
           case info of
-            CpeCast {} -> go infos n
-            CpeTick tickish
+            AICast {} -> go infos n
+            AITick tickish
               | tickishFloatable tickish                 -> go infos n
               -- If we can't guarantee a tick will be floated out of the application
               -- we can't guarantee the value args following it will be applied.
               | otherwise                             -> n
-            CpeApp e                                  -> go infos n'
+            AIApp e                                  -> go infos n'
               where
                 !n'
                   | isTypeArg e = n
@@ -1182,13 +1211,13 @@ cpeApp top_env expr
             let tick_fun = foldr mkTick fun' rt_ticks
             in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
 
-      CpeApp (Type arg_ty)
+      AIApp (Type arg_ty)
         -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth
 
-      CpeApp (Coercion co)
+      AIApp (Coercion co)
         -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth
 
-      CpeApp arg -> do
+      AIApp arg -> do
         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
                = case (ss, isLazyExpr arg) of
                    (_   : ss_rest, True)  -> (topDmd, ss_rest)
@@ -1197,10 +1226,10 @@ cpeApp top_env expr
         (fs, arg') <- cpeArg top_env ss1 arg
         rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)
 
-      CpeCast co
+      AICast co
         -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth
       -- See Note [Ticks and mandatory eta expansion]
-      CpeTick tickish
+      AITick tickish
         | tickishPlace tickish == PlaceRuntime
         , req_depth > 0
         -> assert (isProfTick tickish) $
@@ -1481,10 +1510,11 @@ cpeArg env dmd arg
        -- see Note [ANF-ising literal string arguments]
        ; if exprIsTrivial arg2
          then return (floats2, arg2)
-         else do { v <- newVar arg_ty
-                 -- See Note [Eta expansion of arguments in CorePrep]
+         else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
+                       -- See Note [Pin demand info on floats]
                  ; let arg3 = cpeEtaExpandArg env arg2
-                       arg_float = mkNonRecFloat env dmd is_unlifted v arg3
+                       -- See Note [Eta expansion of arguments in CorePrep]
+                 ; let arg_float = mkNonRecFloat env is_unlifted v arg3
                  ; return (snocFloat floats2 arg_float, varToCoreExpr v) }
        }
 
@@ -1703,6 +1733,51 @@ cpeEtaExpand arity expr
 Note [Pin demand info on floats]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We pin demand info on floated lets, so that we can see the one-shot thunks.
+For example,
+  f (g x)
+where `f` uses its argument at least once, creates a Float for `y = g x` and we
+should better pin appropriate demand info on `y`.
+
+Note [Flatten case-binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have the following call, where f is strict:
+   f (case x of DEFAULT -> blah)
+(For the moment, ignore the fact that the Simplifier will have floated that
+`case` out because `f` is strict.)
+In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`
+
+    Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl
+
+with the call `f a`.  When we wrap that `Float` we will get
+
+   case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a }
+
+which is a bit silly. Actually the rest of the back end can cope with nested
+cases like this, but it is harder to read and we'd prefer the more direct:
+
+   case x of y { DEFAULT ->
+   case blah of a { DEFAULT -> f a }}
+
+This is easy to avoid: turn that
+
+   case x of DEFAULT -> blah
+
+into a FloatingBind of its own.  This is easily done in the Case
+equation for `cpsRhsE`.  Then our example will generate /two/ floats:
+
+    Float (y = x)    CaseBound top_lvl
+    Float (a = blah) CaseBound top_lvl
+
+and we'll end up with nested cases.
+
+Of course, the Simplifier never leaves us with an argument like this, but we
+/can/ see
+
+  data T a = T !a
+  ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs
+
+and the above footwork in cpsRhsE avoids generating a nested case.
+
 
 Note [Speculative evaluation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1816,6 +1891,9 @@ The `FloatInfo` of a `Float` describes how far it can float without
 
   * Any binding is at least `StrictContextFloatable`, meaning we may float it
     out of a strict context such as `f <>` where `f` is strict.
+    We may never float out of a Case alternative `case e of p -> <>`, though,
+    even if we made sure that `p` does not capture any variables of the float,
+    because that risks sequencing guarantees of Note [seq# magic].
 
   * A binding is `LazyContextFloatable` if we may float it out of a lazy context
     such as `let x = <> in Just x`.
@@ -1982,19 +2060,34 @@ zipFloats = appFloats
 zipManyFloats :: [Floats] -> Floats
 zipManyFloats = foldr zipFloats emptyFloats
 
-mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
-mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $
-  Float (NonRec bndr' rhs) bound info
+mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind
+mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info
+  where
+    (bound, info)
+      | is_lifted, is_hnf        = (LetBound,  TopLvlFloatable)
+          -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
+          -- let-bind `StrictBox x'` after Note [Flatten case-binds].
+      | exprIsTickedString scrut = (CaseBound, TopLvlFloatable)
+          -- String literals are unboxed (so must be case-bound) and float to
+          -- the top-level
+      | otherwise                = (CaseBound, StrictContextFloatable)
+         -- For a Case, we never want to drop the eval; hence no need to test
+         -- for ok-for-spec-eval
+    is_lifted   = not is_unlifted
+    is_hnf      = exprIsHNF scrut
+
+mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind
+mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $
+  Float (NonRec bndr rhs) bound info
   where
-    bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats]
-    (bound,info)
+    (bound, info)
       | is_lifted, is_hnf        = (LetBound, TopLvlFloatable)
           -- is_lifted: We currently don't allow unlifted values at the
           --            top-level or inside letrecs
           --            (but SG thinks that in principle, we should)
       | is_data_con bndr         = (LetBound, TopLvlFloatable)
-          -- We need this special case for unlifted DataCon workers/wrappers
-          -- until #17521 is fixed
+          -- We need this special case for nullary unlifted DataCon
+          -- workers/wrappers (top-level bindings) until #17521 is fixed
       | exprIsTickedString rhs   = (CaseBound, TopLvlFloatable)
           -- String literals are unboxed (so must be case-bound) and float to
           -- the top-level
@@ -2012,6 +2105,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr
 
     is_lifted   = not is_unlifted
     is_hnf      = exprIsHNF rhs
+    dmd         = idDemandInfo bndr
     is_strict   = isStrUsedDmd dmd
     ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs
     is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
@@ -2044,7 +2138,7 @@ deFloatTop floats
   where
     get (Float b _ TopLvlFloatable) bs
       = get_bind b : bs
-    get b _  = pprPanic "corePrepPgm" (ppr b)
+    get b _  = pprPanic "deFloatTop" (ppr b)
 
     -- See Note [Dead code in CorePrep]
     get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)


=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) )
 import GHC.Types.Unique.Supply (mkSplitUniqSupply)
 import GHC.Types.RepType (dataConRuntimeRepStrictness)
 import GHC.Core (AltCon(..))
-import GHC.Builtin.PrimOps ( PrimOp(..) )
 import Data.List (mapAccumL)
 import GHC.Utils.Outputable
 import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )
@@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body)
     (info, body') = inferTagExpr env body
 
 inferTagExpr _ (StgOpApp op args ty)
-  | StgPrimOp SeqOp <- op
-  -- Recall seq# :: a -> State# s -> (# State# s, a #)
-  -- However the output State# token has been unarised away,
-  -- so we now effectively have
-  --    seq# :: a -> State# s -> (# a #)
-  -- The key point is the result of `seq#` is guaranteed evaluated and properly
-  -- tagged (because that result comes directly from evaluating the arg),
-  -- and we want tag inference to reflect that knowledge (#15226).
-  -- Hence `TagTuple [TagProper]`.
-  -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
-  = (TagTuple [TagProper], StgOpApp op args ty)
-  -- Do any other primops guarantee to return a properly tagged value?
-  -- Probably not, and that is the conservative assumption anyway.
+  -- Which primops guarantee to return a properly tagged value?
+  -- Probably none, and that is the conservative assumption anyway.
   -- (And foreign calls definitely need not make promises.)
-  | otherwise = (TagDunno, StgOpApp op args ty)
+  = (TagDunno, StgOpApp op args ty)
 
 inferTagExpr env (StgLet ext bind body)
   = (info, StgLet ext bind' body')


=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`.
 rewriteOpApp :: InferStgExpr -> RM TgStgExpr
 rewriteOpApp (StgOpApp op args res_ty) = case op of
   op@(StgPrimOp primOp)
-    | primOp == SeqOp || primOp == DataToTagOp
+    | primOp == DataToTagOp
     -- see Note [Rewriting primop arguments]
     -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
   _ -> pure $! StgOpApp op args res_ty


=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -68,11 +68,6 @@ cgExpr  :: CgStgExpr -> FCode ReturnKind
 
 cgExpr (StgApp fun args)     = cgIdApp fun args
 
--- seq# a s ==> a
--- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
-  cgIdApp a []
-
 -- dataToTagLarge# :: a_levpoly -> Int#
 -- See Note [DataToTag overview] in GHC.Tc.Instance.Class
 -- TODO: There are some more optimization ideas for this code path
@@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
        ; return AssignedDirectly
        }
 
-{- Note [Handle seq#]
-~~~~~~~~~~~~~~~~~~~~~
-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.
-The special case for seq# in cgCase does this:
-
-  case seq# a s of v
-    (# s', a' #) -> e
-==>
-  case a of v
-    (# s', a' #) -> e
-
-(taking advantage of the fact that the return convention for (# State#, a #)
-is the same as the return convention for just 'a')
--}
-
-cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
-  = -- Note [Handle seq#]
-    -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold
-    -- Use the same return convention as vanilla 'a'.
-    cgCase (StgApp a []) bndr alt_type alts
-
 cgCase scrut bndr alt_type alts
   = -- the general case
     do { platform <- getPlatform


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1637,7 +1637,6 @@ emitPrimOp cfg primop =
   CompactAdd -> alwaysExternal
   CompactAddWithSharing -> alwaysExternal
   CompactSize -> alwaysExternal
-  SeqOp -> alwaysExternal
   GetSparkOp -> alwaysExternal
   NumSparks -> alwaysExternal
   DataToTagOp -> alwaysExternal


=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of
 
   ParOp     -> \[r] [_a] -> pure $ PrimInline $ r |= zero_
   SparkOp   -> \[r] [a]  -> pure $ PrimInline $ r |= a
-  SeqOp     -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e])
   NumSparks -> \[r] []   -> pure $ PrimInline $ r |= zero_
 
 ------------------------------ Tag to enum stuff --------------------------------


=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -60,7 +60,7 @@ import GHC.Stg.Syntax
 import GHC.Tc.Utils.TcType
 
 import GHC.Builtin.Names
-import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)
+import GHC.Builtin.PrimOps (primOpIsReallyInline)
 
 import GHC.Types.RepType
 import GHC.Types.Var
@@ -423,8 +423,6 @@ isInlineExpr v = \case
     -> (emptyUniqSet, True)
   StgOpApp (StgFCallOp f _) _ _
     -> (emptyUniqSet, isInlineForeignCall f)
-  StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t
-    -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t)
   StgOpApp (StgPrimOp op) _ _
     -> (emptyUniqSet, primOpIsReallyInline op)
   StgOpApp (StgPrimCallOp _c) _ _


=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -31,6 +31,7 @@ module GHC.Types.Id.Make (
         realWorldPrimId,
         voidPrimId, voidArgId,
         nullAddrId, seqId, lazyId, lazyIdKey,
+        seqHashId, seqHashIdName, seqHashIdKey,
         coercionTokenId, coerceId,
         proxyHashId,
         nospecId, nospecIdName,
@@ -172,7 +173,14 @@ wiredInIds
   ++ errorIds           -- Defined in GHC.Core.Make
 
 magicIds :: [Id]    -- See Note [magicIds]
-magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId]
+magicIds
+  = [ lazyId
+    , oneShotId
+    , noinlineId
+    , noinlineConstraintId
+    , nospecId
+    , seqHashId
+    ]
 
 ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
 ghcPrimIds
@@ -1845,10 +1853,11 @@ leftSectionName   = mkWiredInIdName gHC_PRIM  (fsLit "leftSection")    leftSecti
 rightSectionName  = mkWiredInIdName gHC_PRIM  (fsLit "rightSection")   rightSectionKey    rightSectionId
 
 -- Names listed in magicIds; see Note [magicIds]
-lazyIdName, oneShotName, nospecIdName :: Name
+lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name
 lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId
 oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId
 nospecIdName      = mkWiredInIdName gHC_MAGIC (fsLit "nospec")         nospecIdKey        nospecId
+seqHashIdName     = mkWiredInIdName gHC_MAGIC (fsLit "seq#")           seqHashIdKey       seqHashId
 
 ------------------------------------------------
 proxyHashId :: Id
@@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info
     concs = mkRepPolyIdConcreteTyVars
         [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]
 
+------------------------------------------------
+seqHashId :: Id
+-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
+seqHashId = pcMiscPrelId seqHashIdName ty info
+  where
+    info = noCafIdInfo `setArityInfo`  2
+                       `setDmdSigInfo` dmd_sig
+    -- forall a b. a -> State# b -> (# State# b, a #)
+    ty  = mkSpecForAllTys [alphaTyVar,deltaTyVar]
+        $ mkVisFunTyMany alphaTy
+        $ mkVisFunTyMany state_ty
+        $ mkTupleTy Unboxed [state_ty, alphaTy]
+    state_ty = mkStatePrimTy deltaTy
+    dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv
+      -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2)
+      -- NB: topSubDmd because we don't know how its value is used
+
 ----------------------------------------------------------------------
 {- Note [Wired-in Ids for rebindable syntax]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
libraries/base/src/GHC/Exts.hs
=====================================
@@ -105,7 +105,7 @@ module GHC.Exts
         currentCallStack,
 
         -- * Ids with special behaviour
-        inline, noinline, lazy, oneShot, considerAccessible,
+        inline, noinline, lazy, oneShot, considerAccessible, seq#,
 
         -- * SpecConstr annotations
         SpecConstrAnnotation(..), SPEC (..),


=====================================
libraries/ghc-prim/GHC/Magic.hs
=====================================
@@ -1,6 +1,8 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -24,7 +26,7 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where
+module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where
 
 --------------------------------------------------
 --        See Note [magicIds] in GHC.Types.Id.Make
@@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r).
 {-# NOINLINE runRW# #-}  -- runRW# is inlined manually in CorePrep
 runRW# m = m realWorld#
 
+-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to
+-- breaking changes. For example, this magic Id used to live in "GHC.Prim".
+-- Prefer to use 'GHC.IO.evaluate' whenever possible!
+seq# :: forall a s. a -> State# s -> (# State# s, a #)
+-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
+{-# NOINLINE seq# #-}  -- seq# is inlined manually in CorePrep
+seq# !a s = (# s, a #)
+
 -- | @'dataToTag#'@ evaluates its argument and returns the index
 -- (starting at zero) of the constructor used to produce that
 -- argument.  Any algebraic data type with all of its constructors


=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -17,23 +17,23 @@ T15226b.testFun1
      -> b
      -> GHC.Prim.State# GHC.Prim.RealWorld
      -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #)
-[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
+[GblId, Arity=3, Str=<ML><ML><L>, Unf=OtherCon []] =
     {} \r [x y void]
-        case seq# [x GHC.Prim.void#] of ds1 {
-        Solo# ipv1 [Occ=Once1] ->
+        case x of sat {
+        __DEFAULT ->
+        case y of conrep {
+        __DEFAULT ->
         let {
           sat [Occ=Once1] :: T15226b.StrictPair a b
           [LclId] =
-              {ipv1, y} \u []
-                  case y of conrep {
-                  __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep];
-                  };
-        } in  seq# [sat GHC.Prim.void#];
+              T15226b.MkStrictPair! [sat conrep];
+        } in  Solo# [sat];
+        };
         };
 
 T15226b.testFun
   :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b)
-[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
+[GblId, Arity=3, Str=<ML><ML><L>, Unf=OtherCon []] =
     {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#;
 
 T15226b.MkStrictPair [InlPrag=CONLIKE]



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

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


More information about the ghc-commits mailing list