)
import MkId ( eRROR_ID )
import Literal ( mkStringLit )
-import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo, zapDemandInfo,
setUnfoldingInfo,
import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
+import CoreUnfold ( mkUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF,
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType
)
-import VarEnv ( elemVarEnv )
+import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
+import StaticFlags ( opt_PprStyle_Debug )
import OrdList
-import Maybe ( Maybe )
import Maybes ( orElse )
import Outputable
import Util ( notNull )
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
| isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
- simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
+ simplNonRecBndr env bndr `thenSmpl` \ (env, bndr1) ->
simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 ->
-- Now complete the binding and simplify the body
let
- -- simplLetBndr doesn't deal with the IdInfo, so we must
- -- do so here (c.f. simplLazyBind)
- bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
- env2 = modifyInScope env1 bndr2 bndr2
+ (env2,bndr2) = addLetIdInfo env1 bndr bndr1
in
if needsCaseBinding bndr_ty rhs1
then
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
- simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
+ simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
-> SimplM (FloatsWith SimplEnv)
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = let -- Transfer the IdInfo of the original binder to the new binder
- -- This is crucial: we must preserve
- -- strictness
- -- rules
- -- worker info
- -- etc. To do this we must apply the current substitution,
- -- which incorporates earlier substitutions in this very letrec group.
- --
- -- NB 1. We do this *before* processing the RHS of the binder, so that
- -- its substituted rules are visible in its own RHS.
- -- This is important. Manuel found cases where he really, really
- -- wanted a RULE for a recursive function to apply in that function's
- -- own right-hand side.
- --
- -- NB 2: We do not transfer the arity (see Subst.substIdInfo)
- -- The arity of an Id should not be visible
- -- in its own RHS, else we eta-reduce
- -- f = \x -> f x
- -- to
- -- f = f
- -- which isn't sound. And it makes the arity in f's IdInfo greater than
- -- the manifest arity, which isn't good.
- -- The arity will get added later.
- --
- -- NB 3: It's important that we *do* transer the loop-breaker OccInfo,
- -- because that's what stops the Id getting inlined infinitely, in the body
- -- of the letrec.
-
- -- NB 4: does no harm for non-recursive bindings
-
- bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
- env1 = modifyInScope env bndr2 bndr2
+ = let
+ (env1,bndr2) = addLetIdInfo env bndr bndr1
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
- rhs_cont = mkRhsStop (idType bndr1)
+ rhs_cont = mkRhsStop (idType bndr2)
in
-- Simplify the RHS; note the mkRhsStop, which tells
-- the simplifier that this is the RHS of a let.
case_ty' = substTy env case_ty -- c.f. defn of simplExpr
simplExprF env (Let (Rec pairs) body) cont
- = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
\begin{code}
simplNote env (Coerce to from) body cont
= let
+ addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic
+ -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
+ -- two are the same. This happens a lot in Happy-generated parsers
+ | s1 `coreEqType` k1 = cont
+
addCoerce s1 k1 (CoerceIt t1 cont)
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- we may find (coerce T (coerce S (\x.e))) y
-- and we'd like it to simplify to e[y/x] in one round
-- of simplification
- | t1 `coreEqType` k1 = cont -- The coerces cancel out
- | otherwise = CoerceIt t1 cont -- They don't cancel, but
- -- the inner one is redundant
+ | t1 `coreEqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg), -- This whole case only works for value args
= knownCon env (LitAlt lit) [] case_bndr alts cont
| otherwise
- = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
+ = -- Prepare the alternatives.
+ prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
- -- Deal with the case binder, and prepare the continuation;
+ -- Prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
res_ty' = contResultType dup_cont
in
- -- Deal with variable scrutinee
+ -- Deal with case binder
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- Deal with the case alternatives
-> SimplM [OutAlt] -- Includes the continuation
simplAlts env handled_cons case_bndr' alts cont'
- = mapSmpl simpl_alt alts
+ = do { mb_alts <- mapSmpl simpl_alt alts
+ ; return [alt' | Just (_, alt') <- mb_alts] }
+ -- Filter out the alternatives that are inaccessible
where
- simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont' `thenSmpl` \ (_, alt') ->
- returnSmpl alt'
+ simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont'
simplAlt :: SimplEnv -> [AltCon] -> OutId -> InAlt -> SimplCont
- -> SimplM (Maybe TvSubstEnv, OutAlt)
+ -> SimplM (Maybe (TvSubstEnv, OutAlt))
-- Simplify an alternative, returning the type refinement for the
-- alternative, if the alternative does any refinement at all
+-- Nothing => the alternative is inaccessible
simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Nothing, (DEFAULT, [], rhs'))
+ returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
where
env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
-- Record the constructors that the case-binder *can't* be.
simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Nothing, (LitAlt lit, [], rhs'))
+ returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
where
env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
env' = mk_rhs_env env case_bndr' unf
in
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Nothing, (DataAlt con, vs', rhs'))
+ returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
| otherwise -- GADT case
= let
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
- case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of {
- Nothing -- Dead code; for now, I'm just going to put in an
- -- error case so I can see them
+ case coreRefineTys con tvs' (idType case_bndr') of {
+ Nothing -- Inaccessible
+ | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case
+ -- so we can see it
-> let rhs' = mkApps (Var eRROR_ID)
[Type (substTy env (exprType rhs)),
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
- returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ;
+ returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs')))
+
+ | otherwise -- Filter out the inaccessible branch
+ -> return Nothing ;
Just refine@(tv_subst_env, _) -> -- The normal case
vs' = tvs' ++ ids'
in
simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Just tv_subst_env, (DataAlt con, vs', rhs')) }
+ returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) }
where
-- add_evals records the evaluated-ness of the bound variables of
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
--- gaw 2004
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
where
go env [] = returnSmpl (emptyFloats env, [])
go env (alt:alts)
- = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
- addFloats env floats1 $ \ env ->
- go env alts `thenSmpl` \ (floats2, alts') ->
- returnSmpl (floats2, alt' : alts')
+ = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt
+ ; addFloats env floats1 $ \ env -> do
+ { (floats2, alts') <- go env alts
+ ; returnSmpl (floats2, case mb_alt' of
+ Just alt' -> alt' : alts'
+ Nothing -> alts'
+ )}}
mkDupableAlt env case_bndr' cont alt
- = simplAlt env [] case_bndr' alt cont `thenSmpl` \ (mb_reft, (con, bndrs', rhs')) ->
+ = simplAlt env [] case_bndr' alt cont `thenSmpl` \ mb_stuff ->
+ case mb_stuff of {
+ Nothing -> returnSmpl (emptyFloats env, Nothing) ;
+
+ Just (reft, (con, bndrs', rhs')) ->
-- Safe to say that there are no handled-cons for the DEFAULT case
if exprIsDupable rhs' then
- returnSmpl (emptyFloats env, (con, bndrs', rhs'))
+ returnSmpl (emptyFloats env, Just (con, bndrs', rhs'))
-- It is worth checking for a small RHS because otherwise we
-- get extra let bindings that may cause an extra iteration of the simplifier to
-- inline back in place. Quite often the rhs is just a variable or constructor.
rhs_ty' = exprType rhs'
used_bndrs' = filter abstract_over (case_bndr' : bndrs')
abstract_over bndr
- | isTyVar bndr = not (mb_reft `refines` bndr)
+ | isTyVar bndr = not (bndr `elemVarEnv` reft)
-- Don't abstract over tyvar binders which are refined away
+ -- See Note [Refinement] below
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
- refines Nothing bndr = False
- refines (Just tv_subst) bndr = bndr `elemVarEnv` tv_subst
- -- See Note [Refinement] below
in
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
+ newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
join_rhs = mkLams really_final_bndrs rhs'
join_call = mkApps (Var join_bndr) final_args
in
- returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
+ returnSmpl (unitFloat env join_bndr join_rhs, Just (con, bndrs', join_call)) }
\end{code}
Note [Refinement]
projects / ghc-hetmet.git / blobdiff