Commit 9bd20e83 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

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
parent e9c0110c
......@@ -178,7 +178,7 @@ module GHC (
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
isDeadEndId, isDictonaryId,
recordSelectorTyCon,
-- ** Type constructors
......
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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)
......
......@@ -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]
......
......@@ -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
......
......@@ -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'']) }
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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')
......
......@@ -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
......
......@@ -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 )