diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-03-16 16:55:48 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-15 10:42:09 -0400 |
| commit | 9bd20e83ff9b65bd5496fbb29d27072c9e4e84b9 (patch) | |
| tree | 1e1686db2b020a4f79eb19cad6ac7d85ad7191f5 | |
| parent | e9c0110ce9e753360d7e6523114109b7616f2f08 (diff) | |
| download | haskell-9bd20e83ff9b65bd5496fbb29d27072c9e4e84b9.tar.gz | |
DmdAnal: Improve handling of precise exceptions
This patch does two things: Fix possible unsoundness in what was called
the "IO hack" and implement part 2.1 of the "fixing precise exceptions"
plan in
https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions,
which, in combination with !2956, supersedes !3014 and !2525.
**IO hack**
The "IO hack" (which is a fallback to preserve precise exceptions
semantics and thus soundness, rather than some smart thing that
increases precision) is called `exprMayThrowPreciseException` now.
I came up with two testcases exemplifying possible unsoundness (if
twisted enough) in the old approach:
- `T13380d`: Demonstrating unsoundness of the "IO hack" when resorting
to manual state token threading and direct use of primops.
More details below.
- `T13380e`: Demonstrating unsoundness of the "IO hack" when we have
Nested CPR. Not currently relevant, as we don't have Nested
CPR yet.
- `T13380f`: Demonstrating unsoundness of the "IO hack" for safe FFI
calls.
Basically, the IO hack assumed that precise exceptions can only be
thrown from a case scrutinee of type `(# State# RealWorld, _ #)`. I
couldn't come up with a program using the `IO` abstraction that violates
this assumption. But it's easy to do so via manual state token threading
and direct use of primops, see `T13380d`. Also similar code might be
generated by Nested CPR in the (hopefully not too) distant future, see
`T13380e`. Hence, we now have a more careful test in `forcesRealWorld`
that passes `T13380{d,e}` (and will hopefully be robust to Nested CPR).
**Precise exceptions**
In #13380 and #17676 we saw that we didn't preserve precise exception
semantics in demand analysis. We fixed that with minimal changes in
!2956, but that was terribly unprincipled.
That unprincipledness resulted in a loss of precision, which is tracked
by these new test cases:
- `T13380b`: Regression in dead code elimination, because !2956 was too
syntactic about `raiseIO#`
- `T13380c`: No need to apply the "IO hack" when the IO action may not
throw a precise exception (and the existing IO hack doesn't
detect that)
Fixing both issues in !3014 turned out to be too complicated and had
the potential to regress in the future. Hence we decided to only fix
`T13380b` and augment the `Divergence` lattice with a new middle-layer
element, `ExnOrDiv`, which means either `Diverges` (, throws an
imprecise exception) or throws a *precise* exception.
See the wiki page on Step 2.1 for more implementational details:
https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions#dead-code-elimination-for-raiseio-with-isdeadenddiv-introducing-exnordiv-step-21
37 files changed, 808 insertions, 534 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index b92f0de3f0..f51e3b3a68 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -178,7 +178,7 @@ module GHC ( isRecordSelector, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, + isDeadEndId, isDictonaryId, recordSelectorTyCon, -- ** Type constructors diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index a29fbf48d7..0928f8ed61 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -2567,14 +2567,17 @@ section "Exceptions" ------------------------------------------------------------------------ -- Note [Strictness for mask/unmask/catch] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Consider this example, which comes from GHC.IO.Handle.Internals: -- wantReadableHandle3 f ma b st -- = case ... of -- DEFAULT -> case ma of MVar a -> ... --- 0# -> maskAsynchExceptions# (\st -> case ma of MVar a -> ...) +-- 0# -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...) -- The outer case just decides whether to mask exceptions, but we don't want --- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd. +-- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd +-- in mask and unmask. But catch really is lazy in its first argument, see +-- #11555. So for IO actions 'ma' we often use a wrapper around it that is +-- head-strict in 'ma': GHC.IO.catchException. primop CatchOp "catch#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) @@ -2593,13 +2596,16 @@ primop RaiseOp "raise#" GenPrimOp b -> o -- NB: the type variable "o" is "a", but with OpenKind with + -- In contrast to 'raiseIO#', which throws a *precise* exception, + -- exceptions thrown by 'raise#' are considered *imprecise*. + -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand. + -- Hence, it has 'botDiv', not 'exnDiv'. + -- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#' + -- is not), but not as "has_side_effects" (which 'raiseIO#' is). + -- See Note [PrimOp can_fail and has_side_effects] in PrimOp.hs. strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True - has_side_effects = True - -- raise# certainly throws a Haskell exception and hence has_side_effects - -- It doesn't actually make much difference because the fact that it - -- returns bottom independently ensures that we are careful not to discard - -- it. But still, it's better to say the Right Thing. + can_fail = True -- Note [Arithmetic exception primops] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2648,8 +2654,8 @@ primop RaiseIOOp "raiseIO#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, b #) with -- See Note [Precise exceptions and strictness analysis] in Demand.hs - -- for why we give it topDiv - -- strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] topDiv } + -- for why this is the *only* primop that has 'exnDiv' + strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv } out_of_line = True has_side_effects = True diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs index 53e47d9746..935fd7a67b 100644 --- a/compiler/GHC/Core/Arity.hs +++ b/compiler/GHC/Core/Arity.hs @@ -759,8 +759,8 @@ arityType _ (Var v) , not $ isTopSig strict_sig , (ds, res) <- splitStrictSig strict_sig , let arity = length ds - = if isBotDiv res then ABot arity - else ATop (take arity one_shots) + = if isDeadEndDiv res then ABot arity + else ATop (take arity one_shots) | otherwise = ATop (take (idArity v) one_shots) where @@ -787,7 +787,7 @@ arityType env (App fun arg ) -- The difference is observable using 'seq' -- arityType env (Case scrut _ _ alts) - | exprIsBottom scrut || null alts + | exprIsDeadEnd scrut || null alts = ABot 0 -- Do not eta expand -- See Note [Dealing with bottom (1)] | otherwise diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b1f0e8eece..872a081f47 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -64,7 +64,7 @@ import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Arity ( typeArity ) -import GHC.Types.Demand ( splitStrictSig, isBotDiv ) +import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv ) import GHC.Driver.Types import GHC.Driver.Session @@ -651,7 +651,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty ppr binder) ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotDiv result_info -> + (demands, result_info) | isDeadEndDiv result_info -> checkL (demands `lengthAtLeast` idArity binder) (text "idArity" <+> ppr (idArity binder) <+> text "exceeds arity imposed by the strictness signature" <+> @@ -986,7 +986,7 @@ used to check two things: * exprIsHNF is false: it would *seem* to be terribly wrong if the scrutinee was already in head normal form. -* exprIsBottom is true: we should be able to see why GHC believes the +* exprIsDeadEnd is true: we should be able to see why GHC believes the scrutinee is diverging for sure. It was already known that the second test was not entirely reliable. @@ -1182,7 +1182,7 @@ lintCaseExpr scrut var alt_ty alts = , isAlgTyCon tycon , not (isAbstractTyCon tycon) , null (tyConDataCons tycon) - , not (exprIsBottom scrut) + , not (exprIsDeadEnd scrut) -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) -- This can legitimately happen for type families $ return () diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index ef5bb94b23..250942e0f6 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -701,7 +701,7 @@ trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] where max_arity_by_type = length (typeArity (idType v)) max_arity_by_strsig - | isBotDiv result_info = length demands + | isDeadEndDiv result_info = length demands | otherwise = a (demands, result_info) = splitStrictSig (idStrictness v) diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 5d4e650564..b1fcc227ef 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -16,7 +16,7 @@ module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where import GHC.Prelude import GHC.Driver.Session -import GHC.Core.Opt.WorkWrap.Utils ( findTypeShape ) +import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core import GHC.Core.Seq ( seqBinds ) @@ -25,6 +25,7 @@ import GHC.Types.Var.Env import GHC.Types.Basic import Data.List ( mapAccumL ) import GHC.Core.DataCon +import GHC.Types.ForeignCall ( isSafeForeignCall ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Utils @@ -34,7 +35,7 @@ import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv import GHC.Utils.Misc import GHC.Data.Maybe ( isJust ) -import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Unique.Set @@ -151,7 +152,7 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) -dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co) = (unitDmdType (coercionDmdEnv co), Coercion co) @@ -222,8 +223,13 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr id_dmds = addCaseBndrDmd case_bndr_dmd dmds - alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2 - | otherwise = alt_ty2 + fam_envs = ae_fam_envs env + alt_ty3 + -- See Note [Precise exceptions and strictness analysis] in Demand + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty2 + | otherwise + = alt_ty2 -- Compute demand on the scrutinee -- See Note [Demand on scrutinee of a product case] @@ -251,12 +257,20 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts) -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives - res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty + fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in Demand + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty + | otherwise + = alt_ty + res_ty = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty + in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty" <+> ppr alt_ty +-- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ (res_ty, Case scrut' case_bndr' ty alts') @@ -314,16 +328,37 @@ dmdAnal' env dmd (Let (Rec pairs) body) body_ty2 `seq` (body_ty2, Let (Rec pairs') body') -io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool --- See Note [IO hack in the demand analyser] -io_hack_reqd scrut con bndrs - | (bndr:_) <- bndrs - , con == tupleDataCon Unboxed 2 - , idType bndr `eqType` realWorldStatePrimTy - , (fun, _) <- collectArgs scrut - = case fun of - Var f -> not (isPrimOpId f) - _ -> True +-- | A simple, syntactic analysis of whether an expression MAY throw a precise +-- exception when evaluated. It's always sound to return 'True'. +-- See Note [Which scrutinees may throw precise exceptions]. +exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool +exprMayThrowPreciseException envs e + | not (forcesRealWorld envs (exprType e)) + = False -- 1. in the Note + | (Var f, _) <- collectArgs e + , Just op <- isPrimOpId_maybe f + , op /= RaiseIOOp + = False -- 2. in the Note + | (Var f, _) <- collectArgs e + , Just fcall <- isFCallId_maybe f + , not (isSafeForeignCall fcall) + = False -- 3. in the Note + | otherwise + = True -- _. in the Note + +-- | Recognises types that are +-- * @State# RealWorld@ +-- * Unboxed tuples with a @State# RealWorld@ field +-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See +-- T13380e) and user-written variants thereof by their type. +forcesRealWorld :: FamInstEnvs -> Type -> Bool +forcesRealWorld fam_envs ty + | ty `eqType` realWorldStatePrimTy + = True + | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } + <- deepSplitProductType_maybe fam_envs ty + , isUnboxedTupleCon dc + = any (\(ty,_) -> ty `eqType` realWorldStatePrimTy) field_tys | otherwise = False @@ -340,49 +375,42 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) id_dmds = addCaseBndrDmd case_bndr_dmd dmds = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) - -{- Note [IO hack in the demand analyser] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a hack here for I/O operations. Consider - - case foo x s of { (# s', r #) -> y } - -Is this strict in 'y'? Often not! If foo x s performs some observable action -(including raising an exception with raiseIO#, modifying a mutable variable, or -even ending the program normally), then we must not force 'y' (which may fail -to terminate) until we have performed foo x s. - -Hackish solution: spot the IO-like situation and add a virtual branch, -as if we had - case foo x s of - (# s, r #) -> y - other -> return () -So the 'y' isn't necessarily going to be evaluated - -A more complete example (#148, #1592) where this shows up is: - do { let len = <expensive> ; - ; when (...) (exitWith ExitSuccess) - ; print len } - -However, consider - f x s = case getMaskingState# s of - (# s, r #) -> - case x of I# x2 -> ... - -Here it is terribly sad to make 'f' lazy in 's'. After all, -getMaskingState# is not going to diverge or throw an exception! This -situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle -(on an MVar not an Int), and made a material difference. - -So if the scrutinee is a primop call, we *don't* apply the -state hack: - - If it is a simple, terminating one like getMaskingState, - applying the hack is over-conservative. - - If the primop is raise# then it returns bottom, so - the case alternatives are already discarded. - - If the primop can raise a non-IO exception, like - divide by zero or seg-fault (eg writing an array - out of bounds) then we don't mind evaluating 'x' first. +{- Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the specification of 'exprMayThrowPreciseExceptions', +which is important for Scenario 2 of +Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +For an expression @f a1 ... an :: ty@ we determine that + 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. + This check is done by 'forcesRealWorld'. + (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') + _. 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). + See haddock on GHC.Types.ForeignCall.PlayRisky. + +We *need* to return False in those cases, because + 1. We would lose too much strictness in pure code, all over the place. + 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, + 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. + +In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) +to the Divergence lattice, but in practice it turned out to be hard to untaint +from 'topDiv' to 'conDiv', leading to bugs, performance regressions and +complexity that didn't justify the single fixed testcase T13380c. Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -453,27 +481,33 @@ dmdTransform :: AnalEnv -- The strictness environment -- this function plus demand on its free variables dmdTransform env var dmd - | isDataConWorkId var -- Data constructor + -- Data constructors + | isDataConWorkId var = dmdTransformDataConSig (idArity var) dmd - + -- Dictionary component selectors | gopt Opt_DmdTxDictSel (ae_dflags env), - Just _ <- isClassOpId_maybe var -- Dictionary component selector + Just _ <- isClassOpId_maybe var = dmdTransformDictSelSig (idStrictness var) dmd - - | isGlobalId var -- Imported function + -- Imported functions + | isGlobalId var , let res = dmdTransformSig (idStrictness var) dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) res - - | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing + -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). + -- In that case, we have a strictness signature to unleash in our AnalEnv. + | Just (sig, top_lvl) <- lookupSigEnv env var , let fn_ty = dmdTransformSig sig dmd - = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ if isTopLevel top_lvl - then fn_ty -- Don't record top level things + then fn_ty -- Don't record demand on top-level things else addVarDmd fn_ty var (mkOnceUsedDmd dmd) - - | otherwise -- Local non-letrec-bound thing - = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) + -- Everything else: + -- * Local let binders for which we use LetUp (cf. 'useLetUp') + -- * Lambda binders + -- * Case and constructor field binders + | otherwise + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ + unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) {- ************************************************************************ @@ -600,10 +634,9 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs = mkRhsDmd env rhs_arity rhs (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs - -- TODO: Won't the following line unnecessarily trim down arity for join - -- points returning a lambda in a C(S) context? - sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) - id' = setIdStrictness id sig + sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) + id' = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $ + setIdStrictness id sig -- See Note [NOINLINE and strictness] diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 4d759a47bc..9398435ee5 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -407,12 +407,17 @@ floating in cases with a single alternative that may bind values. But there are wrinkles -* Which unlifted cases do we float? See GHC.Builtin.PrimOps - Note [PrimOp can_fail and has_side_effects] which explains: - - We can float-in can_fail primops, but we can't float them out. +* Which unlifted cases do we float? + See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which + explains: + - We can float in can_fail primops (which concerns imprecise exceptions), + but we can't float them out. - But we can float a has_side_effects primop, but NOT inside a lambda, - so for now we don't float them at all. - Hence exprOkForSideEffects + so for now we don't float them at all. Hence exprOkForSideEffects. + - Throwing precise exceptions is a special case of the previous point: We + may /never/ float in a call to (something that ultimately calls) + 'raiseIO#'. + See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. * Because we can float can-fail primops (array indexing, division) inwards but not outwards, we must be careful not to transform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 92a747424f..7bb7acafb0 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -20,7 +20,7 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) -import GHC.Types.Id ( Id, idArity, idType, isBottomingId, +import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) @@ -221,7 +221,7 @@ floatBind (NonRec (TB var _) rhs) -- A tiresome hack: -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels - let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' + let rhs'' | isDeadEndId var = etaExpand (idArity var) rhs' | otherwise = rhs' in (fs, rhs_floats, [NonRec var rhs'']) } diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index 7a28abce20..211fc39920 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -158,8 +158,8 @@ libCaseBind env (Rec pairs) Let (Rec dup_pairs) (Var unitDataConId) ok_pair (id,_) - = idArity id > 0 -- Note [Only functions!] - && not (isBottomingId id) -- Note [Not bottoming ids] + = idArity id > 0 -- Note [Only functions!] + && not (isDeadEndId id) -- Note [Not bottoming ids] {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index ed6f4c61fe..0a1395a432 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -87,7 +87,7 @@ import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) +import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) @@ -293,7 +293,7 @@ lvlTopBind env (Rec pairs) lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr lvl_top env is_rec bndr rhs = lvlRhs env is_rec - (isBottomingId bndr) + (isDeadEndId bndr) Nothing -- Not a join point (freeVars rhs) @@ -943,7 +943,7 @@ Id, *immediately*, for three reasons: Lint complains unless the scrutinee of such a case is clearly bottom. This was reported in #11290. But since the whole bottoming-float - thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure + thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure that it'll nail all such cases. Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] @@ -983,7 +983,7 @@ annotateBotStr id n_extra mb_str = case mb_str of Nothing -> id Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (increaseStrictSigArity n_extra sig) + `setIdStrictness` (prependArgsStrictSig n_extra sig) `setIdCprInfo` mkCprSig (arity + n_extra) botCpr notWorthFloating :: CoreExpr -> [Var] -> Bool diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 340efd2c9c..154b15e9d8 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -3058,7 +3058,7 @@ altsWouldDup (alt:alts) | is_bot_alt alt = altsWouldDup alts | otherwise = not (all is_bot_alt alts) where - is_bot_alt (_,_,rhs) = exprIsBottom rhs + is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv -> SimplCont @@ -3515,7 +3515,7 @@ mkLetUnfolding dflags top_lvl src id new_rhs -- we don't.) The simple thing is always to have one. where is_top_lvl = isTopLevel top_lvl - is_bottoming = isBottomingId id + is_bottoming = isDeadEndId id ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 14e1a08fe0..87948ff6c1 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -58,7 +58,6 @@ import GHC.Types.Var import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic -import GHC.Builtin.PrimOps import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) @@ -499,11 +498,9 @@ mkArgInfo env fun rules n_val_args call_cont -- interesting context. This avoids substituting -- top-level bindings for (say) strings into -- calls to error. But now we are more careful about - -- inlining lone variables, so it's ok - -- (see GHC.Core.Opt.Simplify.Utils.analyseCont) - -- See Note [Precise exceptions and strictness analysis] in Demand.hs - -- for the special case on raiseIO# - if isBotDiv result_info || isPrimOpId_maybe fun == Just RaiseIOOp then + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then map isStrictDmd demands -- Finite => result is bottom else map isStrictDmd demands ++ vanilla_stricts @@ -1145,7 +1142,7 @@ preInlineUnconditionally preInlineUnconditionally env top_lvl bndr rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing - | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids] + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] -- in module Exitify @@ -1517,7 +1514,7 @@ tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr tryEtaExpandRhs mode bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - ; return (count isId join_bndrs, exprIsBottom join_body, rhs) } + ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 780c115857..d2c431765b 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1551,8 +1551,8 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs , ri_lam_body = body, ri_arg_occs = arg_occs }) spec_info@(SI { si_specs = specs, si_n_specs = spec_count , si_mb_unspec = mb_unspec }) - | isBottomingId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS + | isDeadEndId fn -- Note [Do not specialise diverging functions] + -- and do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) @@ -1713,10 +1713,10 @@ calcSpecStrictness :: Id -- The original function -> StrictSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topDiv + = mkClosedStrictSig spec_dmds div where spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idStrictness fn + StrictSig (DmdType _ dmds div) = idStrictness fn dmd_env = go emptyVarEnv dmds pats @@ -1776,10 +1776,10 @@ Note [Transfer strictness] We must transfer strictness information from the original function to the specialised one. Suppose, for example - f has strictness SS + f has strictness SSx and a RULE f (a:as) b = f_spec a as b -Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need +Now we want f_spec to have strictness LLSx, otherwise we'll use call-by-need when calling f_spec instead of call-by-value. And that can result in unbounded worsening in space (cf the classic foldl vs foldl') diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 4c4c3dc5e7..5ea719ac5b 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -1228,7 +1228,10 @@ mk_absent_let dflags fam_envs arg abs_rhs = mkAbsentErrorApp arg_ty msg msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (ppr arg <+> ppr (idType arg)) + (ppr arg <+> ppr (idType arg) <+> file_msg) + file_msg = case outputFile dflags of + Nothing -> empty + Just f -> text "in output file " <+> quotes (text f) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for -- determinism, because with different uniques the strings diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 3e55600461..e8a4e86af1 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -39,7 +39,7 @@ import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.DataCon -import GHC.Types.Demand( etaExpandStrictSig ) +import GHC.Types.Demand( etaConvertStrictSig ) import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) @@ -767,7 +767,7 @@ joinPointBinding_maybe bndr rhs , let str_sig = idStrictness bndr str_arity = count isId bndrs -- Strictness demands are for Ids only join_bndr = bndr `asJoinId` join_arity - `setIdStrictness` etaExpandStrictSig str_arity str_sig + `setIdStrictness` etaConvertStrictSig str_arity str_sig = Just (join_bndr, mkLams bndrs body) | otherwise diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 42a8974b54..bf281e7246 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -53,7 +53,7 @@ import GHC.Core.SimpleOpt import GHC.Core.Arity ( manifestArity ) import GHC.Core.Utils import GHC.Types.Id -import GHC.Types.Demand ( StrictSig, isBottomingSig ) +import GHC.Types.Demand ( StrictSig, isDeadEndSig ) import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps @@ -86,7 +86,7 @@ mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfo mkFinalUnfolding dflags src strict_sig expr = mkUnfolding dflags src True {- Top level -} - (isBottomingSig strict_sig) + (isDeadEndSig strict_sig) expr mkCompulsoryUnfolding :: CoreExpr -> Unfolding @@ -1150,7 +1150,7 @@ certainlyWillInline dflags fn_info -- See Note [certainlyWillInline: INLINABLE] do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] - , not (isBottomingSig (strictnessInfo fn_info)) + , not (isDeadEndSig (strictnessInfo fn_info)) -- Do not unconditionally inline a bottoming functions even if -- it seems smallish. We've carefully lifted it out to top level, -- so we don't want to re-inline it. diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 6faf179489..b9f4a63eb5 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,7 +23,7 @@ module GHC.Core.Utils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, isExprLevPoly, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, @@ -1031,21 +1031,21 @@ getIdFromTrivialExpr_maybe e go _ = Nothing {- -exprIsBottom is a very cheap and cheerful function; it may return +exprIsDeadEnd is a very cheap and cheerful function; it may return False for bottoming expressions, but it never costs much to ask. See also GHC.Core.Arity.exprBotStrictness_maybe, but that's a bit more expensive. -} -exprIsBottom :: CoreExpr -> Bool +exprIsDeadEnd :: CoreExpr -> Bool -- See Note [Bottoming expressions] -exprIsBottom e +exprIsDeadEnd e | isEmptyTy (exprType e) = True | otherwise = go 0 e where - go n (Var v) = isBottomingId v && n >= idArity v + go n (Var v) = isDeadEndId v && n >= idArity v go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e go n (Tick _ e) = go n e @@ -1059,7 +1059,7 @@ exprIsBottom e {- Note [Bottoming expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsBottom +exception. We can test for it in two different ways, and exprIsDeadEnd checks for both of these situations: * Visibly-bottom computations. For example @@ -1353,7 +1353,6 @@ type CheapAppFun = Id -> Arity -> Bool -- but with minor variations: -- isWorkFreeApp -- isCheapApp - -- isExpandableApp isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args @@ -1369,7 +1368,7 @@ isWorkFreeApp fn n_val_args isCheapApp :: CheapAppFun isCheapApp fn n_val_args | isWorkFreeApp fn n_val_args = True - | isBottomingId fn = True -- See Note [isCheapApp: bottoming functions] + | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of DataConWorkId {} -> True -- Actually handled by isWorkFreeApp @@ -1390,7 +1389,7 @@ isExpandableApp fn n_val_args RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False - _ | isBottomingId fn -> False + _ | isDeadEndId fn -> False -- See Note [isExpandableApp: bottoming functions] | isConLikeId fn -> True | all_args_are_preds -> True @@ -2136,7 +2135,7 @@ diffExpr top env (Tick n1 e1) (Tick n2 e2) -- generated names, which are allowed to differ. diffExpr _ _ (App (App (Var absent) _) _) (App (App (Var absent2) _) _) - | isBottomingId absent && isBottomingId absent2 = [] + | isDeadEndId absent && isDeadEndId absent2 = [] diffExpr top env (App f1 a1) (App f2 a2) = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 diffExpr top env (Lam b1 e1) (Lam b2 e2) diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 430ef5ac7c..455b0824e1 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -39,7 +39,7 @@ import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info import GHC.Core.InstEnv import GHC.Core.Type ( tidyTopType ) -import GHC.Types.Demand ( appIsBottom, isTopSig, isBottomingSig ) +import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) @@ -726,7 +726,7 @@ addExternal omit_prags expose_all id show_unfold = show_unfolding unfolding never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (strictnessInfo idinfo) + bottoming_fn = isDeadEndSig (strictnessInfo idinfo) -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker @@ -1229,7 +1229,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold _bottom_hidden id_sig = case mb_bot_str of Nothing -> False - Just (arity, _) -> not (appIsBottom id_sig arity) + Just (arity, _) -> not (appIsDeadEnd id_sig arity) --------- Unfolding ------------ unf_info = unfoldingInfo idinfo diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index f36889444c..416eff9f4a 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -22,26 +22,25 @@ module GHC.Types.Demand ( addCaseBndrDmd, DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - nopDmdType, botDmdType, mkDmdType, - addDemand, ensureArgs, BothDmdArg, mkBothDmdArg, toBothDmdArg, + nopDmdType, botDmdType, addDemand, DmdEnv, emptyDmdEnv, peelFV, findIdDemand, - Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, - appIsBottom, isBottomingSig, pprIfaceStrictSig, + Divergence(..), lubDivergence, isDeadEndDiv, + topDiv, botDiv, exnDiv, + appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig, StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - nopSig, botSig, cprProdSig, + nopSig, botSig, isTopSig, hasDemandEnvSig, splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, etaExpandStrictSig, + prependArgsStrictSig, etaConvertStrictSig, seqDemand, seqDemandList, seqDmdType, seqStrictSig, evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, - deferAfterIO, + splitDmdTy, splitFVs, deferAfterPreciseException, postProcessUnsat, postProcessDmdType, splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, @@ -125,7 +124,7 @@ See #14998 for the way it's resolved at the moment. Here's a historic breakdown: Apparently, exception handling prim-ops didn't use to have any special -strictness signatures, thus defaulting to topSig, which assumes they use their +strictness signatures, thus defaulting to nopSig, which assumes they use their arguments lazily. Joachim was the first to realise that we could provide richer information. Thus, in 0558911f91c (Dec 13), he added signatures to primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call @@ -179,6 +178,13 @@ is not strict in its argument: Just try this in GHCi Any analysis that assumes otherwise will be broken in some way or another (beyond `-fno-pendantic-bottoms`). + +But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a +subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is +only used by `raiseIO#` in order to preserve precise exceptions by strictness +analysis, while not impacting the ability to eliminate dead code. +See Note [Precise exceptions and strictness analysis]. + -} -- | Vanilla strictness domain @@ -913,30 +919,63 @@ Divergence: Dunno In a fixpoint iteration, start from Diverges -} +-- | Divergence lattice. Models a subset lattice of the following exhaustive +-- set of divergence results: +-- +-- [n] nontermination (e.g. loops) +-- [i] throws imprecise exception +-- [p] throws precise exception +-- [c] converges (reduces to WHNF) +-- +-- The different lattice elements correspond to different subsets, indicated by +-- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an +-- exception, and may or may not reduce to WHNF). +-- +-- @ +-- Dunno (nipc) +-- | +-- ExnOrDiv (nip) +-- | +-- Diverges (ni) +-- @ +-- +-- As you can see, we don't distinguish __n__ and __i__. +-- See Note [Precise exceptions and strictness analysis] for why __p__ is so +-- special compared to __i__. data Divergence - = Diverges -- Definitely diverges - | Dunno -- Might diverge or converge + = Diverges -- ^ Definitely throws an imprecise exception or diverges. + | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise + -- exception or diverges. Never converges, hence 'isDeadEndDiv'! + -- See scenario 1 in Note [Precise exceptions and strictness analysis]. + | Dunno -- ^ Might diverge, throw any kind of exception or converge. deriving( Eq, Show ) -lubDivergence :: Divergence -> Divergence ->Divergence -lubDivergence Diverges r = r -lubDivergence r Diverges = r -lubDivergence Dunno Dunno = Dunno --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) +lubDivergence :: Divergence -> Divergence -> Divergence +lubDivergence Diverges div = div +lubDivergence div Diverges = div +lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv +lubDivergence _ _ = Dunno +-- This needs to commute with defaultFvDmd, i.e. +-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 +-- (See Note [Default demand on free variables and arguments] for why) bothDivergence :: Divergence -> Divergence -> Divergence --- See Note [Asymmetry of 'both' for DmdType and Divergence] -bothDivergence _ Diverges = Diverges -bothDivergence r Dunno = r --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) +-- See Note [Asymmetry of 'both*'], which concludes that 'bothDivergence' needs +-- to be symmetric. +-- Strictly speaking, we should have @bothDivergence Dunno Diverges = ExnOrDiv@. +-- But that regresses in too many places (every infinite loop, basically) to be +-- worth it and is only relevant in higher-order scenarios +-- (e.g. Divergence of @f (throwIO blah)@). +-- So 'bothDivergence' currently is 'glbDivergence', really. +bothDivergence Dunno Dunno = Dunno +bothDivergence Diverges _ = Diverges +bothDivergence _ Diverges = Diverges +bothDivergence _ _ = ExnOrDiv instance Outputable Divergence where - ppr Diverges = char 'b' - ppr Dunno = empty + ppr Diverges = char 'b' -- for (b)ottom + ppr ExnOrDiv = char 'x' -- for e(x)ception + ppr Dunno = empty {- Note [Precise vs imprecise exceptions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -958,78 +997,132 @@ Imprecise exceptions are actually more interesting than precise ones (which are fairly standard) from the perspective of semantics. See the paper "A Semantics for Imprecise Exceptions" for more details. +Note [Dead ends] +~~~~~~~~~~~~~~~~ +We call an expression that either diverges or throws a precise or imprecise +exception a "dead end". We used to call such an expression just "bottoming", +but with the measures we take to preserve precise exception semantics +(see Note [Precise exceptions and strictness analysis]), that is no longer +accurate: 'exnDiv' is no longer the bottom of the Divergence lattice. + +Yet externally to demand analysis, we mostly care about being able to drop dead +code etc., which is all due to the property that such an expression never +returns, hence we consider throwing a precise exception to be a dead end. +See also 'isDeadEndDiv'. + Note [Precise exceptions and strictness analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -raiseIO# raises a *precise* exception, in contrast to raise# which -raise an *imprecise* exception. See Note [Precise vs imprecise exceptions] -in XXXX. +We have to take care to preserve precise exception semantics in strictness +analysis (#17676). There are two scenarios that need careful treatment. + +The fixes were discussed at +https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions -Unlike raise# (which returns botDiv), we want raiseIO# to return topDiv. +Recall that raiseIO# raises a *precise* exception, in contrast to raise# which +raises an *imprecise* exception. See Note [Precise vs imprecise exceptions]. + +Scenario 1: Precise exceptions in case alternatives +--------------------------------------------------- +Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv. Here's why. Consider this example from #13380 (similarly #17676): - f x y | x>0 = raiseIO Exc - | y>0 = return 1 - | otherwise = return 2 + f x y | x>0 = raiseIO# Exc + | y>0 = return 1 + | otherwise = return 2 Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and loose with the precise exception; after optimisation, (f 42 (error "boom")) turns from throwing the precise Exc to throwing the imprecise user error -"boom". So, the defaultDmd of raiseIO# should be lazy (topDmd), which can be -achieved by giving it divergence topDiv. +"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be +achieved by giving it divergence exnDiv. +See Note [Default demand on free variables and arguments]. -But if it returns topDiv, the simplifier will fail to discard raiseIO#'s -continuation in - case raiseIO# x s of { (# s', r #) -> <BIG> } +Why don't we just give it topDiv instead of introducing exnDiv? +Because then the simplifier will fail to discard raiseIO#'s continuation in + case raiseIO# x s of { (# s', r #) -> <BIG> } which we'd like to optimise to - raiseIO# x s -Temporary hack solution: special treatment for raiseIO# in -Simplifier.Utils.mkArgInfo. For the non-hack solution, see -https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions#replacing-hacks-by-principled-program-analyses + case raiseIO# x s of {} +Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and +its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it +behaves exactly as botDiv, so that dead code elimination works as expected. +This is tracked by T13380b. + +Scenario 2: Precise exceptions in case scrutinees +------------------------------------------------- +Consider (more complete examples in #148, #1592, testcase strun003) + + case foo x s of { (# s', r #) -> y } + +Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception +(ultimately via raiseIO#), then we must not force 'y', which may fail to +terminate or throw an imprecise exception, until we have performed @foo x s@. + +So we have to 'Demand.deferAfterPreciseException' (which just 'lub's with +'nopDmdType' to model the exceptional control flow) when @foo x s@ +may throw a precise exception. Motivated by T13380{d,e,f}. +See Note [Which scrutinees may throw precise exceptions] in DmdAnal. + +Historical Note: This used to be called the "IO hack". But that term is rather +a bad fit because +1. It's easily confused with the "State hack", which also affects IO. +2. Neither "IO" nor "hack" is a good description of what goes on here, which + is deferring strictness results after possibly throwing a precise exception. + The "hack" is probably not having to defer when we can prove that the + expression may not throw a precise exception (increasing precision of the + analysis), but that's just a favourable guess. -} - ------------------------------------------------------------------------ -- Combined demand result -- ------------------------------------------------------------------------ --- [cprRes] lets us switch off CPR analysis --- by making sure that everything uses TopRes -topDiv, botDiv :: Divergence +topDiv, exnDiv, botDiv :: Divergence topDiv = Dunno +exnDiv = ExnOrDiv botDiv = Diverges -isTopDiv :: Divergence -> Bool -isTopDiv Dunno = True -isTopDiv _ = False - --- | True if the result diverges or throws an exception -isBotDiv :: Divergence -> Bool -isBotDiv Diverges = True -isBotDiv _ = False - --- See Notes [Default demand on free variables] --- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Divergence -> Demand -defaultDmd Dunno = absDmd -defaultDmd _ = botDmd -- Diverges - -resTypeArgDmd :: Divergence -> Demand +-- | True if the result indicates that evaluation will not return. +-- See Note [Dead ends]. +isDeadEndDiv :: Divergence -> Bool +isDeadEndDiv Diverges = True +isDeadEndDiv ExnOrDiv = True +isDeadEndDiv Dunno = False + +-- See Notes [Default demand on free variables and arguments] +-- and Scenario 1 in [Precise exceptions and strictness analysis] +defaultFvDmd :: Divergence -> Demand +defaultFvDmd Dunno = absDmd +defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv! +defaultFvDmd Diverges = botDmd -- Diverges + +defaultArgDmd :: Divergence -> Demand -- TopRes and BotRes are polymorphic, so that -- BotRes === (Bot -> BotRes) === ... -- TopRes === (Top -> TopRes) === ... -- This function makes that concrete --- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd Dunno = topDmd -resTypeArgDmd _ = botDmd -- Diverges - -{- -Note [defaultDmd and resTypeArgDmd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -These functions are similar: They express the demand on something not -explicitly mentioned in the environment resp. the argument list. Yet they are -different: - * Variables not mentioned in the free variables environment are definitely - unused, so we can use absDmd there. - * Further arguments *can* be used, of course. Hence topDmd is used. +-- Also see Note [Default demand on free variables and arguments] +defaultArgDmd Dunno = topDmd +-- NB: not botDmd! We don't want to mask the precise exception by forcing the +-- argument. But it is still absent. +defaultArgDmd ExnOrDiv = absDmd +defaultArgDmd Diverges = botDmd + +{- Note [Default demand on free variables and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Free variables not mentioned in the environment of a 'DmdType' +are demanded according to the demand type's Divergence: + * In a Diverges (botDiv) context, that demand is botDmd + (HyperStr and Absent). + * In all other contexts, the demand is absDmd (Lazy and Absent). +This is recorded in 'defaultFvDmd'. + +Similarly, we can eta-expand demand types to get demands on excess arguments +not accounted for in the type, by consulting 'defaultArgDmd': + * In a Diverges (botDiv) context, that demand is again botDmd. + * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge + before evaluating the excess argument, but don't want to eagerly evaluate + it (cf. Note [Precise exceptions and strictness analysis]). + * In a Dunno context (topDiv), the demand is topDmd, because + it's perfectly possible to enter the additional lambda and evaluate it + in unforeseen ways (so, not Absent). ************************************************************************ @@ -1039,61 +1132,46 @@ different: ************************************************************************ -} -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables and arguments] data DmdType = DmdType DmdEnv -- Demand on explicitly-mentioned -- free variables [Demand] -- Demand on arguments - Divergence -- See [Nature of result demand] + Divergence -- See [Demand type Divergence] {- -Note [Nature of result demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Divergence contains information about termination (currently distinguishing -definite divergence and no information; it is possible to include definite -convergence here), and CPR information about the result. - -The semantics of this depends on whether we are looking at a DmdType, i.e. the -demand put on by an expression _under a specific incoming demand_ on its -environment, or at a StrictSig describing a demand transformer. - -For a - * DmdType, the termination information is true given the demand it was - generated with, while for - * a StrictSig it holds after applying enough arguments. - -The CPR information, though, is valid after the number of arguments mentioned -in the type is given. Therefore, when forgetting the demand on arguments, as in -dmdAnalRhs, this needs to be considered (via removeDmdTyArgs). +Note [Demand type Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand. +This is described in detail in Note [Understanding DmdType and StrictSig]. +Here, we'll focus on what that means for a DmdType's Divergence in a higher-order +scenario. Consider - b2 x y = x `seq` y `seq` error (show x) + err x y = x `seq` y `seq` error (show x) this has a strictness signature of <S><S>b -meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but -for "b2 1 2 `seq` ()" we get definite divergence. - -For comparison, - b1 x = x `seq` error (show x) -has a strictness signature of - <S>b -and "b1 1 `seq` ()" is known to terminate. - -Now consider a function h with signature "<C(S)>", and the expression - e1 = h b1 -now h puts a demand of <C(S)> onto its argument, and the demand transformer -turns it into - <S>b -Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not -diverge, and we do not anything being passed to b. - -Note [Asymmetry of 'both' for DmdType and Divergence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there is only one -result! For example, given (e1 e2), we get a DmdType dt1 for e1, use -its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). -Similarly with +meaning that we don't know what happens when we call errin weaker contexts than +C(C(S)), like @err `seq` ()@ (S) and @err 1 `seq` ()@ (C(S)). We may not unleash +the botDiv, hence assume topDiv. Of course, in @err 1 2 `seq` ()@ the incoming +demand C(C(S)) is strong enough and we see that the expression diverges. + +Now consider a function + f g = g 1 2 +with signature <C(S)>, and the expression + f err `seq` () +now f puts a strictness demand of C(C(S)) onto its argument, which is unleashed +on err via the App rule. In contrast to weaker head strictness, this demand is +strong enough to unleash err's signature and hence we see that the whole +expression diverges! + +Note [Asymmetry of 'both*'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *asymmetrical*, because there can only one +be one type contributing argument demands! For example, given (e1 e2), we get +a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do +(dt1 `bothType` dt2). Similarly with case e of { p -> rhs } we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then compute (dt_rhs `bothType` dt_scrut). @@ -1101,10 +1179,18 @@ compute (dt_rhs `bothType` dt_scrut). We 1. combine the information on the free variables, 2. take the demand on arguments from the first argument - 3. combine the termination results, but - 4. take CPR info from the first argument. - -3 and 4 are implemented in bothDivergence. + 3. combine the termination results, as in bothDivergence. + +Since we don't use argument demands of the second argument anyway, 'both's +second argument is just a 'BothDmdType'. + +But note that the argument demand types are not guaranteed to be observed in +left to right order. For example, analysis of a case expression will pass the +demand type for the alts as the left argument and the type for the scrutinee as +the right argument. Also, it is not at all clear if there is such an order; +consider the LetUp case, where the RHS might be forced at any point while +evaluating the let body. +Therefore, it is crucial that 'bothDivergence' is symmetric! -} -- Equality needed for fixpoints in GHC.Core.Opt.DmdAnal @@ -1116,45 +1202,34 @@ instance Eq DmdType where -- Unique order, it is the same order for both && ds1 == ds2 && div1 == div2 +-- | Compute the least upper bound of two 'DmdType's elicited /by the same +-- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType lubDmdType d1 d2 = DmdType lub_fv lub_ds lub_div where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = ensureArgs n d1 - (DmdType fv2 ds2 r2) = ensureArgs n d2 + (DmdType fv1 ds1 r1) = etaExpandDmdType n d1 + (DmdType fv2 ds2 r2) = etaExpandDmdType n d2 - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2) lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 lub_div = lubDivergence r1 r2 -{- -Note [The need for BothDmdArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, the right argument to bothDmdType, as well as the return value of -dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs -to know about the free variables and termination information, but nothing about -the demand put on arguments, nor cpr information. So we make that explicit by -only passing the relevant information. --} - type BothDmdArg = (DmdEnv, Divergence) mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno) +mkBothDmdArg env = (env, topDiv) toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, go r) - where - go Dunno = Dunno - go Diverges = Diverges +toBothDmdArg (DmdType fv _ r) = (fv, r) bothDmdType :: DmdType -> BothDmdArg -> DmdType bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and Divergence] + -- See Note [Asymmetry of 'both*'] -- 'both' takes the argument/result info from its *first* arg, -- using its second arg just for its free-var info. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) + = DmdType (plusVarEnv_CD bothDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) ds1 (r1 `bothDivergence` t2) @@ -1172,40 +1247,46 @@ instance Outputable DmdType where emptyDmdEnv :: VarEnv Demand emptyDmdEnv = emptyVarEnv --- nopDmdType is the demand of doing nothing --- (lazy, absent, no CPR information, no termination information). --- Note that it is ''not'' the top of the lattice (which would be "may use everything"), --- so it is (no longer) called topDmd -nopDmdType, botDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topDiv +botDmdType :: DmdType botDmdType = DmdType emptyDmdEnv [] botDiv -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) - | isTopDiv res && isEmptyVarEnv env = True -isTopDmdType _ = False +-- | The demand type of doing nothing (lazy, absent, no Divergence +-- information). Note that it is ''not'' the top of the lattice (which would be +-- "may use everything"), so it is (no longer) called topDmdType. +-- (SG: I agree, but why is it still 'topDmd' then?) +nopDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topDiv -mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType -mkDmdType fv ds res = DmdType fv ds res +isTopDmdType :: DmdType -> Bool +isTopDmdType (DmdType env args div) + = div == topDiv && null args && isEmptyVarEnv env dmdTypeDepth :: DmdType -> Arity dmdTypeDepth (DmdType _ ds _) = length ds --- | This makes sure we can use the demand type with n arguments. --- It extends the argument list with the correct resTypeArgDmd. --- It also adjusts the Divergence: Divergence survives additional arguments, --- CPR information does not (and definite converge also would not). -ensureArgs :: Arity -> DmdType -> DmdType -ensureArgs n d | n == depth = d - | otherwise = DmdType fv ds' r' +-- | This makes sure we can use the demand type with n arguments after eta +-- expansion, where n must not be lower than the demand types depth. +-- It appends the argument list with the correct 'defaultArgDmd'. +etaExpandDmdType :: Arity -> DmdType -> DmdType +etaExpandDmdType n d + | n == depth = d + | n > depth = DmdType fv inc_ds div + | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) where depth = dmdTypeDepth d - DmdType fv ds r = d - - ds' = take n (ds ++ repeat (resTypeArgDmd r)) - r' = case r of -- See [Nature of result demand] - Dunno -> topDiv - _ -> r - + DmdType fv ds div = d + -- Arity increase: + -- * Demands on FVs are still valid + -- * Demands on args also valid, plus we can extend with defaultArgDmd + -- as appropriate for the given Divergence + -- * Divergence is still valid: + -- - A dead end after 2 arguments stays a dead end after 3 arguments + -- - The remaining case is Dunno, which is already topDiv + inc_ds = take n (ds ++ repeat (defaultArgDmd div)) + +-- | A conservative approximation for a given 'DmdType' in case of an arity +-- decrease. Currently, it's just nopDmdType. +decreaseArityDmdType :: DmdType -> DmdType +decreaseArityDmdType _ = nopDmdType seqDmdType :: DmdType -> () seqDmdType (DmdType env ds res) = @@ -1219,23 +1300,16 @@ splitDmdTy :: DmdType -> (Demand, DmdType) -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty) --- When e is evaluated after executing an IO action, and d is e's demand, then --- what of this demand should we consider, given that the IO action can cleanly --- exit? +-- | When e is evaluated after executing an IO action that may throw a precise +-- exception, and d is e's demand, then what of this demand should we consider? -- * We have to kill all strictness demands (i.e. lub with a lazy demand) -- * We can keep usage information (i.e. lub with an absent demand) -- * We have to kill definite divergence --- * We can keep CPR information. --- See Note [IO hack in the demand analyser] in GHC.Core.Opt.DmdAnal -deferAfterIO :: DmdType -> DmdType -deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` nopDmdType of - DmdType fv ds _ -> DmdType fv ds (defer_res res) - where - defer_res r@(Dunno {}) = r - defer_res _ = topDiv -- Diverges +-- See Note [Precise exceptions and strictness analysis] +deferAfterPreciseException :: DmdType -> DmdType +deferAfterPreciseException d = lubDmdType d nopDmdType strictenDmd :: Demand -> CleanDemand strictenDmd (JD { sd = s, ud = u}) @@ -1270,14 +1344,16 @@ toCleanDmd (JD { sd = s, ud = u }) -- This is used in dmdAnalStar when post-processing -- a function's argument demand. So we only care about what -- does to free variables, and whether it terminates. --- see Note [The need for BothDmdArg] +-- see Note [Asymmetry of 'both*'] postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) postProcessDivergence :: Str () -> Divergence -> Divergence -postProcessDivergence Lazy _ = topDiv -postProcessDivergence _ res = res +-- In a Lazy scenario, we might not force the Divergence, in which case we +-- converge, hence Dunno. +postProcessDivergence Lazy _ = Dunno +postProcessDivergence _ d = d postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env @@ -1355,7 +1431,6 @@ peelManyCalls n (JD { sd = str, ud = abs }) {- Note [Demands from unsaturated function calls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer, e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context, @@ -1370,9 +1445,7 @@ But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a f * Not enough demand on the strictness side: - In that case, we need to zap all strictness in the demand on arguments and free variables. - - Furthermore, we remove CPR information. It could be left, but given the incoming - demand is not enough to evaluate so far we just do not bother. - - And finally termination information: If r says that f diverges for sure, + - And finally Divergence information: If r says that f Diverges for sure, then this holds when the demand guarantees that two arguments are going to be passed. If the demand is lower, we may just as well converge. If we were tracking definite convegence, than that would still hold under @@ -1397,29 +1470,17 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) (DmdType fv' ds res, dmd) where fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables] - dmd = lookupVarEnv fv id `orElse` defaultDmd res + -- See Note [Default demand on free variables and arguments] + dmd = lookupVarEnv fv id `orElse` defaultFvDmd res addDemand :: Demand -> DmdType -> DmdType addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res findIdDemand :: DmdType -> Var -> Demand findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultDmd res + = lookupVarEnv fv id `orElse` defaultFvDmd res {- -Note [Default demand on free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the variable is not mentioned in the environment of a demand type, -its demand is taken to be a result demand of the type. - For the strictness component, - if the result demand is a Diverges, then we use HyperStr - else we use Lazy - For the usage component, we use Absent. -So we use either absDmd or botDmd. - -Also note the equations for lubDivergence (resp. bothDivergence) noted there. - Note [Always analyse in virgin pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Tricky point: make sure that we analyse in the 'virgin' pass. Consider @@ -1526,7 +1587,7 @@ transfomer, namely This DmdType gives the demands unleashed by the Id when it is applied to as many arguments as are given in by the arg demands in the DmdType. -Also see Note [Nature of result demand] for the meaning of a Divergence in a +Also see Note [Demand type Divergence] for the meaning of a Divergence in a strictness signature. If an Id is applied to less arguments than its arity, it means that @@ -1585,9 +1646,6 @@ type's depth! So in mkStrictSigForArity we make sure to trim the list of argument demands to the given threshold arity. Call sites will make sure that this corresponds to the arity of the call demand that elicited the wrapped demand type. See also Note [What are demand signatures?] in GHC.Core.Opt.DmdAnal. - -Besides trimming argument demands, mkStrictSigForArity will also trim CPR -information if necessary. -} -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe @@ -1607,7 +1665,9 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' -- unleashable at that arity. See Note [Understanding DmdType and StrictSig] mkStrictSigForArity :: Arity -> DmdType -> StrictSig -mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) +mkStrictSigForArity arity dmd_ty@(DmdType fvs args div) + | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div) + | otherwise = StrictSig (etaExpandDmdType arity dmd_ty) mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) @@ -1615,32 +1675,33 @@ mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv splitStrictSig :: StrictSig -> ([Demand], Divergence) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- ^ Add extra arguments to a strictness signature. --- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument --- demands and leaves CPR info intact. -increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) +prependArgsStrictSig :: Int -> StrictSig -> StrictSig +-- ^ Add extra ('topDmd') arguments to a strictness signature. +-- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument +-- demands. This is used by FloatOut. +prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | new_args == 0 = sig | isTopDmdType dmd_ty = sig - | arity_increase == 0 = sig - | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" - <+> text "negative arity increase" - <+> ppr arity_increase ) - nopSig + | new_args < 0 = pprPanic "prependArgsStrictSig: negative new_args" + (ppr new_args $$ ppr sig) | otherwise = StrictSig (DmdType env dmds' res) where - dmds' = replicate arity_increase topDmd ++ dmds - -etaExpandStrictSig :: Arity -> StrictSig -> StrictSig --- ^ We are expanding (\x y. e) to (\x y z. e z). --- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if --- necessary, potentially destroying the signature's CPR property. -etaExpandStrictSig arity (StrictSig dmd_ty) - | arity < dmdTypeDepth dmd_ty - -- an arity decrease must zap the whole signature, because it was possibly - -- computed for a higher incoming call demand. - = nopSig - | otherwise - = StrictSig $ ensureArgs arity dmd_ty + dmds' = replicate new_args topDmd ++ dmds + +etaConvertStrictSig :: Arity -> StrictSig -> StrictSig +-- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to +-- the former (when the Simplifier identifies a new join points, for example). +-- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if +-- necessary. +-- This works by looking at the 'DmdType' (which was produced under a call +-- demand for the old arity) and trying to transfer as many facts as we can to +-- the call demand of new arity. +-- An arity increase (resulting in a stronger incoming demand) can retain much +-- of the info, while an arity decrease (a weakening of the incoming demand) +-- must fall back to a conservative default. +etaConvertStrictSig arity (StrictSig dmd_ty) + | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty + | otherwise = StrictSig $ etaExpandDmdType arity dmd_ty isTopSig :: StrictSig -> Bool isTopSig (StrictSig ty) = isTopDmdType ty @@ -1651,16 +1712,16 @@ hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) strictSigDmdEnv :: StrictSig -> DmdEnv strictSigDmdEnv (StrictSig (DmdType env _ _)) = env --- | True if the signature diverges or throws an exception -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res +-- | True if the signature diverges or throws an exception in a saturated call. +-- See Note [Dead ends]. +isDeadEndSig :: StrictSig -> Bool +isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res -nopSig, botSig :: StrictSig -nopSig = StrictSig nopDmdType +botSig :: StrictSig botSig = StrictSig botDmdType -cprProdSig :: Arity -> StrictSig -cprProdSig _arity = nopSig +nopSig :: StrictSig +nopSig = StrictSig nopDmdType seqStrictSig :: StrictSig -> () seqStrictSig (StrictSig ty) = seqDmdType ty @@ -1706,7 +1767,7 @@ dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd = postProcessUnsat defer_use $ DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv | otherwise - = nopDmdType -- See Note [Demand transformer for a dictionary selector] + = nopDmdType -- See Note [Demand transformer for a dictionary selector] where enhance cd old | isAbsDmd old = old | otherwise = mkOnceUsedDmd cd -- This is the one! @@ -1789,13 +1850,11 @@ The occurrence analyser propagates this one-shot infor to the binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. -} --- | Returns true if an application to n args --- would diverge or throw an exception --- See Note [Unsaturated applications] -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotDiv res = not $ lengthExceeds ds n -appIsBottom _ _ = False +-- | Returns true if an application to n args would diverge or throw an +-- exception. See Note [Unsaturated applications] and Note [Dead ends]. +appIsDeadEnd :: StrictSig -> Int -> Bool +appIsDeadEnd (StrictSig (DmdType _ ds res)) n + = isDeadEndDiv res && not (lengthExceeds ds n) {- Note [Unsaturated applications] @@ -1803,9 +1862,9 @@ Note [Unsaturated applications] If a function having bottom as its demand result is applied to a less number of arguments than its syntactic arity, we cannot say for sure that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. +function appIsDeadEnd, which, given a strictness signature and a number +of arguments, says conservatively if the function is never going to return. +See Note [Dead ends]. -} zapUsageEnvSig :: StrictSig -> StrictSig @@ -2019,9 +2078,11 @@ instance Binary DmdType where instance Binary Divergence where put_ bh Dunno = putByte bh 0 - put_ bh Diverges = putByte bh 1 + put_ bh ExnOrDiv = putByte bh 1 + put_ bh Diverges = putByte bh 2 get bh = do { h <- getByte bh ; case h of 0 -> return Dunno + 1 -> return ExnOrDiv _ -> return Diverges } diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index 2a42a2b51e..cf3739bfca 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -49,20 +49,27 @@ instance Outputable ForeignCall where ppr (CCall cc) = ppr cc data Safety - = PlaySafe -- Might invoke Haskell GC, or do a call back, or - -- switch threads, etc. So make sure things are - -- tidy before the call. Additionally, in the threaded - -- RTS we arrange for the external call to be executed - -- by a separate OS thread, i.e., _concurrently_ to the - -- execution of other Haskell threads. - - | PlayInterruptible -- Like PlaySafe, but additionally - -- the worker thread running this foreign call may - -- be unceremoniously killed, so it must be scheduled - -- on an unbound thread. - - | PlayRisky -- None of the above can happen; the call will return - -- without interacting with the runtime system at all + = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- ^ Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- ^ None of the above can happen; the call will return + -- without interacting with the runtime system at all. + -- Specifically: + -- + -- * No GC + -- * No call backs + -- * No blocking + -- * No precise exceptions + -- deriving ( Eq, Show, Data ) -- Show used just for Show Lex.Token, I think diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 028bfd45f0..3d9d9c3f40 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -70,7 +70,7 @@ module GHC.Types.Id ( isDataConWrapId, isDataConWrapId_maybe, isDataConId_maybe, idDataCon, - isConLikeId, isBottomingId, idIsFrom, + isConLikeId, isDeadEndId, idIsFrom, hasNoBinding, -- ** Join variables @@ -637,10 +637,11 @@ setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) --- | Returns true if an application to n args would diverge -isBottomingId :: Var -> Bool -isBottomingId v - | isId v = isBottomingSig (idStrictness v) +-- | Returns true if an application to n args diverges or throws an exception +-- See Note [Dead ends] in GHC.Types.Demand. +isDeadEndId :: Var -> Bool +isDeadEndId v + | isId v = isDeadEndSig (idStrictness v) | otherwise = False -- | Accesses the 'Id''s 'strictnessInfo'. @@ -958,7 +959,7 @@ transferPolyIdInfo old_id abstract_wrt new_id new_occ_info = zapOccTailCallInfo old_occ_info old_strictness = strictnessInfo old_info - new_strictness = increaseStrictSigArity arity_increase old_strictness + new_strictness = prependArgsStrictSig arity_increase old_strictness old_cpr = cprInfo old_info transfer new_info = new_info `setArityInfo` new_arity diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index df62ad5469..910d738a8e 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1245,8 +1245,8 @@ mkPrimOpId prim_op -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr - | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr - | otherwise = topCpr + | isDeadEndDiv (snd (splitStrictSig strict_sig)) = botCpr + | otherwise = topCpr info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) @@ -1372,7 +1372,7 @@ proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` ty ) + `setNeverLevPoly` ty) where -- proxy# :: forall {k} (a:k). Proxy# k a -- @@ -1699,8 +1699,8 @@ inlined. realWorldPrimId :: Id -- :: State# RealWorld realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverLevPoly` realWorldStatePrimTy) + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) voidPrimId :: Id -- Global constant :: Void# voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy diff --git a/testsuite/tests/stranal/should_compile/T10482a.stderr b/testsuite/tests/stranal/should_compile/T10482a.stderr index 369694a870..ec04d2c3c9 100644 --- a/testsuite/tests/stranal/should_compile/T10482a.stderr +++ b/testsuite/tests/stranal/should_compile/T10482a.stderr @@ -3,7 +3,7 @@ Result size of Tidy Core = {terms: 342, types: 152, coercions: 3, joins: 0/0} -- RHS size: {terms: 9, types: 8, coercions: 0, joins: 0/0} -Foo.$WMkT4 [InlPrag=INLINE[0]] :: forall a. Foo a -> Int -> T4 a +Foo.$WMkT4 [InlPrag=INLINE[0] CONLIKE] :: forall a. Foo a -> Int -> T4 a [GblId[DataConWrapper], Arity=2, Caf=NoCafRefs, @@ -11,14 +11,14 @@ Foo.$WMkT4 [InlPrag=INLINE[0]] :: forall a. Foo a -> Int -> T4 a Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a_agw) (dt_a1hl [Occ=Once] :: Foo a_agw) (dt_a1hm [Occ=Once] :: Int) -> - case dt_a1hl of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT4 @a_agw dt_X0 dt_a1hm }}] + Tmpl= \ (@a_agr) (dt_a1h9 [Occ=Once] :: Foo a_agr) (dt_a1ha [Occ=Once] :: Int) -> + case dt_a1h9 of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT4 @a_agr dt_X0 dt_a1ha }}] Foo.$WMkT4 - = \ (@a_agw) (dt_a1hl [Occ=Once] :: Foo a_agw) (dt_a1hm [Occ=Once] :: Int) -> - case dt_a1hl of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT4 @a_agw dt_X0 dt_a1hm } + = \ (@a_agr) (dt_a1h9 [Occ=Once] :: Foo a_agr) (dt_a1ha [Occ=Once] :: Int) -> + case dt_a1h9 of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT4 @a_agr dt_X0 dt_a1ha } -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} -Foo.$WMkT2 [InlPrag=INLINE[0]] :: Int -> Int -> T2 +Foo.$WMkT2 [InlPrag=INLINE[0] CONLIKE] :: Int -> Int -> T2 [GblId[DataConWrapper], Arity=2, Caf=NoCafRefs, @@ -26,11 +26,11 @@ Foo.$WMkT2 [InlPrag=INLINE[0]] :: Int -> Int -> T2 Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (dt_a1gu [Occ=Once] :: Int) (dt_a1gv [Occ=Once] :: Int) -> - case dt_a1gu of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT2 dt_X0 dt_a1gv }}] + Tmpl= \ (dt_a1gi [Occ=Once] :: Int) (dt_a1gj [Occ=Once] :: Int) -> + case dt_a1gi of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT2 dt_X0 dt_a1gj }}] Foo.$WMkT2 - = \ (dt_a1gu [Occ=Once] :: Int) (dt_a1gv [Occ=Once] :: Int) -> - case dt_a1gu of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT2 dt_X0 dt_a1gv } + = \ (dt_a1gi [Occ=Once] :: Int) (dt_a1gj [Occ=Once] :: Int) -> + case dt_a1gi of dt_X0 [Occ=Once] { __DEFAULT -> Foo.MkT2 dt_X0 dt_a1gj } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$trModule4 :: GHC.Prim.Addr# @@ -64,14 +64,14 @@ Foo.$trModule :: GHC.Unit.Module Foo.$trModule = GHC.Unit.Module Foo.$trModule3 Foo.$trModule1 -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep_r1x7 :: GHC.Types.KindRep +$krep_r1w5 :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep_r1x7 = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) +$krep_r1w5 = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$krep1_r1x8 :: GHC.Types.KindRep +$krep1_r1w6 :: GHC.Types.KindRep [GblId, Cpr=m2, Unf=OtherCon []] -$krep1_r1x8 = GHC.Types.KindRepVar 0# +$krep1_r1w6 = GHC.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$tcT5 :: GHC.Prim.Addr# @@ -93,19 +93,19 @@ Foo.$tcT2 :: GHC.Types.TyCon Foo.$tcT2 = GHC.Types.TyCon 12492463661685256209## 1082997131366389398## Foo.$trModule Foo.$tcT1 0# GHC.Types.krep$* -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep2_r1x9 :: GHC.Types.KindRep +$krep2_r1w7 :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep2_r1x9 = GHC.Types.KindRepTyConApp Foo.$tcT2 (GHC.Types.[] @GHC.Types.KindRep) +$krep2_r1w7 = GHC.Types.KindRepTyConApp Foo.$tcT2 (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep3_r1xa :: GHC.Types.KindRep +$krep3_r1w8 :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -$krep3_r1xa = GHC.Types.KindRepFun $krep_r1x7 $krep2_r1x9 +$krep3_r1w8 = GHC.Types.KindRepFun $krep_r1w5 $krep2_r1w7 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT1 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -Foo.$tc'MkT1 = GHC.Types.KindRepFun $krep_r1x7 $krep3_r1xa +Foo.$tc'MkT1 = GHC.Types.KindRepFun $krep_r1w5 $krep3_r1w8 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT6 :: GHC.Prim.Addr# @@ -146,19 +146,19 @@ Foo.$tcT3 :: GHC.Types.TyCon Foo.$tcT3 = GHC.Types.TyCon 8915518733037212359## 16476420519216613869## Foo.$trModule Foo.$tcT6 0# GHC.Types.krep$* -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep4_r1xb :: GHC.Types.KindRep +$krep4_r1w9 :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep4_r1xb = GHC.Types.KindRepTyConApp Foo.$tcT3 (GHC.Types.[] @GHC.Types.KindRep) +$krep4_r1w9 = GHC.Types.KindRepTyConApp Foo.$tcT3 (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep5_r1xc :: GHC.Types.KindRep +$krep5_r1wa :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -$krep5_r1xc = GHC.Types.KindRepFun $krep_r1x7 $krep4_r1xb +$krep5_r1wa = GHC.Types.KindRepFun $krep_r1w5 $krep4_r1w9 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT7 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -Foo.$tc'MkT7 = GHC.Types.KindRepFun $krep_r1x7 $krep5_r1xc +Foo.$tc'MkT7 = GHC.Types.KindRepFun $krep_r1w5 $krep5_r1wa -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT9 :: GHC.Prim.Addr# @@ -187,29 +187,29 @@ Foo.$tcFoo :: GHC.Types.TyCon Foo.$tcFoo = GHC.Types.TyCon 11236787750777559483## 2472662601374496863## Foo.$trModule Foo.$trModule1 0# GHC.Types.krep$*Arr* -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep6_r1xd :: [GHC.Types.KindRep] +$krep6_r1wb :: [GHC.Types.KindRep] [GblId, Cpr=m2, Unf=OtherCon []] -$krep6_r1xd = GHC.Types.: @GHC.Types.KindRep $krep1_r1x8 (GHC.Types.[] @GHC.Types.KindRep) +$krep6_r1wb = GHC.Types.: @GHC.Types.KindRep $krep1_r1w6 (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep7_r1xe :: GHC.Types.KindRep +$krep7_r1wc :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep7_r1xe = GHC.Types.KindRepTyConApp Foo.$tcFoo $krep6_r1xd +$krep7_r1wc = GHC.Types.KindRepTyConApp Foo.$tcFoo $krep6_r1wb -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep8_r1xf :: [GHC.Types.KindRep] +$krep8_r1wd :: [GHC.Types.KindRep] [GblId, Cpr=m2, Unf=OtherCon []] -$krep8_r1xf = GHC.Types.: @GHC.Types.KindRep $krep_r1x7 (GHC.Types.[] @GHC.Types.KindRep) +$krep8_r1wd = GHC.Types.: @GHC.Types.KindRep $krep_r1w5 (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep9_r1xg :: GHC.Types.KindRep +$krep9_r1we :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep9_r1xg = GHC.Types.KindRepTyConApp Foo.$tcFoo $krep8_r1xf +$krep9_r1we = GHC.Types.KindRepTyConApp Foo.$tcFoo $krep8_r1wd -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Foo.$tc'Foo1 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -Foo.$tc'Foo1 = GHC.Types.KindRepFun $krep_r1x7 $krep9_r1xg +Foo.$tc'Foo1 = GHC.Types.KindRepFun $krep_r1w5 $krep9_r1we -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$tc'Foo3 :: GHC.Prim.Addr# @@ -250,19 +250,19 @@ Foo.$tcT4 :: GHC.Types.TyCon Foo.$tcT4 = GHC.Types.TyCon 15961711399118996930## 13694522307176382499## Foo.$trModule Foo.$tcT8 0# GHC.Types.krep$*Arr* -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep10_r1xh :: GHC.Types.KindRep +$krep10_r1wf :: GHC.Types.KindRep [GblId, Cpr=m1, Unf=OtherCon []] -$krep10_r1xh = GHC.Types.KindRepTyConApp Foo.$tcT4 $krep6_r1xd +$krep10_r1wf = GHC.Types.KindRepTyConApp Foo.$tcT4 $krep6_r1wb -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep11_r1xi :: GHC.Types.KindRep +$krep11_r1wg :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -$krep11_r1xi = GHC.Types.KindRepFun $krep_r1x7 $krep10_r1xh +$krep11_r1wg = GHC.Types.KindRepFun $krep_r1w5 $krep10_r1wf -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT10 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep [GblId, Cpr=m4, Unf=OtherCon []] -Foo.$tc'MkT10 = GHC.Types.KindRepFun $krep7_r1xe $krep11_r1xi +Foo.$tc'MkT10 = GHC.Types.KindRepFun $krep7_r1wc $krep11_r1wg -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Foo.$tc'MkT12 :: GHC.Prim.Addr# @@ -288,13 +288,13 @@ Rec { Foo.$wf4 [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: Foo Int -> GHC.Prim.Int# -> Int [GblId, Arity=2, Str=<S,1*U><L,U>, Unf=OtherCon []] Foo.$wf4 - = \ (ww_s1tc + = \ (ww_s1sF :: Foo Int Unf=OtherCon []) - (ww1_s1tg :: GHC.Prim.Int#) -> - case GHC.Prim.># ww1_s1tg 0# of { - __DEFAULT -> ww_s1tc `cast` (Foo.D:R:FooInt0[0] ; Foo.N:R:FooInt[0] :: Foo Int ~R# Int); - 1# -> Foo.$wf4 ww_s1tc (GHC.Prim.-# ww1_s1tg 1#) + (ww1_s1sJ :: GHC.Prim.Int#) -> + case GHC.Prim.># ww1_s1sJ 0# of { + __DEFAULT -> ww_s1sF `cast` (Foo.D:R:FooInt0[0] ; Foo.N:R:FooInt[0] :: Foo Int ~R# Int); + 1# -> Foo.$wf4 ww_s1sF (GHC.Prim.-# ww1_s1sJ 1#) } end Rec } @@ -305,35 +305,35 @@ f4 [InlPrag=NOUSERINLINE[2]] :: T4 Int -> Int Str=<S(SS),1*U(1*U,1*U(U))>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1t9 [Occ=Once!] :: T4 Int) -> - case w_s1t9 of { MkT4 ww1_s1tc [Occ=Once] ww2_s1td [Occ=Once!] -> - case ww2_s1td of { GHC.Types.I# ww4_s1tg [Occ=Once] -> Foo.$wf4 ww1_s1tc ww4_s1tg } + Tmpl= \ (w_s1sC [Occ=Once!] :: T4 Int) -> + case w_s1sC of { MkT4 ww1_s1sF [Occ=Once] ww2_s1sG [Occ=Once!] -> + case ww2_s1sG of { GHC.Types.I# ww4_s1sJ [Occ=Once] -> Foo.$wf4 ww1_s1sF ww4_s1sJ } }}] f4 - = \ (w_s1t9 :: T4 Int) -> - case w_s1t9 of { MkT4 ww1_s1tc ww2_s1td -> case ww2_s1td of { GHC.Types.I# ww4_s1tg -> Foo.$wf4 ww1_s1tc ww4_s1tg } } + = \ (w_s1sC :: T4 Int) -> + case w_s1sC of { MkT4 ww1_s1sF ww2_s1sG -> case ww2_s1sG of { GHC.Types.I# ww4_s1sJ -> Foo.$wf4 ww1_s1sF ww4_s1sJ } } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -lvl_r1xj :: Int +lvl_r1wh :: Int [GblId, Cpr=m1, Unf=OtherCon []] -lvl_r1xj = GHC.Types.I# 1# +lvl_r1wh = GHC.Types.I# 1# Rec { -- RHS size: {terms: 21, types: 4, coercions: 0, joins: 0/0} Foo.$wf2 [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: Int -> GHC.Prim.Int# -> Int [GblId, Arity=2, Str=<L,1*U><L,U>, Unf=OtherCon []] Foo.$wf2 - = \ (ww_s1tn + = \ (ww_s1sQ :: Int Unf=OtherCon []) - (ww1_s1tr :: GHC.Prim.Int#) -> - case GHC.Prim.># ww1_s1tr 0# of { + (ww1_s1sU :: GHC.Prim.Int#) -> + case GHC.Prim.># ww1_s1sU 0# of { __DEFAULT -> - case GHC.Prim.># ww1_s1tr 1# of { - __DEFAULT -> ww_s1tn; - 1# -> lvl_r1xj + case GHC.Prim.># ww1_s1sU 1# of { + __DEFAULT -> ww_s1sQ; + 1# -> lvl_r1wh }; - 1# -> Foo.$wf2 ww_s1tn (GHC.Prim.-# ww1_s1tr 1#) + 1# -> Foo.$wf2 ww_s1sQ (GHC.Prim.-# ww1_s1sU 1#) } end Rec } @@ -344,23 +344,23 @@ f2 [InlPrag=NOUSERINLINE[2]] :: T2 -> Int Str=<S(LS),1*U(1*U,1*U(U))>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1tk [Occ=Once!] :: T2) -> - case w_s1tk of { MkT2 ww1_s1tn [Occ=Once] ww2_s1to [Occ=Once!] -> - case ww2_s1to of { GHC.Types.I# ww4_s1tr [Occ=Once] -> Foo.$wf2 ww1_s1tn ww4_s1tr } + Tmpl= \ (w_s1sN [Occ=Once!] :: T2) -> + case w_s1sN of { MkT2 ww1_s1sQ [Occ=Once] ww2_s1sR [Occ=Once!] -> + case ww2_s1sR of { GHC.Types.I# ww4_s1sU [Occ=Once] -> Foo.$wf2 ww1_s1sQ ww4_s1sU } }}] f2 - = \ (w_s1tk :: T2) -> - case w_s1tk of { MkT2 ww1_s1tn ww2_s1to -> case ww2_s1to of { GHC.Types.I# ww4_s1tr -> Foo.$wf2 ww1_s1tn ww4_s1tr } } + = \ (w_s1sN :: T2) -> + case w_s1sN of { MkT2 ww1_s1sQ ww2_s1sR -> case ww2_s1sR of { GHC.Types.I# ww4_s1sU -> Foo.$wf2 ww1_s1sQ ww4_s1sU } } Rec { -- RHS size: {terms: 15, types: 4, coercions: 0, joins: 0/0} Foo.$wh [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -> Bool [GblId, Arity=2, Str=<S,1*U><L,U>, Unf=OtherCon []] Foo.$wh - = \ (ww_s1tz :: GHC.Prim.Int#) (ww1_s1tD :: GHC.Prim.Int#) -> - case ww_s1tz of ds_X2 { - __DEFAULT -> Foo.$wh (GHC.Prim.-# ds_X2 1#) ww1_s1tD; - 0# -> GHC.Prim.tagToEnum# @Bool (GHC.Prim.># ww1_s1tD 0#) + = \ (ww_s1t2 :: GHC.Prim.Int#) (ww1_s1t6 :: GHC.Prim.Int#) -> + case ww_s1t2 of ds_X2 { + __DEFAULT -> Foo.$wh (GHC.Prim.-# ds_X2 1#) ww1_s1t6; + 0# -> GHC.Prim.tagToEnum# @Bool (GHC.Prim.># ww1_s1t6 0#) } end Rec } @@ -371,22 +371,22 @@ h [InlPrag=NOUSERINLINE[2]] :: Int -> Int -> Bool Str=<S(S),1*U(1*U)><S,1*U(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1tv [Occ=Once!] :: Int) (w1_s1tw [Occ=Once!] :: Int) -> - case w_s1tv of { GHC.Types.I# ww1_s1tz [Occ=Once] -> - case w1_s1tw of { GHC.Types.I# ww3_s1tD [Occ=Once] -> Foo.$wh ww1_s1tz ww3_s1tD } + Tmpl= \ (w_s1sY [Occ=Once!] :: Int) (w1_s1sZ [Occ=Once!] :: Int) -> + case w_s1sY of { GHC.Types.I# ww1_s1t2 [Occ=Once] -> + case w1_s1sZ of { GHC.Types.I# ww3_s1t6 [Occ=Once] -> Foo.$wh ww1_s1t2 ww3_s1t6 } }}] -h = \ (w_s1tv :: Int) (w1_s1tw :: Int) -> - case w_s1tv of { GHC.Types.I# ww1_s1tz -> case w1_s1tw of { GHC.Types.I# ww3_s1tD -> Foo.$wh ww1_s1tz ww3_s1tD } } +h = \ (w_s1sY :: Int) (w1_s1sZ :: Int) -> + case w_s1sY of { GHC.Types.I# ww1_s1t2 -> case w1_s1sZ of { GHC.Types.I# ww3_s1t6 -> Foo.$wh ww1_s1t2 ww3_s1t6 } } Rec { -- RHS size: {terms: 12, types: 2, coercions: 0, joins: 0/0} Foo.$wf1 [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=1, Str=<S,U>, Unf=OtherCon []] Foo.$wf1 - = \ (ww_s1tJ :: GHC.Prim.Int#) -> - case Foo.$wh ww_s1tJ ww_s1tJ of { - False -> Foo.$wf1 (GHC.Prim.-# ww_s1tJ 1#); - True -> ww_s1tJ + = \ (ww_s1tc :: GHC.Prim.Int#) -> + case Foo.$wh ww_s1tc ww_s1tc of { + False -> Foo.$wf1 (GHC.Prim.-# ww_s1tc 1#); + True -> ww_s1tc } end Rec } @@ -398,23 +398,23 @@ f1 [InlPrag=NOUSERINLINE[2]] :: Int -> Int Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1tG [Occ=Once!] :: Int) -> - case w_s1tG of { GHC.Types.I# ww1_s1tJ [Occ=Once] -> - case Foo.$wf1 ww1_s1tJ of ww2_s1tN [Occ=Once] { __DEFAULT -> GHC.Types.I# ww2_s1tN } + Tmpl= \ (w_s1t9 [Occ=Once!] :: Int) -> + case w_s1t9 of { GHC.Types.I# ww1_s1tc [Occ=Once] -> + case Foo.$wf1 ww1_s1tc of ww2_s1tg [Occ=Once] { __DEFAULT -> GHC.Types.I# ww2_s1tg } }}] f1 - = \ (w_s1tG :: Int) -> - case w_s1tG of { GHC.Types.I# ww1_s1tJ -> case Foo.$wf1 ww1_s1tJ of ww2_s1tN { __DEFAULT -> GHC.Types.I# ww2_s1tN } } + = \ (w_s1t9 :: Int) -> + case w_s1t9 of { GHC.Types.I# ww1_s1tc -> case Foo.$wf1 ww1_s1tc of ww2_s1tg { __DEFAULT -> GHC.Types.I# ww2_s1tg } } Rec { -- RHS size: {terms: 14, types: 3, coercions: 0, joins: 0/0} Foo.$wf3 [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=2, Str=<S,U><L,U>, Unf=OtherCon []] Foo.$wf3 - = \ (ww_s1tV :: GHC.Prim.Int#) (ww1_s1u0 :: GHC.Prim.Int#) -> - case Foo.$wh ww_s1tV ww1_s1u0 of { - False -> ww_s1tV; - True -> Foo.$wf3 ww_s1tV (GHC.Prim.-# ww1_s1u0 1#) + = \ (ww_s1to :: GHC.Prim.Int#) (ww1_s1tt :: GHC.Prim.Int#) -> + case Foo.$wh ww_s1to ww1_s1tt of { + False -> ww_s1to; + True -> Foo.$wf3 ww_s1to (GHC.Prim.-# ww1_s1tt 1#) } end Rec } @@ -426,19 +426,19 @@ f3 [InlPrag=NOUSERINLINE[2]] :: T3 -> Int Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1tP [Occ=Once!] :: T3) -> - case w_s1tP of { MkT3 ww1_s1tS [Occ=Once!] ww2_s1tX [Occ=Once!] -> - case ww1_s1tS of { GHC.Types.I# ww4_s1tV [Occ=Once] -> - case ww2_s1tX of { GHC.Types.I# ww6_s1u0 [Occ=Once] -> - case Foo.$wf3 ww4_s1tV ww6_s1u0 of ww7_s1u5 [Occ=Once] { __DEFAULT -> GHC.Types.I# ww7_s1u5 } + Tmpl= \ (w_s1ti [Occ=Once!] :: T3) -> + case w_s1ti of { MkT3 ww1_s1tl [Occ=Once!] ww2_s1tq [Occ=Once!] -> + case ww1_s1tl of { GHC.Types.I# ww4_s1to [Occ=Once] -> + case ww2_s1tq of { GHC.Types.I# ww6_s1tt [Occ=Once] -> + case Foo.$wf3 ww4_s1to ww6_s1tt of ww7_s1ty [Occ=Once] { __DEFAULT -> GHC.Types.I# ww7_s1ty } } } }}] f3 - = \ (w_s1tP :: T3) -> - case w_s1tP of { MkT3 ww1_s1tS ww2_s1tX -> - case ww1_s1tS of { GHC.Types.I# ww4_s1tV -> - case ww2_s1tX of { GHC.Types.I# ww6_s1u0 -> case Foo.$wf3 ww4_s1tV ww6_s1u0 of ww7_s1u5 { __DEFAULT -> GHC.Types.I# ww7_s1u5 } } + = \ (w_s1ti :: T3) -> + case w_s1ti of { MkT3 ww1_s1tl ww2_s1tq -> + case ww1_s1tl of { GHC.Types.I# ww4_s1to -> + case ww2_s1tq of { GHC.Types.I# ww6_s1tt -> case Foo.$wf3 ww4_s1to ww6_s1tt of ww7_s1ty { __DEFAULT -> GHC.Types.I# ww7_s1ty } } } } diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr index ee700fc6c6..df5bd122d0 100644 --- a/testsuite/tests/stranal/should_compile/T10694.stderr +++ b/testsuite/tests/stranal/should_compile/T10694.stderr @@ -6,26 +6,24 @@ Result size of Tidy Core = {terms: 74, types: 65, coercions: 0, joins: 0/4} T10694.$wpm [InlPrag=NOINLINE] :: Int -> Int -> (# Int, Int #) [GblId, Arity=2, Str=<L,U(U)><L,U(U)>, Unf=OtherCon []] T10694.$wpm - = \ (w_s1v1 :: Int) (w1_s1v2 :: Int) -> + = \ (w :: Int) (w1 :: Int) -> let { - l_s1uz :: Int + l :: Int [LclId] - l_s1uz - = case w_s1v1 of { GHC.Types.I# x_aJ0 -> case w1_s1v2 of { GHC.Types.I# y_aJ3 -> GHC.Types.I# (GHC.Prim.+# x_aJ0 y_aJ3) } } } in + l = case w of { GHC.Types.I# x -> case w1 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } } } in let { - l1_s1uA :: Int + l1 :: Int [LclId] - l1_s1uA - = case w_s1v1 of { GHC.Types.I# x_aJ8 -> case w1_s1v2 of { GHC.Types.I# y_aJb -> GHC.Types.I# (GHC.Prim.-# x_aJ8 y_aJb) } } } in + l1 = case w of { GHC.Types.I# x -> case w1 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.-# x y) } } } in let { - l2_s1uB :: [Int] + l2 :: [Int] [LclId, Unf=OtherCon []] - l2_s1uB = GHC.Types.: @Int l1_s1uA (GHC.Types.[] @Int) } in + l2 = GHC.Types.: @Int l1 (GHC.Types.[] @Int) } in let { - l3_sJm :: [Int] + l3 :: [Int] [LclId, Unf=OtherCon []] - l3_sJm = GHC.Types.: @Int l_s1uz l2_s1uB } in - (# GHC.List.$w!! @Int l3_sJm 0#, GHC.List.$w!! @Int l3_sJm 1# #) + l3 = GHC.Types.: @Int l l2 } in + (# GHC.List.$w!! @Int l3 0#, GHC.List.$w!! @Int l3 1# #) -- RHS size: {terms: 10, types: 11, coercions: 0, joins: 0/0} pm [InlPrag=NOUSERINLINE[0]] :: Int -> Int -> (Int, Int) @@ -35,9 +33,9 @@ pm [InlPrag=NOUSERINLINE[0]] :: Int -> Int -> (Int, Int) Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1v1 [Occ=Once] :: Int) (w1_s1v2 [Occ=Once] :: Int) -> - case T10694.$wpm w_s1v1 w1_s1v2 of { (# ww1_s1v7 [Occ=Once], ww2_s1v8 [Occ=Once] #) -> (ww1_s1v7, ww2_s1v8) }}] -pm = \ (w_s1v1 :: Int) (w1_s1v2 :: Int) -> case T10694.$wpm w_s1v1 w1_s1v2 of { (# ww1_s1v7, ww2_s1v8 #) -> (ww1_s1v7, ww2_s1v8) } + Tmpl= \ (w [Occ=Once] :: Int) (w1 [Occ=Once] :: Int) -> + case T10694.$wpm w w1 of { (# ww1 [Occ=Once], ww2 [Occ=Once] #) -> (ww1, ww2) }}] +pm = \ (w :: Int) (w1 :: Int) -> case T10694.$wpm w w1 of { (# ww1, ww2 #) -> (ww1, ww2) } -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} m :: Int -> Int -> Int @@ -46,9 +44,8 @@ m :: Int -> Int -> Int Str=<L,U(U)><L,U(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (x_awo [Occ=Once] :: Int) (y_awp [Occ=Once] :: Int) -> - case pm x_awo y_awp of { (_ [Occ=Dead], mr_awr [Occ=Once]) -> mr_awr }}] -m = \ (x_awo :: Int) (y_awp :: Int) -> case T10694.$wpm x_awo y_awp of { (# ww1_s1v7, ww2_s1v8 #) -> ww2_s1v8 } + Tmpl= \ (x [Occ=Once] :: Int) (y [Occ=Once] :: Int) -> case pm x y of { (_ [Occ=Dead], mr [Occ=Once]) -> mr }}] +m = \ (x :: Int) (y :: Int) -> case T10694.$wpm x y of { (# ww1, ww2 #) -> ww2 } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T10694.$trModule4 :: GHC.Prim.Addr# diff --git a/testsuite/tests/stranal/should_compile/T13380b.hs b/testsuite/tests/stranal/should_compile/T13380b.hs new file mode 100644 index 0000000000..db873e8f92 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T13380b.hs @@ -0,0 +1,14 @@ +module Lib (m) where + +import Control.Exception + +throws :: IO () +throws = throwIO (userError "What") +{-# NOINLINE throws #-} + +bigDeadAction :: IO Int +bigDeadAction = return $ sum $ [0..999] +{-# NOINLINE bigDeadAction #-} + +m :: IO Int +m = throws >> bigDeadAction diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 012d3170e2..e807e4f9d8 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -33,7 +33,7 @@ test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, ['']) # T9208 fails (and should do so) if you have assertion checking on in the compiler # Hence the above expect_broken. See comments in the ticket -test('T10694', [ grep_errmsg(r'(Str|Cpr)=') ], compile, ['-dppr-cols=200 -ddump-simpl']) +test('T10694', [ grep_errmsg(r'(Str|Cpr)=') ], compile, ['-dppr-cols=200 -ddump-simpl -dsuppress-uniques']) test('T11770', [ check_errmsg('OneShot') ], compile, ['-ddump-simpl']) test('T13031', normal, makefile_test, []) @@ -51,3 +51,4 @@ test('T17852', [ grep_errmsg(r'\\$wf ::') ], compile, ['-ddump-worker-wrapper - test('T16029', normal, makefile_test, []) test('T10069', [ grep_errmsg(r'(wc1).*Int#$') ], compile, ['-dppr-cols=200 -ddump-simpl']) +test('T13380b', [ grep_errmsg('bigDeadAction') ], compile, ['-dppr-cols=200 -ddump-simpl']) diff --git a/testsuite/tests/stranal/should_run/T13380d.hs b/testsuite/tests/stranal/should_run/T13380d.hs new file mode 100644 index 0000000000..440c4ced1e --- /dev/null +++ b/testsuite/tests/stranal/should_run/T13380d.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +import Control.Exception +import GHC.Exts +import GHC.IO + +-- | An "unboxed" IO action that throws a precise excpetion that isn't inlined. +throws :: State# RealWorld -> State# RealWorld +throws s = case raiseIO# (toException (userError "What")) s of (# s', _ #) -> s' +{-# NOINLINE throws #-} + +{-# NOINLINE f #-} +f :: Int -> Int -> IO Int +-- à la #13380 +f x y | x>0 = IO $ \s -> case throws s of s' -> unIO (return 0) s' + | y>0 = return 1 + | otherwise = return 2 + +main = f 2 undefined >>= print diff --git a/testsuite/tests/stranal/should_run/T13380d.stderr b/testsuite/tests/stranal/should_run/T13380d.stderr new file mode 100644 index 0000000000..ee8cfb8b85 --- /dev/null +++ b/testsuite/tests/stranal/should_run/T13380d.stderr @@ -0,0 +1 @@ +T13380d: user error (What) diff --git a/testsuite/tests/stranal/should_run/T13380e.hs b/testsuite/tests/stranal/should_run/T13380e.hs new file mode 100644 index 0000000000..d807db091b --- /dev/null +++ b/testsuite/tests/stranal/should_run/T13380e.hs @@ -0,0 +1,18 @@ +import Control.Exception + +-- This is just like T13380d, but doesn't look through the IO abstraction. +-- With Nested CPR, it will result in very similar code, however! + +-- | An IO action that throws a precise excpetion that isn't inlined. +throws :: IO () +throws = throwIO (userError "What") +{-# NOINLINE throws #-} + +{-# NOINLINE f #-} +f :: Int -> Int -> IO Int +-- à la #13380 +f x y | x>0 = throws >> return 0 + | y>0 = return 1 + | otherwise = return 2 + +main = f 2 undefined >>= print diff --git a/testsuite/tests/stranal/should_run/T13380e.stderr b/testsuite/tests/stranal/should_run/T13380e.stderr new file mode 100644 index 0000000000..d118d7a50a --- /dev/null +++ b/testsuite/tests/stranal/should_run/T13380e.stderr @@ -0,0 +1 @@ +T13380e: user error (What) diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T index d822e482dd..341d8e2639 100644 --- a/testsuite/tests/stranal/should_run/all.T +++ b/testsuite/tests/stranal/should_run/all.T @@ -20,6 +20,8 @@ test('T11555a', normal, compile_and_run, ['']) test('T12368', exit_code(1), compile_and_run, ['']) test('T12368a', exit_code(1), compile_and_run, ['']) test('T13380', exit_code(1), compile_and_run, ['']) +test('T13380d', exit_code(1), compile_and_run, ['']) +test('T13380e', exit_code(1), compile_and_run, ['']) test('T14171', [expect_broken(14171), exit_code(1)], compile_and_run, ['']) test('T14290', normal, compile_and_run, ['']) test('T14285', normal, multimod_compile_and_run, ['T14285', '']) diff --git a/testsuite/tests/stranal/should_run/strun003.hs b/testsuite/tests/stranal/should_run/strun003.hs index 893847aa72..8b00768030 100644 --- a/testsuite/tests/stranal/should_run/strun003.hs +++ b/testsuite/tests/stranal/should_run/strun003.hs @@ -2,7 +2,9 @@ -- But it won't if the strictness analyser thinks that 'len' is use -- strictly, which was the case in GHC 6.0 --- See the io_hack_reqd in GHC.Core.Opt.DmdAnal +-- See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand +-- This is similar to T17676, but with an extra putStrLn. +-- See also #148, #1592. module Main where diff --git a/testsuite/tests/stranal/sigs/T13380c.hs b/testsuite/tests/stranal/sigs/T13380c.hs new file mode 100644 index 0000000000..24e28c9789 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T13380c.hs @@ -0,0 +1,14 @@ +module Lib (f) where + +import Control.Exception + +-- | Just an arbitrary IO action without throwIO that isn't inlined. +doesn'tThrow :: IO () +doesn'tThrow = return () +{-# NOINLINE doesn'tThrow #-} + +{-# NOINLINE f #-} +f :: Int -> Int -> IO Int +f x y | x>0 = doesn'tThrow >> (y `seq` return 0) + | y>0 = return 1 + | otherwise = return 2 diff --git a/testsuite/tests/stranal/sigs/T13380c.stderr b/testsuite/tests/stranal/sigs/T13380c.stderr new file mode 100644 index 0000000000..2001614a58 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T13380c.stderr @@ -0,0 +1,18 @@ + +==================== Strictness signatures ==================== +Lib.$trModule: +Lib.f: <S,1*U(U)><S,1*U(U)><L,U> + + + +==================== Cpr signatures ==================== +Lib.$trModule: m1 +Lib.f: + + + +==================== Strictness signatures ==================== +Lib.$trModule: +Lib.f: <S,1*U(U)><S,1*U(U)><L,U> + + diff --git a/testsuite/tests/stranal/sigs/T13380f.hs b/testsuite/tests/stranal/sigs/T13380f.hs new file mode 100644 index 0000000000..d8d94b6f07 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T13380f.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE InterruptibleFFI #-} + +module T13380f where + +-- This one concerns FFI calls, and tests precise exception detection +-- like T13380{d,e}. Unsafe FFI calls should be considered not to throw a +-- precise exception, all other FFI calls may well throw precise exceptions. +-- We test that by looking at the strictness signatures of f, g and h, so that +-- we don't actually have to provide C bindings. + +foreign import ccall unsafe "__unsafe" + unsafeCall :: IO () + +foreign import ccall safe "__safe" + safeCall :: IO () + +foreign import ccall interruptible "__interruptible" + interruptibleCall :: IO () + +{-# NOINLINE f #-} +f :: Int -> Int -> IO Int +-- Strict in y! +f x y | x>0 = unsafeCall >> (y `seq` return 0) + | y>0 = return 1 + | otherwise = return 2 + +{-# NOINLINE g #-} +g :: Int -> Int -> IO Int +-- à la #13380. Lazy in y! +g x y | x>0 = safeCall >> (y `seq` return 0) + | y>0 = return 1 + | otherwise = return 2 + +{-# NOINLINE h #-} +h :: Int -> Int -> IO Int +-- à la #13380. Lazy in y! +h x y | x>0 = interruptibleCall >> (y `seq` return 0) + | y>0 = return 1 + | otherwise = return 2 diff --git a/testsuite/tests/stranal/sigs/T13380f.stderr b/testsuite/tests/stranal/sigs/T13380f.stderr new file mode 100644 index 0000000000..dd53a9c971 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T13380f.stderr @@ -0,0 +1,33 @@ + +==================== Strictness signatures ==================== +T13380f.$trModule: +T13380f.f: <S,1*U(U)><S,1*U(U)><L,U> +T13380f.g: <S,1*U(U)><L,1*U(U)><L,U> +T13380f.h: <S,1*U(U)><L,1*U(U)><L,U> +T13380f.interruptibleCall: <L,U> +T13380f.safeCall: <L,U> +T13380f.unsafeCall: <L,U> + + + +==================== Cpr signatures ==================== +T13380f.$trModule: +T13380f.f: +T13380f.g: +T13380f.h: +T13380f.interruptibleCall: +T13380f.safeCall: +T13380f.unsafeCall: + + + +==================== Strictness signatures ==================== +T13380f.$trModule: +T13380f.f: <S,1*U(U)><S,1*U(U)><L,U> +T13380f.g: <S,1*U(U)><L,1*U(U)><L,U> +T13380f.h: <S,1*U(U)><L,1*U(U)><L,U> +T13380f.interruptibleCall: <L,U> +T13380f.safeCall: <L,U> +T13380f.unsafeCall: <L,U> + + diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index 3afe9c7cd8..8802389cb4 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -20,3 +20,5 @@ test('CaseBinderCPR', normal, compile, ['']) test('NewtypeArity', normal, compile, ['']) test('T5075', normal, compile, ['']) test('T17932', normal, compile, ['']) +test('T13380c', expect_broken('!3014'), compile, ['']) +test('T13380f', normal, compile, ['']) |