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
Pipeline #19409 failed with stages
in 412 minutes and 3 seconds
......@@ -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)
......
This diff is collapsed.
......@@ -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 )
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
......
......@@ -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.
......
......@@ -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)
......
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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#
......
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
......@@ -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'])
{-# 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 #-}