...
 
Commits (6)
  • Ben Gamari's avatar
    e9c0110c
  • Sebastian Graf's avatar
    DmdAnal: Improve handling of precise exceptions · 9bd20e83
    Sebastian Graf authored
    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
    9bd20e83
  • Ben Gamari's avatar
    GHC.Cmm.Opt: Handle MO_XX_Conv · 568d7279
    Ben Gamari authored
    This MachOp was introduced by 2c959a18
    but a wildcard match in cmmMachOpFoldM hid the fact that it wasn't
    handled. Ideally we would eliminate the match but this appears to be a
    larger task.
    
    Fixes #18141.
    568d7279
  • wz1000's avatar
    Add info about typeclass evidence to .hie files · c8671dfa
    wz1000 authored
    See testsuite/tests/hiefile/should_run/HieQueries.hs and
    testsuite/tests/hiefile/should_run/HieQueries.stdout for an example of this
    
    Additionally,
    
    - Recurse into AbsBinds so that type information for pattern synonyms is saved
    - Made some scopes more accurate
    - Along with typeclass evidence info, also include information on Implicit
      Parameters
    
    Updates haddock submodule
    c8671dfa
  • wz1000's avatar
  • wz1000's avatar
    Mark NodeInfo with its origin(generated/source) · a984c8fd
    wz1000 authored
    a984c8fd
