[Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri Dec 15 17:02:12 UTC 2023
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
0fd053c4 by Sebastian Graf at 2023-12-15T18:01:38+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.
- - - - -
20 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/DmdAnal.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/core-to-stg/T24124.hs
- + testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/core-to-stg/all.T
- 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,63 @@ 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 saturated 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)
+ Mainly for reasons of backwards compatibility, we recognise `seq#` during
+ Demand Analysis as not throwing a precise exception by the mechanism
+ implementing Note [Precise exceptions and strictness analysis].
+ More concretely, `case seq# x s of (# s', x' #) -> y` is detected strict in
+ `y`, which is how all PrimOps except `raiseIO#` are treated.
+
+(SEQ4)
+ 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.Core.Opt.DmdAnal.exprMayThrowPreciseException: return False for seq#.
+
+- 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].
+ We are only inlining `seq#`, leaving opportunities for case-of-known-con
+ behind for `case seq# f 13 s of (# s', r #) -> rhs`. These are easily picked
+ up by Unarise and we get `case f 13 of sat { __DEFAULT -> Solo# [sat] }`,
+ which is good enough.
+
+ 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 +2219,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/DmdAnal.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.FamInstEnv
import GHC.Core.Opt.Arity ( typeArity )
import GHC.Core.Opt.WorkWrap.Utils
+import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
@@ -602,16 +603,21 @@ exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException envs e
| not (forcesRealWorld envs (exprType e))
= False -- 1. in the Note
- | (Var f, _) <- collectArgs e
+ | Var f <- fn
, Just op <- isPrimOpId_maybe f
, op /= RaiseIOOp
= False -- 2. in the Note
- | (Var f, _) <- collectArgs e
+ | Var f <- fn
, Just fcall <- isFCallId_maybe f
, not (isSafeForeignCall fcall)
= False -- 3. in the Note
+ | Var f <- fn
+ , f `hasKey` seqHashIdKey
+ = False -- 3. in the Note
| otherwise
= True -- _. in the Note
+ where
+ (fn, _) = collectArgs e
-- | Recognises types that are
-- * @State# RealWorld@
@@ -799,14 +805,16 @@ For an expression @f a1 ... an :: ty@ we determine that
(Why not simply unboxed pairs as above? This is motivated by
T13380{d,e}.)
2. False If f is a PrimOp, and it is *not* raiseIO#
- 3. False If f is an unsafe FFI call ('PlayRisky')
+ 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic].
+ 4. False If f is an unsafe FFI call ('PlayRisky')
_. True Otherwise "give up".
It is sound to return False in those cases, because
1. We don't give any guarantees for unsafePerformIO, so no precise exceptions
from pure code.
2. raiseIO# is the only primop that may throw a precise exception.
- 3. Unsafe FFI calls may not interact with the RTS (to throw, for example).
+ 3. `seq# = \(!a) s -> (# a, s #)`, so it does not throw a precise exception.
+ 4. Unsafe FFI calls may not interact with the RTS (to throw, for example).
See haddock on GHC.Types.ForeignCall.PlayRisky.
We *need* to return False in those cases, because
@@ -814,7 +822,8 @@ We *need* to return False in those cases, because
2. We would lose strictness for primops like getMaskingState#, which
introduces a substantial regression in
GHC.IO.Handle.Internals.wantReadableHandle.
- 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData,
+ 3. `seq#` used to be a PrimOp and we want to stay backwards compatible.
+ 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData,
where an intermittent FFI call to c_MD5Init would otherwise lose
strictness on the arguments len and buf, leading to regressions in T9203
(2%) and i386's haddock.base (5%). Tested by T13380f.
=====================================
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,38 @@ 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 token]
+ | f `hasKey` seqHashIdKey
+ -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) },
+ -- allocating a Float for (case thing of res { __DEFAULT -> _ })
+ -- and turning token into a CpeArg as needed
+ = do { (floats1, thing) <- cpeBody env thing
+ ; (floats2, token) <- cpeArg env topDmd token
+ ; case_bndr <- newVar ty
+ ; let tup = mkCoreUnboxedTuple [token, Var case_bndr]
+ ; let is_unlifted = False -- otherwise seq# would not type-check
+ ; let float = mkCaseFloat is_unlifted case_bndr thing
+ ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }
+
cpe_app env (Var v) args
= do { v1 <- fiddleCCall v
; let e2 = lookupCorePrepEnv env v1
@@ -1120,13 +1151,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 +1213,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 +1228,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 +1512,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 +1735,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 +1893,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 +2062,38 @@ 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)
+{-
+Eventually we want the following code, when #20749 is fixed.
+Unfortunately, today it breaks T24124.
+ | 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 +2111,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 +2144,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/core-to-stg/T24124.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import Debug.Trace
+import GHC.IO
+import GHC.ST
+
+data StrictPair a b = !a :*: !b
+
+strictFun :: Int -> Int
+{-# OPAQUE strictFun #-}
+strictFun x = x*x*x
+
+opaqueId :: a -> a
+{-# OPAQUE opaqueId #-}
+{-# RULES
+ "opaqueId/noinline" opaqueId = noinline
+#-}
+-- work around noinline's special desugaring
+opaqueId v = v
+
+evaluateST :: a -> ST s a
+-- hide the fact that we are actually in IO because !11515
+-- causes seq# to look like it can throw precise exceptions
+evaluateST x = ST (\s -> seq# x s)
+
+fun :: Int -> Int -> ST s Int
+{-# OPAQUE fun #-}
+fun = lazy $ \ !x y -> do
+ -- This should evaluate x before y.
+ _ <- evaluateST $ opaqueId (x :*: x)
+ _ <- evaluateST y
+ evaluateST $! strictFun x
+
+main :: IO ()
+main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13))
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -0,0 +1,2 @@
+x eval'd
+y eval'd
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O'])
test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep'])
test('T23914', normal, compile, ['-O'])
test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques'])
+test('T24124', normal, compile_and_run, ['-O'])
=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -17,23 +17,21 @@ 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] ->
- 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#];
+ case x of sat {
+ __DEFAULT ->
+ case y of conrep {
+ __DEFAULT ->
+ case T15226b.MkStrictPair [sat conrep] of sat {
+ __DEFAULT -> 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/0fd053c463bfd7cb1de25ec8c9174e31ea1a0d7c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fd053c463bfd7cb1de25ec8c9174e31ea1a0d7c
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/20231215/8686438e/attachment-0001.html>
More information about the ghc-commits
mailing list