From 53f99d8465ec50f7c37c65658fa346094bd37ded Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 22 Apr 2008 12:04:00 +0000 Subject: [PATCH] Simplify SimplCont, plus some other small changes to the Simplifier The main change in this patch is this: * The Stop constructor of SimplCont no longer contains the OutType of the whole continuation. This is a nice simplification in lots of places where we build a Stop continuation. For example, rebuildCall no longer needs to maintain the type of the function. * Similarly StrictArg no longer needs an OutType * The consequential complication is that contResultType (not called much) needs to be given the type of the thing in the middle. No big deal. * Lots of other small knock-on effects Other changes in here * simplLazyBind does do the type-abstraction thing if there's a lambda inside. See comments in simplLazyBind * simplLazyBind reduces simplifier iterations by keeping unfolding information for stuff for which type abstraction is done (see add_poly_bind) All of this came up when implementing System IF, but seems worth applying to the HEAD --- compiler/coreSyn/CoreUtils.lhs | 6 +- compiler/simplCore/SimplEnv.lhs | 10 +-- compiler/simplCore/SimplUtils.lhs | 118 +++++++++++++------------- compiler/simplCore/Simplify.lhs | 165 ++++++++++++++++++++++--------------- 4 files changed, 167 insertions(+), 132 deletions(-) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 2599f4a..e3dc239 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -23,7 +23,7 @@ module CoreUtils ( findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, -- Properties of expressions - exprType, coreAltType, + exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsHNF,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsBottom, @@ -109,6 +109,10 @@ exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy coreAltType :: CoreAlt -> Type coreAltType (_,_,rhs) = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 699ba7b..2c0cc09 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -391,15 +391,13 @@ addNonRec env id rhs = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -extendFloats :: SimplEnv -> [OutBind] -> SimplEnv +extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too -extendFloats env binds - = env { seFloats = seFloats env `addFlts` new_floats, +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, seInScope = extendInScopeSetList (seInScope env) bndrs } where - bndrs = bindersOfBinds binds - new_floats = Floats (toOL binds) - (foldr (andFF . classifyFF) FltLifted binds) + bndrs = bindersOf bind addFloats :: SimplEnv -> SimplEnv -> SimplEnv -- Add the floats for env2 to env1; diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index c33bc3d..984cdc4 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -23,7 +23,7 @@ module SimplUtils ( SimplCont(..), DupFlag(..), ArgInfo(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, countValArgs, countArgs, splitInlineCont, - mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg, + mkBoringStop, mkLazyArgStop, contIsRhsOrArg, interestingCallContext, interestingArgContext, interestingArg, mkArgInfo, @@ -50,6 +50,7 @@ import Var ( isCoVar ) import NewDemand import SimplMonad import Type hiding( substTy ) +import Coercion ( coercionKind ) import TyCon import DataCon import Unify ( dataConCannotMatch ) @@ -93,7 +94,6 @@ Key points: \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) @@ -122,7 +122,7 @@ data SimplCont 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 @@ -140,11 +140,11 @@ data ArgInfo } 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 @@ -158,14 +158,11 @@ instance Outputable DupFlag where ------------------- -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 @@ -189,13 +186,21 @@ contIsTrivial (CoerceIt _ cont) = contIsTrivial cont 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 @@ -231,13 +236,11 @@ splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) -- 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} @@ -326,9 +329,9 @@ interestingCallContext cont -- 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 @@ -359,7 +362,7 @@ mkArgInfo fun n_val_args call_cont , 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] @@ -387,12 +390,28 @@ mkArgInfo fun n_val_args call_cont 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) @@ -424,12 +443,12 @@ interestingArgContext :: Id -> SimplCont -> Bool 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 @@ -693,7 +712,7 @@ postInlineUnconditionally -> 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 @@ -932,10 +951,10 @@ There are some particularly delicate points here: 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 @@ -1031,7 +1050,7 @@ Consider this: 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 @@ -1440,29 +1459,14 @@ mkCase tries these things \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) @@ -1498,7 +1502,7 @@ mkCase scrut case_bndr ty alts -- Identity case -------------------------------------------------- -- 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} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 27d2c54..80fced5 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -13,6 +13,8 @@ import SimplMonad import Type hiding ( substTy, extendTvSubst ) import SimplEnv import SimplUtils +import Literal ( mkStringLit ) +import MkId ( rUNTIME_ERROR_ID ) import Id import Var import IdInfo @@ -34,6 +36,7 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable +import MonadUtils import FastString \end{code} @@ -315,15 +318,21 @@ simplLazyBind :: SimplEnv 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 @@ -342,9 +351,21 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se 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, @@ -358,20 +379,19 @@ simplNonRecX :: SimplEnv 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 @@ -502,8 +522,7 @@ makeTrivial env expr = 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} @@ -581,7 +600,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs 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 @@ -592,12 +611,13 @@ completeBind env top_lvl old_bndr new_bndr new_rhs 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} @@ -648,14 +668,7 @@ might do the same again. \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 @@ -707,7 +720,7 @@ simplExprF' env (Type ty) cont 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) @@ -718,8 +731,7 @@ simplExprF' env (Case scrut bndr case_ty alts) 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) @@ -759,7 +771,7 @@ rebuild env expr cont0 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 @@ -806,7 +818,7 @@ simplCast env body co0 cont0 , 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 @@ -834,7 +846,7 @@ simplCast env body co0 cont0 -- (->) 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} @@ -875,7 +887,7 @@ simplLam env bndrs body cont 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) @@ -892,6 +904,11 @@ simplNonRecE :: SimplEnv -- 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) @@ -1047,16 +1064,16 @@ completeCall env var cont ------------- 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. @@ -1070,22 +1087,23 @@ rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont | 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 @@ -1094,15 +1112,14 @@ rebuildCall env fun fun_ty -- 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} @@ -1220,12 +1237,25 @@ rebuildCase env scrut case_bndr alts cont -- 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, @@ -1537,7 +1567,8 @@ of the inner case y, which give us nowhere to go! 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 @@ -1653,7 +1684,8 @@ and then 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) @@ -1739,7 +1771,7 @@ prepareCaseCont :: SimplEnv -- 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} @@ -1749,7 +1781,7 @@ mkDupableCont :: SimplEnv -> SimplCont mkDupableCont env cont | contIsDupable cont - = return (env, cont, mkBoringStop (contResultType cont)) + = return (env, cont, mkBoringStop) mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn @@ -1757,12 +1789,12 @@ mkDupableCont env (CoerceIt ty cont) = 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) @@ -1776,14 +1808,12 @@ 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 }) @@ -1813,8 +1843,7 @@ mkDupableCont env (Select _ case_bndr alts se cont) ; (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) } -- 1.7.10.4