[Git][ghc/ghc][wip/T24124] 2 commits: Make `seq#` a magic Id and inline it in CorePrep (#24124)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri Jan 12 14:43:23 UTC 2024
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
255a3a22 by Sebastian Graf at 2024-01-12T15:17:42+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.
- - - - -
c362c078 by Sebastian Graf at 2024-01-12T15:43:02+01:00
Move Note [seq# magic] to GHC.Types.Id.Make
- - - - -
22 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/dmdanal/should_run/T24124b.hs
- testsuite/tests/dmdanal/should_run/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
=====================================
@@ -920,11 +920,10 @@ 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
DataToTagSmallOp -> False
DataToTagLargeOp -> False
- p -> not (primOpOutOfLine p)
+ 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 )
@@ -822,7 +822,6 @@ primOpRules nm = \case
AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
- SeqOp -> mkPrimOpRule nm 4 [ seqRule ]
SparkOp -> mkPrimOpRule nm 4 [ sparkRule ]
_ -> Nothing
@@ -2039,60 +2038,6 @@ unsafeEqualityProofRule
* *
********************************************************************* -}
-{- Note [seq# magic]
-~~~~~~~~~~~~~~~~~~~~
-The primop
- seq# :: forall a s . a -> State# s -> (# State# s, a #)
-
-is /not/ the same as the Prelude function seq :: a -> b -> b
-as you can see from its type. In fact, seq# is the implementation
-mechanism for 'evaluate'
-
- evaluate :: a -> IO a
- evaluate a = IO $ \s -> seq# a s
-
-The semantics of seq# is
- * evaluate its first argument
- * and return it
-
-Things to note
-
-* Why do we need a primop at all? That is, instead of
- case seq# x s of (# x, s #) -> blah
- why not instead say this?
- case x of { DEFAULT -> blah }
-
- Reason (see #5129): if we saw
- catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
-
- then we'd drop the 'case x' because the body of the case is bottom
- anyway. But we don't want to do that; the whole /point/ of
- seq#/evaluate is to evaluate 'x' first in the IO monad.
-
- 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
- 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
-
-- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
-
-- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
-
-- 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.
--}
-
seqRule :: RuleM CoreExpr
seqRule = do
[Type _ty_a, Type _ty_s, a, s] <- getArgs
@@ -2180,7 +2125,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,17 @@ 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.
+ See point (SEQ3) of Note [seq# magic] in GHC.Types.Id.Make.
+ 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 +823,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
@@ -3348,7 +3347,7 @@ NB: simplLamBndrs preserves this eval info
In addition to handling data constructor fields with !s, addEvals
also records the fact that the result of seq# is always in WHNF.
-See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226):
+See Note [seq# magic] in GHC.Types.Id.Make. Example (#15226):
case seq# v s of
(# s', v' #) -> E
@@ -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,39 @@ 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 the step 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 token of s { __DEFAULT ->
+ -- case thing of res { __DEFAULT -> (# token, res#) } },
+ -- allocating CaseBound Floats for token and thing as needed
+ = do { (floats1, token) <- cpeArg env topDmd token
+ ; (floats2, thing) <- cpeBody env thing
+ ; 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 +1152,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 +1214,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 +1229,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 +1513,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 +1736,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 +1894,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 +2063,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 +2112,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 +2145,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
=====================================
@@ -506,7 +506,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 == DataToTagSmallOp || primOp == DataToTagLargeOp
+ | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp
-- 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 []
-
-- dataToTagSmall# :: a_levpoly -> Int#
-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,
-- particularly wrinkles H3 and DTW4
@@ -549,27 +544,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
-
{-
Note [Eliminate trivial Solo# continuations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1729,7 +1729,6 @@ emitPrimOp cfg primop =
CompactAdd -> alwaysExternal
CompactAddWithSharing -> alwaysExternal
CompactSize -> alwaysExternal
- SeqOp -> alwaysExternal
GetSparkOp -> alwaysExternal
NumSparks -> alwaysExternal
DataToTagSmallOp -> alwaysExternal
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1007,7 +1007,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
=====================================
@@ -61,7 +61,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
@@ -427,8 +427,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
@@ -1843,10 +1851,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
@@ -1961,6 +1970,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info
concs = mkRepPolyIdConcreteTyVars
[((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]
+------------------------------------------------
+seqHashId :: Id
+-- See Note [seq# magic] in GHC.Types.Id.Make
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2238,6 +2264,137 @@ This is crucial: otherwise, we could import an unfolding in which
* To defeat the specialiser when we have incoherent instances.
See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv.
+Note [seq# magic]
+~~~~~~~~~~~~~~~~~
+The purpose of the magic Id (See Note [magicIds])
+
+ seq# :: forall a s . a -> State# s -> (# State# s, a #)
+
+is to elevate evaluation of its argument `a` into an observable
+side effect.
+It is /not/ the same as the Prelude function seq :: a -> b -> b:
+First off, the type is different, but also GHC makes no guarantees that
+evaluation ordering using `seq` is maintained throughout optimisations, only
+termination behavior.
+
+The main use of seq# is to implement `evaluate`
+
+ evaluate :: a -> IO a
+ evaluate a = IO $ \s -> seq# a s
+
+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
+
+(SEQ1)
+ Clearly, the definition given above satisfies the precise semantics,
+ because any side effect in the chain to `s` must have been evaluated before
+ the call. 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 }
+
+ One reason (see #5129): if we saw
+ catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
+
+ then we'd drop the `case x` because the body of the case is bottom
+ anyway (we revisit this decision in #24251).
+ But we don't want to do that; the whole /point/ of
+ seq#/evaluate is to evaluate `x` first in the IO monad.
+
+ 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)
+ We set the strictness signature of `seq#` to <ML><L> in GHC.Types.Id.Make,
+ despite its definition having the stricter signature <1L><L>.
+
+ That is because `seq#` is intended to mean "evaluate this argument now -- not
+ earlier". Therefore, we must not only NOINLINE `seq#`, we must also take care
+ that we do /not/ expose Demand Analysis to the stricter signature because
+ then it would feel free to rearrange evaluation order to enable unboxing such
+ as in
+
+ foo :: Bool -> Bool -> (Int, Int) -> Int
+ foo True _ (a,b) = a + b
+ foo _ False (a,b) = 1 + a + b
+
+ 'foo' is strict in the pair and its components and we *absolutely* want to
+ unbox it. However, doing so is impossible without affecting evaluation order:
+ Without optimisation, `bar False (error "OK") (error "Not OK")` errors "OK".
+ If we decide to unbox (a,b) and insert an eval on the first (strict) arg in
+ the wrapper as well, we get "Not OK".
+
+ More generally, preserving evaluation order is fundamentally at odds
+ with exploiting the results of Strictness Analysis, and the latter offers
+ huge leverage throughout the compiler.
+ By using `seq#`/`evaluate`, the user explicitly gives up on optimisations to
+ observe evaluations in order.
+
+ More concretely, consider
+ do { evaluate x; evaluate y }
+ Operationally, this should evaluate `x` and then `y`.
+ If `seq#` was visibly strict, they might be evaluated in the opposite order.
+
+(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 (T24124b),
+ f :: Int -> Int -> IO Int
+ f x y = evaluate x >> pure $! y+1
+ historically is strict in `y` and thus unboxed, and changing that would break
+ the performance of client code. We retain the old behavior by treating
+ `seq#` just like any PrimOp except `raiseIO#`.
+
+(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 `seq#` in
+
+- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2))
+
+- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+
+- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ4)); see
+ Note [Adding evaluatedness info to pattern-bound variables]
+ in GHC.Core.Opt.Simplify.Iteration
+
+- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException:
+ return False for seq#. (cf. (SEQ3))
+
+- 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 that are easily picked up by Unarise:
+
+ case seq# f 13 s of (# s', r #) -> rhs
+ ==> {Prep}
+ case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs
+ ==> {Unarise}
+ case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r]
+
+ 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.
+
Note [The oneShot function]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the context of making left-folds fuse somewhat okish (see ticket #7994
=====================================
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.Types.Id.Make
+{-# 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/dmdanal/should_run/T24124b.hs
=====================================
@@ -0,0 +1,9 @@
+import Control.Exception
+
+f :: Int -> Int -> IO Int
+f x y = do
+ evaluate x
+ pure $! y + 1
+{-# NOINLINE f #-}
+
+main = f (error "should see this") (error "should not see this") >> pure ()
=====================================
testsuite/tests/dmdanal/should_run/all.T
=====================================
@@ -33,3 +33,4 @@ test('T22475b', normal, compile_and_run, [''])
# T22549: Do not strictify DFuns, otherwise we will <<loop>>
test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])
test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208'])
+test('T24124b', exit_code(1), compile_and_run, [''])
=====================================
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/-/compare/17e859ded734a6587113608efc6f571267ba8c3c...c362c07867e5cb62c53909bfc6cddffe73691d62
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17e859ded734a6587113608efc6f571267ba8c3c...c362c07867e5cb62c53909bfc6cddffe73691d62
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/20240112/2d3294ab/attachment-0001.html>
More information about the ghc-commits
mailing list