SimplCont(..), DupFlag(..), ArgInfo(..),
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
countValArgs, countArgs, splitInlineCont,
- mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
+ mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext, interestingArgContext,
interestingArg, mkArgInfo,
import NewDemand
import SimplMonad
import Type hiding( substTy )
+import Coercion ( coercionKind )
import TyCon
import DataCon
import Unify ( dataConCannotMatch )
\begin{code}
data SimplCont
= Stop -- An empty context, or hole, []
- OutType -- Type of the result
CallCtxt -- True <=> There is something interesting about
-- the context, and hence the inliner
-- should be a bit keener (see interestingCallContext)
SimplCont
| StrictArg -- e C
- OutExpr OutType -- e and its type
+ OutExpr -- e
CallCtxt -- Whether *this* argument position is interesting
ArgInfo -- Whether the function at the head of e has rules, etc
SimplCont -- plus strictness flags for *further* args
}
instance Outputable SimplCont where
- ppr (Stop ty _) = ptext SLIT("Stop") <+> ppr ty
+ ppr (Stop interesting) = ptext SLIT("Stop") <> brackets (ppr interesting)
ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg)
{- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
- ppr (StrictArg f _ _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
+ ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
-------------------
-mkBoringStop :: OutType -> SimplCont
-mkBoringStop ty = Stop ty BoringCtxt
+mkBoringStop :: SimplCont
+mkBoringStop = Stop BoringCtxt
-mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
-mkLazyArgStop ty cci = Stop ty cci
-
-mkRhsStop :: OutType -> SimplCont
-mkRhsStop ty = Stop ty BoringCtxt
+mkLazyArgStop :: CallCtxt -> SimplCont
+mkLazyArgStop cci = Stop cci
-------------------
contIsRhsOrArg (Stop {}) = True
contIsTrivial other = False
-------------------
-contResultType :: SimplCont -> OutType
-contResultType (Stop to_ty _) = to_ty
-contResultType (StrictArg _ _ _ _ cont) = contResultType cont
-contResultType (StrictBind _ _ _ _ cont) = contResultType cont
-contResultType (ApplyTo _ _ _ cont) = contResultType cont
-contResultType (CoerceIt _ cont) = contResultType cont
-contResultType (Select _ _ _ _ cont) = contResultType cont
+contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
+contResultType env ty cont
+ = go cont ty
+ where
+ subst_ty se ty = substTy (se `setInScope` env) ty
+
+ go (Stop {}) ty = ty
+ go (CoerceIt co cont) ty = go cont (snd (coercionKind co))
+ go (StrictBind _ bs body se cont) ty = go cont (subst_ty se (exprType (mkLams bs body)))
+ go (StrictArg fn _ _ cont) ty = go cont (funResultTy (exprType fn))
+ go (Select _ _ alts se cont) ty = go cont (subst_ty se (coreAltsType alts))
+ go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se)
+
+ apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
+ apply_to_arg ty other se = funResultTy ty
-------------------
countValArgs :: SimplCont -> Int
-- See test simpl017 (and Trac #1627) for a good example of why this is important
splitInlineCont (ApplyTo dup (Type ty) se c)
- | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
-splitInlineCont cont@(Stop ty _) = Just (mkBoringStop ty, cont)
-splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
-splitInlineCont cont@(StrictArg _ fun_ty _ _ _) = Just (mkBoringStop (funArgTy fun_ty), cont)
+ | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
+splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont)
+splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont)
+splitInlineCont cont@(StrictArg {}) = Just (mkBoringStop, cont)
splitInlineCont other = Nothing
- -- NB: the calculation of the type for mkBoringStop is an annoying
- -- duplication of the same calucation in mkDupableCont
\end{code}
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivation for inlining it
- interesting (StrictArg _ _ cci _ _) = cci
+ interesting (StrictArg _ cci _ _) = cci
interesting (StrictBind {}) = BoringCtxt
- interesting (Stop ty cci) = cci
+ interesting (Stop cci) = cci
interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
, ai_discs = vanilla_discounts }
| otherwise
= ArgInfo { ai_rules = interestingArgContext fun call_cont
- , ai_strs = arg_stricts
+ , ai_strs = add_type_str (idType fun) arg_stricts
, ai_discs = arg_discounts }
where
vanilla_discounts, arg_discounts :: [Int]
map isStrictDmd demands -- Finite => result is bottom
else
map isStrictDmd demands ++ vanilla_stricts
-
| otherwise
-> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
<+> ppr n_val_args <+> ppr demands )
vanilla_stricts -- Not enough args, or no strictness
+ add_type_str :: Type -> [Bool] -> [Bool]
+ -- If the function arg types are strict, record that in the 'strictness bits'
+ -- No need to instantiate because unboxed types (which dominate the strict
+ -- types) can't instantiate type variables.
+ -- add_type_str is done repeatedly (for each call); might be better
+ -- once-for-all in the function
+ -- But beware primops/datacons with no strictness
+ add_type_str fun_ty [] = []
+ add_type_str fun_ty strs -- Look through foralls
+ | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions
+ = add_type_str fun_ty' strs
+ add_type_str fun_ty (str:strs) -- Add strict-type info
+ | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
+ = (str || isStrictType arg_ty) : add_type_str fun_ty' strs
+ add_type_str fun_ty strs
+ = strs
+
{- Note [Unsaturated functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (test eyeball/inline4)
interestingArgContext fn call_cont
= idHasRules fn || go call_cont
where
- go (Select {}) = False
- go (ApplyTo {}) = False
- go (StrictArg _ _ cci _ _) = interesting cci
- go (StrictBind {}) = False -- ??
- go (CoerceIt _ c) = go c
- go (Stop _ cci) = interesting cci
+ go (Select {}) = False
+ go (ApplyTo {}) = False
+ go (StrictArg _ cci _ _) = interesting cci
+ go (StrictBind {}) = False -- ??
+ go (CoerceIt _ c) = go c
+ go (Stop cci) = interesting cci
interesting (ArgCtxt rules _) = rules
interesting other = False
-> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
- | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
+ | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline
-- because it might be referred to "earlier"
| isExportedId bndr = False
| exprIsTrivial rhs = True
However for GlobalIds we can look at the arity; and for primops we
must, since they have no unfolding.
-* Regardless of whether 'f' is a vlaue, we always want to
+* Regardless of whether 'f' is a value, we always want to
reduce (/\a -> f a) to f
This came up in a RULE: foldr (build (/\a -> g a))
- did not match foldr (build (/\b -> ...something complex...))
+ did not match foldr (build (/\b -> ...something complex...))
The type checker can insert these eta-expanded versions,
with both type and dictionary lambdas; hence the slightly
ad-hoc isDictId
We'd like to float this to
y1 = /\a. e1
y2 = /\a. e2
- x = /\a. C (y1 a) (y2 a)
+ x = /\a. C (y1 a) (y2 a)
for the usual reasons: we want to inline x rather vigorously.
You may think that this kind of thing is rare. But in some programs it is
\begin{code}
-mkCase :: OutExpr -> OutId -> OutType
- -> [OutAlt] -- Increasing order
+mkCase :: OutExpr -> OutId -> [OutAlt] -- Increasing order
-> SimplM OutExpr
--------------------------------------------------
--- 1. Check for empty alternatives
---------------------------------------------------
-
--- This isn't strictly an error. It's possible that the simplifer might "see"
--- that an inner case has no accessible alternatives before it "sees" that the
--- entire branch of an outer case is inaccessible. So we simply
--- put an error case here insteadd
-mkCase scrut case_bndr ty []
- = pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
- return (mkApps (Var rUNTIME_ERROR_ID)
- [Type ty, Lit (mkStringLit "Impossible alternative")])
-
-
---------------------------------------------------
-- 2. Identity case
--------------------------------------------------
-mkCase scrut case_bndr ty alts -- Identity case
+mkCase scrut case_bndr alts -- Identity case
| all identity_alt alts
= do tick (CaseIdentity case_bndr)
return (re_cast scrut)
--------------------------------------------------
-- Catch-all
--------------------------------------------------
-mkCase scrut bndr ty alts = return (Case scrut bndr ty alts)
+mkCase scrut bndr alts = return (Case scrut bndr (coreAltsType alts) alts)
\end{code}
import Type hiding ( substTy, extendTvSubst )
import SimplEnv
import SimplUtils
+import Literal ( mkStringLit )
+import MkId ( rUNTIME_ERROR_ID )
import Id
import Var
import IdInfo
import Maybes ( orElse )
import Data.List ( mapAccumL )
import Outputable
+import MonadUtils
import FastString
\end{code}
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= do { let rhs_env = rhs_se `setInScope` env
- (tvs, body) = collectTyBinders rhs
+ (tvs, body) = case collectTyBinders rhs of
+ (tvs, body) | not_lam body -> (tvs,body)
+ | otherwise -> ([], rhs)
+ not_lam (Lam _ _) = False
+ not_lam _ = True
+ -- Do not do the "abstract tyyvar" thing if there's
+ -- a lambda inside, becuase it defeats eta-reduction
+ -- f = /\a. \x. g a x
+ -- should eta-reduce
+
; (body_env, tvs') <- simplBinders rhs_env tvs
- -- See Note [Floating and type abstraction]
- -- in SimplUtils
+ -- See Note [Floating and type abstraction] in SimplUtils
- -- Simplify the RHS; note the mkRhsStop, which tells
- -- the simplifier that this is the RHS of a let.
- ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
- ; (body_env1, body1) <- simplExprF body_env body rhs_cont
+ -- Simplify the RHS
+ ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
-- ANF-ise a constructor or PAP rhs
; (body_env2, body2) <- prepareRhs body_env1 body1
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
- ; return (extendFloats env poly_binds, rhs') }
+ ; env' <- foldlM add_poly_bind env poly_binds
+ ; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
+ where
+ add_poly_bind env (NonRec poly_id rhs)
+ = completeBind env top_lvl poly_id poly_id rhs
+ -- completeBind adds the new binding in the
+ -- proper way (ie complete with unfolding etc),
+ -- and extends the in-scope set
+ add_poly_bind env bind@(Rec _)
+ = return (extendFloats env bind)
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified,
simplNonRecX env bndr new_rhs
= do { (env', bndr') <- simplBinder env bndr
- ; completeNonRecX env' NotTopLevel NonRecursive
- (isStrictId bndr) bndr bndr' new_rhs }
+ ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs }
completeNonRecX :: SimplEnv
- -> TopLevelFlag -> RecFlag -> Bool
+ -> Bool
-> InId -- Old binder
-> OutId -- New binder
-> OutExpr -- Simplified RHS
-> SimplM SimplEnv
-completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
+completeNonRecX env is_strict old_bndr new_bndr new_rhs
= do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
; (env2, rhs2) <-
- if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
+ if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
then do { tick LetFloatFromLet
; return (addFloats env env1, rhs1) } -- Add the floats to the main env
else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
= return (env, expr)
| otherwise -- See Note [Take care] below
= do { var <- newId FSLIT("a") (exprType expr)
- ; env' <- completeNonRecX env NotTopLevel NonRecursive
- False var var expr
+ ; env' <- completeNonRecX env False var var expr
; return (env', substExpr env' (Var var)) }
\end{code}
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
`setWorkerInfo` worker_info
- final_info | loop_breaker = new_bndr_info
+ final_info | omit_unfolding = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
final_id `seq`
-- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
return (addNonRec env final_id new_rhs)
+ -- The addNonRec adds it to the in-scope set too
where
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- worker_info = substWorker env (workerInfo old_info)
- loop_breaker = isNonRuleLoopBreaker occ_info
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ worker_info = substWorker env (workerInfo old_info)
+ omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
\end{code}
\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
- where
- expr_ty' = substTy env (exprType expr)
- -- The type in the Stop continuation, expr_ty', is usually not used
- -- It's only needed when discarding continuations after finding
- -- a function that returns bottom.
- -- Hence the lazy substitution
-
+simplExpr env expr = simplExprC env expr mkBoringStop
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
-- Simplify an expression, given a continuation
do { ty' <- simplType env ty
; rebuild env (Type ty') cont }
-simplExprF' env (Case scrut bndr case_ty alts) cont
+simplExprF' env (Case scrut bndr _ alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
do { case_expr' <- simplExprC env scrut case_cont
; rebuild env case_expr' cont }
where
- case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
- case_ty' = substTy env case_ty -- c.f. defn of simplExpr
+ case_cont = Select NoDup bndr alts env mkBoringStop
simplExprF' env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
- StrictArg fun ty _ info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont
+ StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
, not (isCoVar tyvar)
= ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
where
- ty' = substTy arg_se arg_ty
+ ty' = substTy (arg_se `setInScope` env) arg_ty
-- ToDo: the PushC rule is not implemented at all
-- (->) t1 t2 :=: (->) s1 s2
[co1, co2] = decomposeCo 2 co
new_arg = mkCoerce (mkSymCoercion co1) arg'
- arg' = substExpr arg_se arg
+ arg' = substExpr (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
\end{code}
simplNonRecE :: SimplEnv
-> InId -- The binder
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
- -> ([InId], InExpr) -- Body of the let/lambda
+ -> ([InBndr], InExpr) -- Body of the let/lambda
-- \xs.e
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- Why? Because of the binder-occ-info-zapping done before
-- the call to simplLam in simplExprF (Lam ...)
+ -- First deal with type lets: let a = Type ty in b
+simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
+ = do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
+ ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
+
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
| preInlineUnconditionally env NotTopLevel bndr rhs
= do { tick (PreInlineUnconditionally bndr)
------------- No inlining! ----------------
-- Next, look for rules or specialisations that match
--
- rebuildCall env (Var var) (idType var)
+ rebuildCall env (Var var)
(mkArgInfo var n_val_args call_cont) cont
}}}}
rebuildCall :: SimplEnv
- -> OutExpr -> OutType -- Function and its type
+ -> OutExpr -- Function
-> ArgInfo
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont
+rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see SimplUtils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
| not (contIsTrivial cont) -- Only do this if there is a non-trivial
= return (env, mk_coerce fun) -- contination to discard, else we do it
where -- again and again!
- cont_ty = contResultType cont
+ fun_ty = exprType fun
+ cont_ty = contResultType env fun_ty cont
co = mkUnsafeCoercion fun_ty cont_ty
mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
| otherwise = mkCoerce co expr
-rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont)
+rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
= do { ty' <- simplType (se `setInScope` env) arg_ty
- ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont }
+ ; rebuildCall env (fun `App` Type ty') info cont }
-rebuildCall env fun fun_ty
+rebuildCall env fun
(ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyTo _ arg arg_se cont)
- | str || isStrictType arg_ty -- Strict argument
+ | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
- (StrictArg fun fun_ty cci arg_info' cont)
+ (StrictArg fun cci arg_info' cont)
-- Note [Shadowing]
| otherwise -- Lazy argument
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg
- (mkLazyArgStop arg_ty cci)
- ; rebuildCall env (fun `App` arg') res_ty arg_info' cont }
+ (mkLazyArgStop cci)
+ ; rebuildCall env (fun `App` arg') arg_info' cont }
where
- (arg_ty, res_ty) = splitFunTy fun_ty
arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
| otherwise = BoringCtxt -- Nothing interesting
-rebuildCall env fun _ _ cont
+rebuildCall env fun _ cont
= rebuild env fun cont
\end{code}
-- Simplify the alternatives
; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
- ; let res_ty' = contResultType dup_cont
- ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
- -- Notice that rebuildDone returns the in-scope set from env', not alt_env
- -- The case binder *not* scope over the whole returned case-expression
- ; rebuild env' case_expr nodup_cont }
+ -- Check for empty alternatives
+ ; if null alts' then
+ -- This isn't strictly an error, although it is unusual.
+ -- It's possible that the simplifer might "see" that
+ -- an inner case has no accessible alternatives before
+ -- it "sees" that the entire branch of an outer case is
+ -- inaccessible. So we simply put an error case here instead.
+ pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
+ let res_ty' = contResultType env' (substTy env' (coreAltsType alts)) dup_cont
+ lit = Lit (mkStringLit "Impossible alternative")
+ in return (env', mkApps (Var rUNTIME_ERROR_ID) [Type res_ty', lit])
+
+ else do
+ { case_expr <- mkCase scrut' case_bndr' alts'
+
+ -- Notice that rebuild gets the in-scope set from env, not alt_env
+ -- The case binder *not* scope over the whole returned case-expression
+ ; rebuild env' case_expr nodup_cont } }
\end{code}
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
simplAlts :: SimplEnv
-> OutExpr
-> InId -- Case binder
- -> [InAlt] -> SimplCont
+ -> [InAlt] -- Non-empty
+ -> SimplCont
-> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it not return an environment
All this should happen in one sweep.
\begin{code}
-knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
+knownCon :: SimplEnv -> OutExpr -> AltCon
+ -> [OutExpr] -- Args *including* the universal args
-> InId -> [InAlt] -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- continunation)
-- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [_] cont = return (env, cont, mkBoringStop (contResultType cont))
+prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
prepareCaseCont env _ cont = mkDupableCont env cont
\end{code}
mkDupableCont env cont
| contIsDupable cont
- = return (env, cont, mkBoringStop (contResultType cont))
+ = return (env, cont, mkBoringStop)
mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
= do { (env', dup, nodup) <- mkDupableCont env cont
; return (env', CoerceIt ty dup, nodup) }
-mkDupableCont env cont@(StrictBind bndr _ _ se _)
- = return (env, mkBoringStop (substTy se (idType bndr)), cont)
+mkDupableCont env cont@(StrictBind {})
+ = return (env, mkBoringStop, cont)
-- See Note [Duplicating strict continuations]
-mkDupableCont env cont@(StrictArg _ fun_ty _ _ _)
- = return (env, mkBoringStop (funArgTy fun_ty), cont)
+mkDupableCont env cont@(StrictArg {})
+ = return (env, mkBoringStop, cont)
-- See Note [Duplicating strict continuations]
mkDupableCont env (ApplyTo _ arg se cont)
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
; return (env'', app_cont, nodup_cont) }
-mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] se _case_cont)
+mkDupableCont env cont@(Select _ _ [(_, bs, _rhs)] _ _)
-- See Note [Single-alternative case]
-- | not (exprIsDupable rhs && contIsDupable case_cont)
-- | not (isDeadBinder case_bndr)
| all isDeadBinder bs -- InIds
- = return (env, mkBoringStop scrut_ty, cont)
- where
- scrut_ty = substTy se (idType case_bndr)
+ = return (env, mkBoringStop, cont)
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
; return (env'', -- Note [Duplicated env]
- Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
- (mkBoringStop (contResultType dup_cont)),
+ Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
nodup_cont) }
projects / ghc-hetmet.git / commitdiff