[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 Apr 17 10:40:01 UTC 2024
Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC
Commits:
e6558ece by Sebastian Graf at 2024-04-17T12:39:41+02: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 making
`seq#` a known-key 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.
- - - - -
26 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/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/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/ghci.debugger/scripts/T19394.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/simplStg/should_compile/T15226b.stderr
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -273,6 +273,9 @@ basicKnownKeyNames
-- DataToTag
dataToTagClassName,
+ -- seq#
+ seqHashName,
+
-- Dynamic
toDynName,
@@ -1419,6 +1422,10 @@ nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey
dataToTagClassName :: Name
dataToTagClassName = clsQual gHC_MAGIC (fsLit "DataToTag") dataToTagClassKey
+-- seq#
+seqHashName :: Name
+seqHashName = varQual gHC_MAGIC (fsLit "seq#") seqHashKey
+
-- Custom type errors
errorMessageTypeErrorFamName
, typeErrorTextDataConName
@@ -2373,7 +2380,7 @@ rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
-thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique
+thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
@@ -2408,6 +2415,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
rationalToFloatIdKey = mkPreludeMiscIdUnique 132
rationalToDoubleIdKey = mkPreludeMiscIdUnique 133
+seqHashKey = 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
=====================================
@@ -3656,13 +3656,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
=====================================
@@ -855,7 +855,6 @@ primOpRules nm = \case
AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
- SeqOp -> mkPrimOpRule nm 4 [ seqRule ]
SparkOp -> mkPrimOpRule nm 4 [ sparkRule ]
_ -> Nothing
@@ -2072,60 +2071,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
@@ -2213,7 +2158,9 @@ builtinRules
platform <- getPlatform
return $ Var (primOpId IntAndOp)
`App` arg `App` mkIntVal platform (d - 1)
- ]
+ ],
+
+ mkBasicRule seqHashName 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` seqHashKey
+ = False -- 3. in the Note
| otherwise
= True -- _. in the Note
+ where
+ (fn, _) = collectArgs e
-- | Recognises types that are
-- * @State# RealWorld@
@@ -799,14 +805,18 @@ 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#` used to be a primop that did not throw a precise exception.
+ We keep it that way for back-compat.
+ See the implementation bits 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 +824,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
=====================================
@@ -58,9 +58,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, seqHashKey )
import GHC.Data.Maybe ( isNothing, orElse, mapMaybe )
import GHC.Data.FastString
@@ -3427,7 +3426,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
@@ -3449,7 +3448,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` seqHashKey
, let x' = zapIdOccInfoAndSetEvald MarkedStrict x
= [s, x']
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -159,19 +159,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
@@ -306,6 +306,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
@@ -596,7 +603,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) }
@@ -649,7 +656,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
@@ -681,7 +688,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)) })
@@ -843,13 +850,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
@@ -938,14 +955,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -987,7 +1004,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)
@@ -1006,9 +1023,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.
@@ -1021,7 +1038,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.
@@ -1031,7 +1048,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
@@ -1057,24 +1074,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` seqHashKey
+ -- 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
@@ -1121,13 +1153,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
@@ -1183,13 +1215,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)
@@ -1198,10 +1230,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,20 +1513,26 @@ 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]
- ; let arity = cpeArgArity env dec arg2
+ else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
+ -- See Note [Pin demand info on floats]
+ ; let arity = cpeArgArity env dec floats1 arg2
arg3 = cpeEtaExpand arity 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) }
}
-cpeArgArity :: CorePrepEnv -> FloatDecision -> CoreArg -> Arity
+cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity
-- ^ See Note [Eta expansion of arguments in CorePrep]
-- Returning 0 means "no eta-expansion"; see cpeEtaExpand
-cpeArgArity env float_decision arg
+cpeArgArity env float_decision floats1 arg
| FloatNone <- float_decision
- = 0 -- Crucial short-cut
+ -- If we did not float
+ , not (isEmptyFloats floats1)
+ -- ... but there was something to float
+ , fs_info floats1 `floatsAtLeastAsFarAs` LazyContextFloatable
+ -- ... and we could have floated it out of a lazy arg
+ = 0 -- ... then short-cut, because floats1 is likely expensive!
-- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]
| Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2
@@ -1672,7 +1710,7 @@ There is a nasty Wrinkle:
The alternative would be to fix Note [Eta expansion for join points], but
that's quite challenging due to unfoldings of (recursive) join points.
-(EA2) In cpeArgArity, if float_decision = FloatNone) the `arg` will look like
+(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like
let <binds> in rhs
where <binds> is non-empty and can't be floated out of a lazy context (see
`wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0
@@ -1704,6 +1742,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1817,6 +1900,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`.
@@ -1983,23 +2069,43 @@ zipFloats = appFloats
zipManyFloats :: [Floats] -> Floats
zipManyFloats = foldr zipFloats emptyFloats
-mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
-mkNonRecFloat env dmd is_unlifted bndr rhs
+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
= -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)
-- <+> ppr is_lifted <+> ppr is_strict
-- <+> ppr ok_for_spec
-- $$ ppr rhs) $
- Float (NonRec bndr' rhs) bound info
+ 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
@@ -2017,6 +2123,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs
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)
@@ -2049,7 +2156,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)
@@ -2510,7 +2617,7 @@ cpeBigNatLit env i = assert (i >= 0) $ do
let
litAddrRhs = Lit (LitString words)
-- not "mkLitString"; that does UTF-8 encoding, which we don't want here
- litAddrFloat = mkNonRecFloat env topDmd True litAddrId litAddrRhs
+ litAddrFloat = mkNonRecFloat env True litAddrId litAddrRhs
contentsLength = mkIntLit platform (toInteger (BS.length words))
=====================================
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
=====================================
@@ -498,7 +498,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
=====================================
@@ -67,11 +67,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
@@ -550,27 +545,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
=====================================
@@ -1012,7 +1012,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
@@ -437,8 +437,6 @@ isInlineExpr = \case
-> True
StgOpApp (StgFCallOp f _) _ _
-> isInlineForeignCall f
- StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t
- -> ctxIsEvaluated e || isStrictType t
StgOpApp (StgPrimOp op) _ _
-> primOpIsReallyInline op
StgOpApp (StgPrimCallOp _c) _ _
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -157,11 +157,12 @@ The magicIds
* May have IdInfo that differs from what would be imported from GHC.Magic.hi.
For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic].
- The two remaining identifiers in GHC.Magic, runRW# and inline, are not listed
- in magicIds: they have special behavior but they can be known-key and
+ The three remaining identifiers in GHC.Magic, runRW#, seq# and inline, are not
+ listed in magicIds: they have special behavior but they can be known-key and
not wired-in.
runRW#: see Note [Simplification of runRW#] in Prep, runRW# code in
- Simplifier, Note [Linting of runRW#].
+ Simplifier, Note [Linting of runRW#].
+ seq#: see Note [seq# magic]
inline: see Note [inlineId magic]
-}
@@ -2237,8 +2238,95 @@ 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.
+This implies that GHC's optimisations must preserve the evaluation "exactly
+here", in the state thread.
+
+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 = let !a' = lazy a in (# s, a #)
+
+Things to note
+
+(SEQ1)
+ It must be NOINLINE, because otherwise the eval !a' would be decoupled from
+ the state token s, and GHC's optimisations, in particular strictness analysis,
+ would happily move the eval around.
+
+ 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)
+ The use of `lazy` ensures that strictness analysis does not see the eval
+ that takes place, so the final demand signature is <L><L>, not <1L><L>.
+ This is important for a definition like
+
+ foo x y = evaluate y >> evaluate x
+
+ Although both y and x are ultimately evaluated, the user made it clear
+ they want to evaluate y *before* x.
+ But if strictness analysis sees the evals, it infers foo as strict in
+ both parameters. This strictness would be exploited in the backend by
+ picking a call-by-value calling convention for foo, one that would evaluate
+ x *before* y. Nononono!
+
+(SEQ3)
+ Why does seq# return the value? Consider
+ let x = e in
+ case seq# x s of (# _, x' #) -> ... x' ... case x' of __DEFAULT -> ...
+ Here, we could simply use x instead of x', but doing so would
+ introduce an unnecessary indirection and tag check at runtime;
+ also we can attach an evaldUnfolding to x' to discard any
+ subsequent evals such as the `case x' of __DEFAULT`.
+
+Implementing seq#. The compiler has magic for `seq#` in
+
+- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+
+- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see
+ Note [Adding evaluatedness info to pattern-bound variables]
+ in GHC.Core.Opt.Simplify.Iteration
+
+- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException:
+ Historically, seq# used to be a primop, and the majority of primops
+ should return False in exprMayThrowPreciseException, so we do the same
+ for seq# for back compat.
+
+- 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 [oneShot magic]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~
In the context of making left-folds fuse somewhat okish (see ticket #7994
and Note [Left folds via right fold]) it was determined that it would be useful
if library authors could explicitly tell the compiler that a certain lambda is
=====================================
libraries/base/src/GHC/Base.hs
=====================================
@@ -47,7 +47,7 @@ module GHC.Base
, unpackNBytes#
-- * Magic combinators
- , inline, noinline, lazy, oneShot, runRW#, DataToTag(..)
+ , inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..)
, WithDict(withDict)
-- * Functions over 'Bool'
=====================================
libraries/base/src/GHC/Exts.hs
=====================================
@@ -90,6 +90,7 @@ module GHC.Exts
lazy,
oneShot,
considerAccessible,
+ seq#,
-- * SpecConstr annotations
SpecConstrAnnotation(..),
SPEC(..),
=====================================
libraries/ghc-internal/src/GHC/Internal/Exts.hs
=====================================
@@ -105,7 +105,7 @@ module GHC.Internal.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
@@ -58,8 +60,8 @@ inline x = x
-- | The call @noinline f@ arranges that @f@ will not be inlined.
-- It is removed during CorePrep so that its use imposes no overhead
-- (besides the fact that it blocks inlining.)
-{-# NOINLINE noinline #-}
noinline :: a -> a
+{-# NOINLINE noinline #-} -- noinline is inlined manually in CorePrep
noinline x = x
-- | The 'lazy' function restrains strictness analysis a little. The
@@ -79,6 +81,7 @@ noinline x = x
-- If 'lazy' were not lazy, 'Control.Parallel.par' would look strict in
-- @y@ which would defeat the whole purpose of 'Control.Parallel.par'.
lazy :: a -> a
+{-# NOINLINE lazy #-} -- lazy is inlined manually in CorePrep
lazy x = x
-- Implementation note: its strictness and unfolding are over-ridden
-- by the definition in GHC.Types.Id.Make; in both cases to nothing at all.
@@ -119,6 +122,20 @@ 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 = let !a' = lazy lazy a in (# s, a' #)
+ -- Why `lazy lazy`? Because lazy is defined in this same module and DmdAnal
+ -- will infer its own, strict demand signature for its RHS instead of using
+ -- the signature attached to wired-in Id. Since lazy is NOINLINE, the
+ -- second-order call `lazy lazy` will obscure the definition.
+ -- Alternatives: (1) put seq# into a different module, or
+ -- (2) handle lazy specially during Demand Analysis
+
-- | @'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,5 @@ 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'])
+# T24124b: Do not make f strict. But semantics of seq# is broken; need strictnessBarrier
+test('T24124b', [expect_broken(22935), exit_code(1)], compile_and_run, [''])
=====================================
testsuite/tests/ghci.debugger/scripts/T19394.stdout
=====================================
@@ -7,5 +7,5 @@ Identifier ‘void#’ is not eligible for the :print, :sprint or :force command
error = (_t1::GHC.Internal.Stack.Types.HasCallStack => [Char] -> a)
oneShot = (_t2::(a -> b) -> a -> b)
xor# = (_t3::Word# -> Word# -> Word#)
-seq# = (_t4::a -> State# d -> (# State# d, a #))
+seq# = (_t4::a -> State# s -> (# State# s, a #))
lazy = (_t5::a -> a)
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4581,7 +4581,7 @@ module GHC.Base where
sameSmallMutableArray# :: forall {l :: Levity} s (a :: TYPE (BoxedRep l)). SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
sameTVar# :: forall {l :: Levity} s (a :: TYPE (BoxedRep l)). TVar# s a -> TVar# s a -> Int#
seq :: forall {r :: RuntimeRep} a (b :: TYPE r). a -> b -> b
- seq# :: forall a d. a -> State# d -> (# State# d, a #)
+ seq# :: forall a s. a -> State# s -> (# State# s, a #)
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
@@ -6686,7 +6686,7 @@ module GHC.Exts where
sameSmallMutableArray# :: forall {l :: Levity} s (a :: TYPE (BoxedRep l)). SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
sameTVar# :: forall {l :: Levity} s (a :: TYPE (BoxedRep l)). TVar# s a -> TVar# s a -> Int#
seq :: forall {r :: RuntimeRep} a (b :: TYPE r). a -> b -> b
- seq# :: forall a d. a -> State# d -> (# State# d, a #)
+ seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
=====================================
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=<1L><1L><L>, Cpr=1(, 1), Unf=OtherCon []] =
{} \r [x y void]
- case seq# [x GHC.Prim.void#] of ds1 {
- (# #) 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 (# #) [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=<1L><1L><L>, Cpr=1(, 1), 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/e6558ece95c090a0f69e03099422e2df885188a5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6558ece95c090a0f69e03099422e2df885188a5
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/20240417/931df1ff/attachment-0001.html>
More information about the ghc-commits
mailing list