......@@ -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
......
......@@ -69,6 +69,7 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
_ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
......@@ -76,6 +77,7 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
-- Eliminate conversion NOPs
cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
......
......@@ -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)
......
This diff is collapsed.
......@@ -24,7 +24,6 @@ import GHC.Utils.Binary
import GHC.Iface.Binary ( getDictFastString )
import GHC.Data.FastMutInt
import GHC.Data.FastString ( FastString )
import GHC.Unit.Module ( Module )
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Utils.Outputable
......@@ -33,7 +32,6 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique.Supply ( takeUniqFromSupply )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Utils.Misc
import GHC.Iface.Env (NameCacheUpdater(..))
import qualified Data.Array as A
......@@ -49,42 +47,6 @@ import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
-- these two types.
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
| KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-- Not actually non deterministic as it is a KnownKey
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
compare LocalName{} _ = LT
compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
hieNameOcc :: HieName -> OccName
hieNameOcc (ExternalName _ occ _) = occ
hieNameOcc (LocalName occ _) = occ
hieNameOcc (KnownKeyName u) =
case lookupKnownKeyName u of
Just n -> nameOccName n
Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
(ppr (unpkUnique u))
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
......@@ -353,14 +315,6 @@ putName (HieSymbolTable next ref) bh name = do
-- ** Converting to and from `HieName`'s
toHieName :: Name -> HieName
toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
(nameSrcSpan name)
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)
fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName nc (ExternalName mod occ span) =
let cache = nsNames nc
......
......@@ -15,7 +15,6 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.Utils
import GHC.Types.Name
......@@ -39,17 +38,18 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
spanDiff
| span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
| otherwise = []
infoDiff'
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
++ (diffList diffType `on` nodeType) info1 info2
++ (diffIdents `on` nodeIdentifiers) info1 info2
infoDiff = case infoDiff' of
infoDiff' i1 i2
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
++ (diffList diffType `on` nodeType) i1 i2
++ (diffIdents `on` nodeIdentifiers) i1 i2
sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
infoDiff = case sinfoDiff info1 info2 of
[] -> []
xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
, "and", ppr (nodeIdentifiers info2,span2)
xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
, "and", ppr (sourcedNodeIdents info2,span2)
, "While comparing"
, ppr (normalizeIdents $ nodeIdentifiers info1), "and"
, ppr (normalizeIdents $ nodeIdentifiers info2)
, ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
, ppr (normalizeIdents $ sourcedNodeIdents info2)
]
]
......@@ -107,11 +107,29 @@ validAst (Node _ span children) = do
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
validateScopes mod asts = validScopes
validateScopes mod asts = validScopes ++ validEvLets
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
-- Check if everything on the RHS of an EvLet binding is also bound
-- somewhere in the AST
validEvLets = concatMap evVarInScope evletrhs
-- Check if a given evidence variable is bound
evVarInScope n = case M.lookup (Right n) refMap of
Nothing -> return $ hsep ["Local evidence variable:", ppr n
, "occuring in the rhs of a EvLet doesn't appear in the refmap"]
Just xs
| any (any isEvidenceBind) (map (identInfo . snd) xs) -> []
| otherwise -> return $ hsep ["Local evidence variable:"
, ppr n, "occuring in the rhs of a EvLet isn't bound in the refmap"]
-- All the evidence variables occuring on the RHS of an EvLet
evletrhs = S.fromList $ concatMap (evLets . identInfo . snd)
$ concat $ M.elems refMap
evLets = concatMap getEvidenceBindDeps
-- Check if all the names occur in their calculated scopes
validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
valid (Left _) _ = []
......@@ -122,15 +140,18 @@ validateScopes mod asts = validScopes
Just xs -> xs
Nothing -> []
inScope (sp, dets)
| (definedInAsts asts n)
| (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))
&& any isOccurrence (identInfo dets)
-- We validate scopes for names which are defined locally, and occur
-- in this span
-- in this span, or are evidence variables
= case scopes of
[] | (nameIsLocalOrFrom mod n
&& not (isDerivedOccName $ nameOccName n))
-- If we don't get any scopes for a local name then its an error.
-- We can ignore derived names.
[] | any isEvidenceContext (identInfo dets)
|| (nameIsLocalOrFrom mod n
&& not (isDerivedOccName $ nameOccName n))
-- If we don't get any scopes for a local name or
-- an evidence variable, then its an error.
-- We can ignore other kinds of derived names as
-- long as we take evidence vars into account
-> return $ hsep $
[ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
, "Doesn't have a calculated scope: ", ppr scopes]
......
......@@ -17,13 +17,16 @@ import GHC.Prelude
import Config
import GHC.Utils.Binary
import GHC.Data.FastString ( FastString )
import GHC.Builtin.Utils
import GHC.Iface.Type
import GHC.Unit.Module ( ModuleName, Module )
import GHC.Types.Name ( Name )
import GHC.Unit.Module ( ModuleName, Module )
import GHC.Types.Name
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Types.SrcLoc ( RealSrcSpan )
import GHC.Types.SrcLoc
import GHC.Types.Avail
import GHC.Types.Unique
import qualified GHC.Utils.Outputable as O ( (<>) )
import GHC.Utils.Misc
import qualified Data.Array as A
import qualified Data.Map as M
......@@ -33,6 +36,8 @@ import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
import Data.Coerce ( coerce )
import Data.Function ( on )
type Span = RealSrcSpan
......@@ -222,17 +227,16 @@ instance Outputable a => Outputable (HieASTs a) where
, rest
]
data HieAST a =
Node
{ nodeInfo :: NodeInfo a
{ sourcedNodeInfo :: SourcedNodeInfo a
, nodeSpan :: Span
, nodeChildren :: [HieAST a]
} deriving (Functor, Foldable, Traversable)
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
put_ bh $ nodeInfo ast
put_ bh $ sourcedNodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
......@@ -247,6 +251,38 @@ instance Outputable a => Outputable (HieAST a) where
header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
rest = vcat (map ppr ch)
-- | NodeInfos grouped by source
newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
deriving (Functor, Foldable, Traversable)
instance Binary (SourcedNodeInfo TypeIndex) where
put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
instance Outputable a => Outputable (SourcedNodeInfo a) where
ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat $
[ "Source: " O.<> ppr k
, ppr a
, rest
]
-- | Source of node info
data NodeOrigin
= SourceInfo
| GeneratedInfo
deriving (Eq, Enum, Ord)
instance Outputable NodeOrigin where
ppr SourceInfo = text "From source"
ppr GeneratedInfo = text "generated by ghc"
instance Binary NodeOrigin where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
......@@ -314,7 +350,7 @@ instance Monoid (IdentifierDetails a) where
instance Binary (IdentifierDetails TypeIndex) where
put_ bh dets = do
put_ bh $ identType dets
put_ bh $ S.toAscList $ identInfo dets
put_ bh $ S.toList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
<*> fmap S.fromDistinctAscList (get bh)
......@@ -363,6 +399,14 @@ data ContextInfo
-- | Record field
| RecField RecFieldContext (Maybe Span)
-- | Constraint/Dictionary evidence variable binding
| EvidenceVarBind
EvVarSource -- ^ how did this bind come into being
Scope -- ^ scope over which the value is bound
(Maybe Span) -- ^ span of the binding site
-- | Usage of evidence variable
| EvidenceVarUse
deriving (Eq, Ord)
instance Outputable ContextInfo where
......@@ -385,10 +429,16 @@ instance Outputable ContextInfo where
<+> ppr sc1 <+> "," <+> ppr sc2
ppr (RecField ctx sp) =
text "record field" <+> ppr ctx <+> pprBindSpan sp
ppr (EvidenceVarBind ctx sc sp) =
text "evidence variable" <+> ppr ctx
$$ "with scope:" <+> ppr sc
$$ pprBindSpan sp
ppr (EvidenceVarUse) =
text "usage of evidence variable"
pprBindSpan :: Maybe Span -> SDoc
pprBindSpan Nothing = text ""
pprBindSpan (Just sp) = text "at:" <+> ppr sp
pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
......@@ -422,6 +472,12 @@ instance Binary ContextInfo where
put_ bh a
put_ bh b
put_ bh MatchBind = putByte bh 9
put_ bh (EvidenceVarBind a b c) = do
putByte bh 10
put_ bh a
put_ bh b
put_ bh c
put_ bh EvidenceVarUse = putByte bh 11
get bh = do
(t :: Word8) <- get bh
......@@ -436,8 +492,65 @@ instance Binary ContextInfo where
7 -> TyVarBind <$> get bh <*> get bh
8 -> RecField <$> get bh <*> get bh
9 -> return MatchBind
10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
11 -> return EvidenceVarUse
_ -> panic "Binary ContextInfo: invalid tag"
data EvVarSource
= EvPatternBind -- ^ bound by a pattern match
| EvSigBind -- ^ bound by a type signature
| EvWrapperBind -- ^ bound by a hswrapper
| EvImplicitBind -- ^ bound by an implicit variable
| EvExternalBind -- ^ Bound by some instance
| EvLetBind EvBindDeps -- ^ A direct let binding
deriving (Eq,Ord)
instance Binary EvVarSource where
put_ bh EvPatternBind = putByte bh 0
put_ bh EvSigBind = putByte bh 1
put_ bh EvWrapperBind = putByte bh 2
put_ bh EvImplicitBind = putByte bh 3
put_ bh EvExternalBind = putByte bh 4
put_ bh (EvLetBind deps) = do
putByte bh 5
put_ bh deps
get bh = do
(t :: Word8) <- get bh
case t of
0 -> pure EvPatternBind
1 -> pure EvSigBind
2 -> pure EvWrapperBind
3 -> pure EvImplicitBind
4 -> pure EvExternalBind
5 -> EvLetBind <$> get bh
_ -> panic "Binary EvVarSource: invalid tag"
instance Outputable EvVarSource where
ppr EvPatternBind = text "bound by a pattern"
ppr EvSigBind = text "bound by a type signature"
ppr EvWrapperBind = text "bound by a HsWrapper"
ppr EvImplicitBind = text "bound by an implicit variable binding"
ppr EvExternalBind = text "bound by an instance"
ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
-- | Eq/Ord instances compare on the converted HieName,
-- as non-exported names may have different uniques after
-- a roundtrip
newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
deriving Outputable
instance Eq EvBindDeps where
(==) = coerce ((==) `on` map toHieName)
instance Ord EvBindDeps where
compare = coerce (compare `on` map toHieName)
instance Binary EvBindDeps where
put_ bh (EvBindDeps xs) = put_ bh xs
get bh = EvBindDeps <$> get bh
-- | Types of imports and exports
data IEType
= Import
......@@ -587,3 +700,46 @@ instance Binary TyVarScope where
0 -> ResolvedScopes <$> get bh
1 -> UnresolvedScope <$> get bh <*> get bh
_ -> panic "Binary TyVarScope: invalid tag"
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
-- these two types.
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
| KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d
-- TODO (int-index): Perhaps use RealSrcSpan in HieName?
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-- Not actually non deterministic as it is a KnownKey
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
compare LocalName{} _ = LT
compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
hieNameOcc :: HieName -> OccName
hieNameOcc (ExternalName _ occ _) = occ
hieNameOcc (LocalName occ _) = occ
hieNameOcc (KnownKeyName u) =
case lookupKnownKeyName u of
Just n -> nameOccName n
Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
(ppr (unpkUnique u))
toHieName :: Name -> HieName
toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
(nameSrcSpan name)
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)
This diff is collapsed.
......@@ -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
......
......@@ -267,7 +267,7 @@ data IdInfo
-- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and
-- call arity info in one 64-bit word. Packing these fields reduces size
-- of `IdInfo` from 12 words to 7 words and reduces residency by almost
-- 4% in some programs.
-- 4% in some programs. See #17497 and associated MR.
--
-- See documentation of the getters for what these packed fields mean.
}
......
......@@ -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
......
{-# LANGUAGE MagicHash #-}
module T18141 where
import GHC.Exts
divInt8# :: Int8# -> Int8# -> Int8#
x# `divInt8#` y#
| isTrue# (x# `gtInt8#` zero#) && isTrue# (y# `ltInt8#` zero#) =
((x# `subInt8#` one#) `quotInt8#` y#) `subInt8#` one#
| isTrue# (x# `ltInt8#` zero#) && isTrue# (y# `gtInt8#` zero#) =
((x# `plusInt8#` one#) `quotInt8#` y#) `subInt8#` one#
| otherwise = x# `quotInt8#` y#
where
zero# = narrowInt8# 0#
one# = narrowInt8# 1#
# Verify that we optimize away conditional branches which always jump
# to the same target.
test('T15188', normal, makefile_test, [])
test('T18141', normal, compile, [''])
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RecordWildCards #-}
module Scopes where
-- Verify that evidence bound by patern
-- synonyms has correct scope
pattern LL :: Num a => a -> a
pattern LL x <- (subtract 1 -> x)
where
LL x = x + 1
data T = C { x :: Int, y :: Char }
-- Verify that names generated from record construction are in scope
-- Verify that names generated from record construction
-- have correct scope
foo = C { x = 1 , y = 'a' }
-- Verify that implicit paramters have correct scope
bar :: (?x :: Int) => Int
bar = ?x + 1
baz :: Int
baz = bar + ?x
where ?x = 2
-- Verify that variables bound in pattern
-- synonyms have the correct scope
pattern A a b = (a , b)
-- Verify that record wildcards are in scope
sdaf :: T
sdaf = C{..}
......
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import System.Environment
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Types.Unique.Supply
import GHC.Types.Name
import Data.Tree
import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
import Data.Maybe (fromJust)
import GHC.Driver.Session
import GHC.SysTools
import GHC.Utils.Outputable ( Outputable, renderWithStyle, ppr, defaultUserStyle, initSDocContext, text)
import qualified Data.Map as M
import Data.Foldable
class C a where
f :: a -> Char
instance C Char where
f x = x
instance C a => C [a] where
f x = 'a'
foo :: C a => a -> Char
foo x = f [x]
-- ^ this is the point
point :: (Int,Int)
point = (31,9)
bar :: Show x => x -> String
bar x = show [(1,x,A)]
-- ^ this is the point'
point' :: (Int,Int)
point' = (37,9)
data A = A deriving Show
makeNc :: IO NameCache
makeNc = do
uniq_supply <- mkSplitUniqSupply 'z'
return $ initNameCache uniq_supply []
dynFlagsForPrinting :: String -> IO DynFlags
dynFlagsForPrinting libdir = do
systemSettings <- initSysTools libdir
return $ defaultDynFlags systemSettings (LlvmConfig [] [])
main = do
libdir:_ <- getArgs
df <- dynFlagsForPrinting libdir
nc <- makeNc
hfr <- readHieFile (NCU (\f -> pure $ snd $ f nc)) "HieQueries.hie"
let hf = hie_file_result hfr
refmap = generateReferencesMap $ getAsts $ hie_asts hf
explainEv df hf refmap point
explainEv df hf refmap point'
return ()
explainEv :: DynFlags -> HieFile -> RefMap Int -> (Int,Int) -> IO ()
explainEv df hf refmap point = do
putStrLn $ replicate 26 '='
putStrLn $ "At point " ++ show point ++ ", we found:"
putStrLn $ replicate 26 '='
putStr $ drawForest ptrees
where
trees = getEvidenceTreesAtPoint hf refmap point
ptrees = fmap (pprint . fmap expandType) <$> trees
expandType = text . renderHieType df .
flip recoverFullType (hie_types hf)
pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
pprint = pretty . renderWithStyle (initSDocContext df sty) . ppr
sty = defaultUserStyle
==========================
At point (31,9), we found:
==========================
│ $dC at HieQueries.hs:31:1-13, of type: C [a]
│ is an evidence variable bound by a let, depending on: [$fC[], $dC]
│ with scope: LocalScope HieQueries.hs:31:1-13
│ bound at: HieQueries.hs:31:1-13
│ Defined at <no location info>
|
+- ┌
| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a]
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ Defined at HieQueries.hs:27:10
| └
|
`- ┌
│ $dC at HieQueries.hs:31:1-13, of type: C a
│ is an evidence variable bound by a type signature
│ with scope: LocalScope HieQueries.hs:31:1-13
│ bound at: HieQueries.hs:31:1-13
│ Defined at <no location info>
==========================
At point (37,9), we found:
==========================
│ $dShow at HieQueries.hs:37:1-22, of type: Show [(Integer, x, A)]
│ is an evidence variable bound by a let, depending on: [$fShow[],
│ $dShow]
│ with scope: LocalScope HieQueries.hs:37:1-22
│ bound at: HieQueries.hs:37:1-22
│ Defined at <no location info>
|
+- ┌
| │ $fShow[] at HieQueries.hs:(1,1)-(82,26), of type: forall a. Show a => Show [a]
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ Defined in `GHC.Show'
| └
|
`- ┌
│ $dShow at HieQueries.hs:37:1-22, of type: Show (Integer, x, A)
│ is an evidence variable bound by a let, depending on: [$fShow(,,),
│ $dShow, $dShow, $dShow]
│ with scope: LocalScope HieQueries.hs:37:1-22
│ bound at: HieQueries.hs:37:1-22
│ Defined at <no location info>
|
+- ┌
| │ $fShow(,,) at HieQueries.hs:(1,1)-(82,26), of type: forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ Defined in `GHC.Show'
| └
|
+- ┌
| │ $dShow at HieQueries.hs:37:1-22, of type: Show Integer
| │ is an evidence variable bound by a let, depending on: [$fShowInteger]
| │ with scope: LocalScope HieQueries.hs:37:1-22
| │ bound at: HieQueries.hs:37:1-22
| │ Defined at <no location info>
| └
| |
| `- ┌
| │ $fShowInteger at HieQueries.hs:(1,1)-(82,26), of type: Show Integer
| │ is an evidence variable bound by an instance
| │ with scope: ModuleScope
| │
| │ Defined in `GHC.Show'
| └
|
+- ┌
| │ $dShow at HieQueries.hs:37:1-22, of type: Show x
| │ is an evidence variable bound by a type signature
| │ with scope: LocalScope HieQueries.hs:37:1-22
| │ bound at: HieQueries.hs:37:1-22
| │ Defined at <no location info>
| └
|
`- ┌
│ $dShow at HieQueries.hs:37:1-22, of type: Show A
│ is an evidence variable bound by a let, depending on: [$fShowA]
│ with scope: LocalScope HieQueries.hs:37:1-22
│ bound at: HieQueries.hs:37:1-22
│ Defined at <no location info>
|
`- ┌
│ $fShowA at HieQueries.hs:42:21-24, of type: Show A
│ is an evidence variable bound by an instance
│ with scope: ModuleScope
│ Defined at HieQueries.hs:42:21
......@@ -42,16 +42,9 @@ dynFlagsForPrinting libdir = do
systemSettings <- initSysTools libdir
return $ defaultDynFlags systemSettings (LlvmConfig [] [])
selectPoint :: HieFile -> (Int,Int) -> HieAST Int
selectPoint hf (sl,sc) = case M.toList (getAsts $ hie_asts hf) of
[(fs,ast)] ->
case selectSmallestContaining (sp fs) ast of
Nothing -> error "point not found"
Just ast' -> ast'
_ -> error "map should only contain a single AST"
where
sloc fs = mkRealSrcLoc fs sl sc
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
selectPoint' hf loc =
maybe (error "point not found") id $ selectPoint hf loc
main = do
libdir:_ <- getArgs
......@@ -61,6 +54,6 @@ main = do
let hf = hie_file_result hfr
forM_ [p1,p2,p3,p4] $ \point -> do
putStr $ "At " ++ show point ++ ", got type: "
let types = nodeType $ nodeInfo $ selectPoint hf point
let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
forM_ types $ \typ -> do
putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('HieQueries', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
......@@ -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 #-}
{-# 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