[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:01 UTC 2023
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
a24a24f7 by Sebastian Graf at 2023-12-13T14:08:16+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,12 +2060,27 @@ 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
@@ -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/a24a24f77d84c2f96df458dcc701a0d44bc7e81f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a24a24f77d84c2f96df458dcc701a0d44bc7e81f
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/1cde11a7/attachment-0001.html>
More information about the ghc-commits
mailing list