Commit 35f85046 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Fix nasty bug in w/w for absence analysis

This dark corner was exposed by Trac #14285.  It involves the
interaction between absence analysis and INLINABLE pragmas.

There is a full explanation in Note [aBSENT_ERROR_ID] in MkCore,
which you can read there.  The changes in this patch are

* Make exprIsHNF return True for absentError, treating
  absentError like an honorary data constructor.

* Make absentError /not/ be diverging, unlike other error Ids.

This is all a bit horrible.

* While doing this I found that exprOkForSpeculation didn't
  have a case for value lambdas so I added one.  It's not
  really called on lifted types much, but it seems like the
  right thing

(cherry picked from commit dbbee1ba)
parent f093d7ea
......@@ -390,17 +390,19 @@ mkDataConWorkId wkr_name data_con
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
-- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker is strict
-- Notice that we do *not* say the worker Id is strict
-- even if the data constructor is declared strict
-- e.g. data T = MkT !(Int,Int)
-- Why? Because the *wrapper* is strict (and its unfolding has case
-- expressions that do the evals) but the *worker* itself is not.
-- If we pretend it is strict then when we see
-- case x of y -> $wMkT y
-- Why? Because the *wrapper* $WMkT is strict (and its unfolding has
-- case expressions that do the evals) but the *worker* MkT itself is
-- not. If we pretend it is strict then when we see
-- case x of y -> MkT y
-- the simplifier thinks that y is "sure to be evaluated" (because
-- $wMkT is strict) and drops the case. No, $wMkT is not strict.
-- the worker MkT is strict) and drops the case. No, the workerId
-- MkT is not strict.
--
-- When the simplifier sees a pattern
-- However, the worker does have StrictnessMarks. When the simplifier
-- sees a pattern
-- case e of MkT x -> ...
-- it uses the dataConRepStrictness of MkT to mark x as evaluated;
-- but that's fine... dataConRepStrictness comes from the data con
......
......@@ -71,6 +71,7 @@ import DataCon
import PrimOp
import Id
import IdInfo
import PrelNames( absentErrorIdKey )
import Type
import TyCoRep( TyBinder(..) )
import Coercion
......@@ -1300,18 +1301,23 @@ it's applied only to dictionaries.
--
-- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSpeculation = expr_ok primOpOkForSpeculation
exprOkForSideEffects = expr_ok primOpOkForSideEffects
-- Polymorphic in binder type
-- There is one call at a non-Id binder type, in SetLevels
expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok _ (Lit _) = True
expr_ok _ (Type _) = True
expr_ok _ (Coercion _) = True
expr_ok primop_ok (Var v) = app_ok primop_ok v []
expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
expr_ok primop_ok (Var v) = app_ok primop_ok v []
expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
expr_ok primop_ok (Lam b e)
| isTyVar b = expr_ok primop_ok e
| otherwise = True
-- Tick annotations that *tick* cannot be speculated, because these
-- are meant to identify whether or not (and how often) the particular
......@@ -1332,7 +1338,7 @@ expr_ok primop_ok other_expr
_ -> False
-----------------------------
app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok primop_ok fun args
= case idDetails fun of
DFunId new_type -> not new_type
......@@ -1368,7 +1374,7 @@ app_ok primop_ok fun args
where
(arg_tys, _) = splitPiTys (idType fun)
arg_ok :: TyBinder -> Expr b -> Bool
arg_ok :: TyBinder -> CoreExpr -> Bool
arg_ok (Named _) _ = True -- A type argument
arg_ok (Anon ty) arg -- A term argument
| isUnliftedType ty = expr_ok primop_ok arg
......@@ -1565,9 +1571,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
-- There is at least one value argument
-- 'n' is number of value args to which the expression is applied
app_is_value :: CoreExpr -> Int -> Bool
app_is_value (Var fun) n_val_args
= idArity fun > n_val_args -- Under-applied function
|| is_con fun -- or constructor-like
app_is_value (Var f) nva = id_app_is_value f nva
app_is_value (Tick _ f) nva = app_is_value f nva
app_is_value (Cast f _) nva = app_is_value f nva
app_is_value (App f a) nva
......@@ -1575,6 +1579,13 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
| otherwise = app_is_value f nva
app_is_value _ _ = False
id_app_is_value id n_val_args
= is_con id
|| idArity id > n_val_args
|| id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in MkCore
-- absentError behaves like an honorary data constructor
{-
Note [exprIsHNF Tick]
......
......@@ -42,7 +42,7 @@ module MkCore (
mkNothingExpr, mkJustExpr,
-- * Error Ids
mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
......@@ -63,13 +63,11 @@ import TysWiredIn
import PrelNames
import HsUtils ( mkChunkified, chunkify )
import TcType ( mkSpecSigmaTy )
import Type
import Coercion ( isCoVar )
import TysPrim
import DataCon ( DataCon, dataConWorkId )
import IdInfo ( vanillaIdInfo, setStrictnessInfo,
setArityInfo )
import IdInfo
import Demand
import Name hiding ( varName )
import Outputable
......@@ -727,7 +725,6 @@ rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
pAT_ERROR_ID = mkRuntimeErrorId patErrorName
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName
tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
mkRuntimeErrorId :: Name -> Id
......@@ -738,7 +735,7 @@ mkRuntimeErrorId :: Name -> Id
-- The Addr# is expected to be the address of
-- a UTF8-encoded error string
mkRuntimeErrorId name
= mkVanillaGlobalWithInfo name runtime_err_ty bottoming_info
= mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
`setArityInfo` 1
......@@ -756,10 +753,11 @@ mkRuntimeErrorId name
strict_sig = mkClosedStrictSig [evalDmd] exnRes
-- exnRes: these throw an exception, not just diverge
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
-- See Note [Error and friends have an "open-tyvar" forall]
runtime_err_ty = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
-- See Note [Error and friends have an "open-tyvar" forall]
runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
(mkFunTy addrPrimTy openAlphaTy)
{- Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -769,4 +767,96 @@ mkRuntimeErrorId name
Notice the runtime-representation polymorphism. This ensures that
"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.
************************************************************************
* *
aBSENT_ERROR_ID
* *
************************************************************************
Note [aBSENT_ERROR_ID]
~~~~~~~~~~~~~~~~~~~~~~
We use aBSENT_ERROR_ID to build dummy values in workers. E.g.
f x = (case x of (a,b) -> b) + 1::Int
The demand analyser figures ot that only the second component of x is
used, and does a w/w split thus
f x = case x of (a,b) -> $wf b
$wf b = let a = absentError "blah"
x = (a,b)
in <the original RHS of f>
After some simplification, the (absentError "blah") thunk goes away.
------ Tricky wrinkle -------
Trac #14285 had, roughly
data T a = MkT a !a
{-# INLINABLE f #-}
f x = case x of MkT a b -> g (MkT b a)
It turned out that g didn't use the second component, and hence f doesn't use
the first. But the stable-unfolding for f looks like
\x. case x of MkT a b -> g ($WMkT b a)
where $WMkT is the wrapper for MkT that evaluates its arguments. We
apply the same w/w split to this unfolding (see Note [Worker-wrapper
for INLINEABLE functions] in WorkWrap) so the template ends up like
\b. let a = absentError "blah"
x = MkT a b
in case x of MkT a b -> g ($WMkT b a)
After doing case-of-known-constructor, and expanding $WMkT we get
\b -> g (case absentError "blah" of a -> MkT b a)
Yikes! That bogusly appears to evaluate the absentError!
This is extremely tiresome. Another way to think of this is that, in
Core, it is an invariant that a strict data contructor, like MkT, must
be be applied only to an argument in HNF. so (absentError "blah") had
better be non-bottom.
So the "solution" is to make absentError behave like a data constructor,
to respect this invariant. Rather than have a special case in exprIsHNF,
I eneded up doing this:
* Make absentError claim to be ConLike
* Make exprOkForSpeculation/exprOkForSideEffects
return True for ConLike things
* In Simplify.rebuildCase, make the
Note [Case to let transformation]
branch use exprOkForSpeculation rather than exprIsHNF, so that
it converts the absentError case to a let.
On the other hand if, by some bug or bizarre happenstance, we ever call
absentError, we should thow an exception. This should never happen, of
course, but we definitely can't return anything. e.g. if somehow we had
case absentError "foo" of
Nothing -> ...
Just x -> ...
then if we return, the case expression will select a field and continue.
Seg fault city. Better to throw an exception. (Even though we've said
it is ConLike :-)
-}
aBSENT_ERROR_ID
= mkVanillaGlobal absentErrorName absent_ty
where
absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
-- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
-- lifted-type things; see Note [Absent errors] in WwLib
mkAbsentErrorApp :: Type -- The type to instantiate 'a'
-> String -- The string to print
-> CoreExpr
mkAbsentErrorApp res_ty err_msg
= mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
where
err_string = Lit (mkMachString err_msg)
......@@ -444,7 +444,8 @@ lvlCase :: LevelEnv -- Level of in-scope names/tyvars
-> LvlM LevelledExpr -- Result expression
lvlCase env scrut_fvs scrut' case_bndr ty alts
| [(con@(DataAlt {}), bs, body)] <- alts
, exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec]
, exprOkForSpeculation (deTagExpr scrut')
-- See Note [Check the output scrutinee for okForSpec]
, not (isTopLvl dest_lvl) -- Can't have top-level cases
, not (floatTopLvlOnly env) -- Can float anywhere
= -- See Note [Floating cases]
......
......@@ -2179,41 +2179,49 @@ to just
This particular example shows up in default methods for
comparison operations (e.g. in (>=) for Int.Int32)
Note [Case elimination: lifted case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a case over a lifted type has a single alternative, and is being used
as a strict 'let' (all isDeadBinder bndrs), we may want to do this
transformation:
Note [Case to let transformation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a case over a lifted type has a single alternative, and is being
used as a strict 'let' (all isDeadBinder bndrs), we may want to do
this transformation:
case e of r ===> let r = e in ...r...
_ -> ...r...
(a) 'e' is already evaluated (it may so if e is a variable)
Specifically we check (exprIsHNF e). In this case
we can just allocate the WHNF directly with a let.
or
(b) 'x' is not used at all and e is ok-for-speculation
The ok-for-spec bit checks that we don't lose any
exceptions or divergence.
NB: it'd be *sound* to switch from case to let if the
scrutinee was not yet WHNF but was guaranteed to
converge; but sticking with case means we won't build a
thunk
or
(c) 'x' is used strictly in the body, and 'e' is a variable
Then we can just substitute 'e' for 'x' in the body.
See Note [Eliminating redundant seqs]
For (b), the "not used at all" test is important. Consider
case (case a ># b of { True -> (p,q); False -> (q,p) }) of
r -> blah
The scrutinee is ok-for-speculation (it looks inside cases), but we do
not want to transform to
let r = case a ># b of { True -> (p,q); False -> (q,p) }
in blah
because that builds an unnecessary thunk.
We treat the unlifted and lifted cases separately:
* Unlifted case: 'e' satisfies exprOkForSpeculation
(ok-for-spec is needed to satisfy the let/app invariant).
This turns case a +# b of r -> ...r...
into let r = a +# b in ...r...
and thence .....(a +# b)....
However, if we have
case indexArray# a i of r -> ...r...
we might like to do the same, and inline the (indexArray# a i).
But indexArray# is not okForSpeculation, so we don't build a let
in rebuildCase (lest it get floated *out*), so the inlining doesn't
happen either. Annoying.
* Lifted case: we need to be sure that the expression is already
evaluated (exprIsHNF). If it's not already evaluated
- we risk losing exceptions, divergence or
user-specified thunk-forcing
- even if 'e' is guaranteed to converge, we don't want to
create a thunk (call by need) instead of evaluating it
right away (call by value)
However, we can turn the case into a /strict/ let if the 'r' is
used strictly in the body. Then we won't lose divergence; and
we won't build a thunk because the let is strict.
See also Note [Eliminating redundant seqs]
NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
We want to turn
case (absentError "foo") of r -> ...MkT r...
into
let r = absentError "foo" in ...MkT r...
Note [Eliminating redundant seqs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2252,23 +2260,6 @@ Just for reference, the original code (added Jan 13) looked like this:
an eval'd function] in CoreUtils.)
Note [Case elimination: unlifted case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
case a +# b of r -> ...r...
Then we do case-elimination (to make a let) followed by inlining,
to get
.....(a +# b)....
If we have
case indexArray# a i of r -> ...r...
we might like to do the same, and inline the (indexArray# a i).
But indexArray# is not okForSpeculation, so we don't build a let
in rebuildCase (lest it get floated *out*), so the inlining doesn't
happen either.
This really isn't a big deal I think. The let can be
Further notes about case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider: test :: Integer -> IO ()
......@@ -2376,11 +2367,11 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
-- a) it binds only the case-binder
-- b) unlifted case: the scrutinee is ok-for-speculation
-- lifted case: the scrutinee is in HNF (or will later be demanded)
-- See Note [Case to let transformation]
| all_dead_bndrs
, if is_unlifted
then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case]
else exprIsHNF scrut -- See Note [Case elimination: lifted case]
|| scrut_is_demanded_var scrut
, if isUnliftedType (idType case_bndr)
then exprOkForSpeculation scrut
else exprIsHNF scrut || scrut_is_demanded_var scrut
= do { tick (CaseElim case_bndr)
; env' <- simplNonRecX env case_bndr scrut
; simplExprF env' rhs cont }
......@@ -2395,9 +2386,8 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
where
is_unlifted = isUnliftedType (idType case_bndr)
all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
scrut_is_demanded_var :: CoreExpr -> Bool
-- See Note [Eliminating redundant seqs]
......
......@@ -19,11 +19,12 @@ import Id
import IdInfo ( JoinArity, vanillaIdInfo )
import DataCon
import Demand
import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup
import MkCore ( mkAbsentErrorApp, mkCoreUbxTup
, mkCoreApp, mkCoreLet )
import MkId ( voidArgId, voidPrimId )
import TysPrim ( voidPrimTy )
import TysWiredIn ( tupleDataCon )
import TysPrim ( voidPrimTy )
import Literal ( absentLiteralOf )
import VarEnv ( mkInScopeSet )
import VarSet ( VarSet )
import Type
......@@ -31,7 +32,6 @@ import RepType ( isVoidTy )
import Coercion
import FamInstEnv
import BasicTypes ( Boxity(..) )
import Literal ( absentLiteralOf )
import TyCon
import UniqSupply
import Unique
......@@ -890,15 +890,24 @@ example, Trac #4306. For these we find a suitable literal,
using Literal.absentLiteralOf. We don't have literals for
every primitive type, so the function is partial.
[I did try the experiment of using an error thunk for unlifted
things too, relying on the simplifier to drop it as dead code,
by making absentError
(a) *not* be a bottoming Id,
(b) be "ok for speculation"
But that relies on the simplifier finding that it really
is dead code, which is fragile, and indeed failed when
profiling is on, which disables various optimisations. So
using a literal will do.]
Note: I did try the experiment of using an error thunk for unlifted
things too, relying on the simplifier to drop it as dead code.
But this is fragile
- It fails when profiling is on, which disables various optimisations
- It fails when reboxing happens. E.g.
data T = MkT Int Int#
f p@(MkT a _) = ...g p....
where g is /lazy/ in 'p', but only uses the first component. Then
'f' is /strict/ in 'p', and only uses the first component. So we only
pass that component to the worker for 'f', which reconstructs 'p' to
pass it to 'g'. Alas we can't say
...f (MkT a (absentError Int# "blah"))...
bacause `MkT` is strict in its Int# argument, so we get an absentError
exception when we shouldn't. Very annoying!
So absentError is only used for lifted types.
-}
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
......@@ -914,12 +923,12 @@ mk_absent_let dflags arg
= WARN( True, text "No absent value for" <+> ppr arg_ty )
Nothing
where
arg_ty = idType arg
abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
lifted_arg = arg `setIdStrictness` exnSig
-- Note in strictness signature that this is bottoming
-- (for the sake of the "empty case scrutinee not known to
-- diverge for sure lint" warning)
arg_ty = idType arg
abs_rhs = mkAbsentErrorApp arg_ty msg
msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
(ppr arg <+> ppr (idType arg))
-- We need to suppress uniques here because otherwise they'd
......
module Main where
import T14285a
import Prelude hiding (null)
main :: IO ()
main = do
let args = "hw"
print $ null $ pre_images 'a' (Rel (fromList [('a',sfromList args)]) (fromList [('b',sfromList args)]))
module T14285a where
import qualified Data.Foldable as F
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Prelude hiding (null)
data Set k = Set IS.IntSet
empty = Set IS.empty
null (Set a) = IS.null a
sfromList :: (Enum a, Foldable c) => c a -> Set a
sfromList xs = Set $ IS.fromList $ Prelude.map fromEnum $ F.toList xs
{-# inlineable fromList #-}
fromList :: Enum k => [(k,v)] -> Map k v
fromList kvs =
Map $ IM.fromList $ Prelude.map (\(k,v) -> (fromEnum k, v)) kvs
newtype Map k v = Map { unMap :: (IM.IntMap v) } deriving (Eq, Ord)
{-# inlineable findWithDefault #-}
findWithDefault d k (Map m) = IM.findWithDefault d (fromEnum k) m
data Rel a b = Rel !(Map a (Set b)) !(Map b (Set a))
{-# INLINEABLE images #-}
images x (Rel f b) = findWithDefault empty x f
{-# INLINEABLE pre_images #-}
pre_images x rel = images x $ mirrorRel rel
{-# INLINEABLE mirrorRel #-}
mirrorRel :: Rel a b -> Rel b a
mirrorRel (Rel f g) = Rel g f
......@@ -16,3 +16,4 @@ test('T12368', exit_code(1), compile_and_run, [''])
test('T12368a', exit_code(1), compile_and_run, [''])
test('T13380', [expect_broken(13380), exit_code(1)], compile_and_run, [''])
test('T14290', normal, compile_and_run, [''])
test('T14285', normal, multimod_compile_and_run, ['T14285', ''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment