Commit 29645274 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor simplExpr (Type ty)

This small refactoring, provoked by comment:18 on Trac #13426,
makes it so that simplExprF never gets a (Type ty) expression to
simplify, which in turn means that calls to exprType on its argument
will always succeed.

No change in behaviour.
parent 03c7dd09
......@@ -355,10 +355,12 @@ simplBind :: SimplEnv
-> TopLevelFlag -> RecFlag -> Maybe SimplCont
-> InId -> OutId -- Binder, both pre-and post simpl
-- The OutId has IdInfo, except arity, unfolding
-- Ids only, no TyVars
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM SimplEnv
simplBind env top_lvl is_rec mb_cont bndr bndr1 rhs rhs_se
| isJoinId bndr1
| ASSERT( isId bndr1 )
isJoinId bndr1
= ASSERT(isNotTopLevel top_lvl && isJust mb_cont)
simplJoinBind env is_rec (fromJust mb_cont) bndr bndr1 rhs rhs_se
| otherwise
......@@ -368,12 +370,14 @@ simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId -- Binder, both pre-and post simpl
-- The OutId has IdInfo, except arity, unfolding
-- Ids only, no TyVars
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM SimplEnv
-- Precondition: rhs obeys the let/app invariant
-- NOT used for JoinIds
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= ASSERT2( not (isJoinId bndr), ppr bndr )
= ASSERT( isId bndr )
ASSERT2( not (isJoinId bndr), ppr bndr )
-- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
do { let rhs_env = rhs_se `setInScopeAndZapFloats` env
(tvs, body) = case collectTyAndValBinders rhs of
......@@ -969,12 +973,22 @@ might do the same again.
-}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
simplExpr env (Type ty)
= do { ty' <- simplType env ty
; return (Type ty') }
simplExpr env expr
= simplExprC env expr (mkBoringStop expr_out_ty)
where
expr_out_ty :: OutType
expr_out_ty = substTy env (exprType expr)
-- NB: Since 'expr' is term-valued, not (Type ty), this call
-- to exprType will succeed. exprType fails on (Type ty).
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
simplExprC :: SimplEnv
-> InExpr -- A term-valued expression, never (Type ty)
-> SimplCont
-> SimplM OutExpr
-- Simplify an expression, given a continuation
simplExprC env expr cont
= -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
......@@ -985,7 +999,9 @@ simplExprC env expr cont
return (wrapFloats env' expr') }
--------------------------------------------------
simplExprF :: SimplEnv -> InExpr -> SimplCont
simplExprF :: SimplEnv
-> InExpr -- A term-valued expression, never (Type ty)
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
simplExprF env e cont
......@@ -1002,13 +1018,19 @@ simplExprF env e cont
simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
simplExprF1 _ (Type ty) _
= pprPanic "simplExprF: type" (ppr ty)
-- simplExprF does only with term-valued expressions
-- The (Type ty) case is handled separately by simplExpr
-- and by the other callers of simplExprF
simplExprF1 env (Var v) cont = simplIdF env v cont
simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF1 env (Tick t expr) cont = simplTick env t expr cont
simplExprF1 env (Cast body co) cont = simplCast env body co cont
simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
rebuild env (Type (substTy env ty)) cont
simplExprF1 env (App fun arg) cont
= simplExprF env fun $
......@@ -1050,6 +1072,12 @@ simplExprF1 env (Let (Rec pairs) body) cont
= simplRecE env pairs body cont
simplExprF1 env (Let (NonRec bndr rhs) body) cont
| Type ty <- rhs -- First deal with type lets (let a = Type ty in e)
= ASSERT( isTyVar bndr )
do { ty' <- simplType env ty
; simplExprF (extendTvSubst env bndr ty') body cont }
| otherwise
= simplNonRecE env bndr (rhs, env) ([], body) cont
---------------------------------
......@@ -1423,7 +1451,7 @@ simplLamBndr env bndr
------------------
simplNonRecE :: SimplEnv
-> InBndr -- The binder
-> InId -- The binder, always an Id for simplNonRecE
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
-> ([InBndr], InExpr) -- Body of the let/lambda
-- \xs.e
......@@ -1445,15 +1473,9 @@ simplNonRecE :: SimplEnv
-- Why? Because of the binder-occ-info-zapping done before
-- the call to simplLam in simplExprF (Lam ...)
-- First deal with type applications and type lets
-- (/\a. e) (Type ty) and (let a = Type ty in e)
simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
= ASSERT( isTyVar bndr )
do { ty_arg' <- simplType (rhs_se `setInScopeAndZapFloats` env) ty_arg
; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
= do dflags <- getDynFlags
= ASSERT( isId bndr )
do dflags <- getDynFlags
case () of
_ | preInlineUnconditionally dflags env NotTopLevel bndr rhs
-> do { tick (PreInlineUnconditionally bndr)
......
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