X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=eba27281574791f5ffd9ce6a2d899047bf84b2ab;hb=5a336f14d30f9b46ac74ca319ed1af25430cd67a;hp=aaeec2e17c1b762345578f2aa7c2f1b9b0ba462c;hpb=934a7ed0191f6410c3b0e8dfcde6155a934e2ebe;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index aaeec2e..eba2728 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -4,13 +4,6 @@ \section[Simplify]{The main module of the simplifier} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" @@ -20,6 +13,8 @@ import SimplMonad import Type hiding ( substTy, extendTvSubst ) import SimplEnv import SimplUtils +import MkId ( rUNTIME_ERROR_ID ) +import FamInstEnv ( FamInstEnv ) import Id import Var import IdInfo @@ -27,11 +22,11 @@ import Coercion import FamInstEnv ( topNormaliseType ) import DataCon ( dataConRepStrictness, dataConUnivTyVars ) import CoreSyn -import NewDemand ( isStrictDmd ) +import NewDemand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) import CoreUtils -import Rules ( lookupRule ) +import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) import TysPrim ( realWorldStatePrimTy ) @@ -41,7 +36,7 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable -import Util +import FastString \end{code} @@ -207,18 +202,18 @@ expansion at a let RHS can concentrate solely on the PAP case. \begin{code} simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] -simplTopBinds env binds +simplTopBinds env0 binds0 = do { -- Put all the top-level binders into scope at the start -- 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. - ; env <- simplRecBndrs env (bindersOfBinds binds) + ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) ; dflags <- getDOptsSmpl ; let dump_flag = dopt Opt_D_dump_inlinings dflags || dopt Opt_D_dump_rule_firings dflags - ; env' <- simpl_binds dump_flag env binds + ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone - ; return (getFloats env') } + ; return (getFloats env2) } where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) @@ -227,13 +222,13 @@ simplTopBinds env binds -- The dump-flag emits a trace for each top-level binding, which -- helps to locate the tracing for inlining and rule firing simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv - simpl_binds dump env [] = return env - simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $ + simpl_binds _ env [] = return env + simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $ simpl_bind env bind ; simpl_binds dump env' binds } - trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) - trace False bind = \x -> x + trace_bind True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) + trace_bind False _ = \x -> x simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r @@ -255,12 +250,12 @@ simplRecBind is used for simplRecBind :: SimplEnv -> TopLevelFlag -> [(InId, InExpr)] -> SimplM SimplEnv -simplRecBind env top_lvl pairs - = do { let (env_with_info, triples) = mapAccumL add_rules env pairs - ; env' <- go (zapFloats env_with_info) triples - ; return (env `addRecFloats` env') } - -- addFloats adds the floats from env', - -- *and* updates env with the in-scope set from env' +simplRecBind env0 top_lvl pairs0 + = do { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0 + ; env1 <- go (zapFloats env_with_info) triples + ; return (env0 `addRecFloats` env1) } + -- addFloats adds the floats from env1, + -- _and_ updates env0 with the in-scope set from env1 where add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) -- Add the (substituted) rules to the binder @@ -271,8 +266,8 @@ simplRecBind env top_lvl pairs go env [] = return env go env ((old_bndr, new_bndr, rhs) : pairs) - = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs - ; go env pairs } + = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + ; go env' pairs } \end{code} simplOrTopPair is used for @@ -322,15 +317,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 @@ -349,7 +350,8 @@ 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') } + ; let env' = foldl (addPolyBind top_lvl) env poly_binds + ; return (env', rhs') } ; completeBind env' top_lvl bndr bndr1 rhs' } \end{code} @@ -364,21 +366,23 @@ simplNonRecX :: SimplEnv -> SimplM SimplEnv simplNonRecX env bndr new_rhs - = do { (env, bndr') <- simplBinder env bndr - ; completeNonRecX env NotTopLevel NonRecursive - (isStrictId bndr) bndr bndr' new_rhs } + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } + = return env -- Here b is dead, and we avoid creating + | otherwise -- the binding b = (a,b) + = do { (env', bndr') <- simplBinder env bndr + ; 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 @@ -430,14 +434,14 @@ That's what the 'go' loop in prepareRhs does prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS prepareRhs env (Cast rhs co) -- Note [Float coercions] - | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] = do { (env', rhs') <- makeTrivial env rhs ; return (env', Cast rhs' co) } -prepareRhs env rhs - = do { (is_val, env', rhs') <- go 0 env rhs - ; return (env', rhs') } +prepareRhs env0 rhs0 + = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 + ; return (env1, rhs1) } where go n_val_args env (Cast rhs co) = do { (is_val, env', rhs') <- go n_val_args env rhs @@ -457,7 +461,7 @@ prepareRhs env rhs is_val = n_val_args > 0 -- There is at least one arg -- ...and the fun a constructor or PAP && (isDataConWorkId fun || n_val_args < idArity fun) - go n_val_args env other + go _ env other = return (False, env, other) \end{code} @@ -508,10 +512,20 @@ makeTrivial env expr | exprIsTrivial 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 - ; return (env, substExpr env (Var var)) } + = do { var <- newId (fsLit "a") (exprType expr) + ; env' <- completeNonRecX env False var var expr +-- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var))) +-- , ppr expr +-- , ppr (substExpr env' (Var var)) +-- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $ + ; return (env', substExpr env' (Var var)) } + -- The substitution is needed becase we're constructing a new binding + -- a = rhs + -- And if rhs is of form (rhs1 |> co), then we might get + -- a1 = rhs1 + -- a = a1 |> co + -- and now a's RHS is trivial and can be substituted out, and that + -- is what completeNonRecX will do \end{code} @@ -559,10 +573,67 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding - | otherwise - = let + | otherwise + = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr) + where + unfolding | omit_unfolding = NoUnfolding + | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs + old_info = idInfo old_bndr + occ_info = occInfo old_info + wkr = substWorker env (workerInfo old_info) + omit_unfolding = isNonRuleLoopBreaker occ_info + -- or not (activeInline env old_bndr) + -- Do *not* trim the unfolding in SimplGently, else + -- the specialiser can't see it! + +----------------- +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv +-- Add a new binding to the environment, complete with its unfolding +-- but *do not* do postInlineUnconditionally, because we have already +-- processed some of the scope of the binding +-- We still want the unfolding though. Consider +-- let +-- x = /\a. let y = ... in Just y +-- in body +-- Then we float the y-binding out (via abstractFloats and addPolyBind) +-- but 'x' may well then be inlined in 'body' in which case we'd like the +-- opportunity to inline 'y' too. + +addPolyBind top_lvl env (NonRec poly_id rhs) + = addNonRecWithUnf env poly_id rhs unfolding NoWorker + where + unfolding | not (activeInline env poly_id) = NoUnfolding + | otherwise = mkUnfolding (isTopLevel top_lvl) rhs + -- addNonRecWithInfo adds the new binding in the + -- proper way (ie complete with unfolding etc), + -- and extends the in-scope set + +addPolyBind _ env bind@(Rec _) = 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 + +----------------- +addNonRecWithUnf :: SimplEnv + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -> WorkerInfo -- and unfolding + -> SimplEnv +-- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set +addNonRecWithUnf env new_bndr rhs unfolding wkr + = ASSERT( isId new_bndr ) + WARN( new_arity < old_arity || new_arity < dmd_arity, + (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs ) + final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + addNonRec env final_id rhs + -- The addNonRec adds it to the in-scope set too + where + dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr + old_arity = idArity new_bndr + -- Arity info - new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + new_arity = exprArity rhs + new_bndr_info = idInfo new_bndr `setArityInfo` new_arity -- Unfolding info -- Add the unfolding *only* for non-loop-breakers @@ -586,25 +657,12 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - `setWorkerInfo` worker_info + `setWorkerInfo` wkr - final_info | loop_breaker = new_bndr_info - | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf + final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf | otherwise = info_w_unf - + final_id = new_bndr `setIdInfo` final_info - in - -- These seqs forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - final_id `seq` - -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ - return (addNonRec env final_id new_rhs) - 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 \end{code} @@ -655,14 +713,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 @@ -682,6 +733,8 @@ simplExprF env e cont = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ simplExprF' env e cont +simplExprF' :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) simplExprF' env (Var v) cont = simplVar env v cont simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont simplExprF' env (Note n expr) cont = simplNote env n expr cont @@ -712,7 +765,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) @@ -723,16 +776,15 @@ 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) + = do { env' <- simplRecBndrs env (map fst pairs) -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; env <- simplRecBind env NotTopLevel pairs - ; simplExprF env body cont } + ; env'' <- simplRecBind env' NotTopLevel pairs + ; simplExprF env'' body cont } simplExprF' env (Let (NonRec bndr rhs) body) cont = simplNonRecE env bndr (rhs, env) ([], body) cont @@ -758,13 +810,13 @@ simplType env ty rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -- At this point the substitution in the SimplEnv should be irrelevant -- only the in-scope set and floats should matter -rebuild env expr cont - = -- pprTrace "rebuild" (ppr expr $$ ppr cont $$ ppr (seFloats env)) $ - case cont of +rebuild env expr cont0 + = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $ + case cont0 of 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 @@ -781,21 +833,21 @@ rebuild env expr cont \begin{code} simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplCast env body co cont - = do { co' <- simplType env co - ; simplExprF env body (addCoerce co' cont) } +simplCast env body co0 cont0 + = do { co1 <- simplType env co0 + ; simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont - add_coerce co (s1, k1) cont -- co :: ty~ty + add_coerce _co (s1, k1) cont -- co :: ty~ty | s1 `coreEqType` k1 = cont -- is a no-op - add_coerce co1 (s1, k2) (CoerceIt co2 cont) - | (l1, t1) <- coercionKind co2 - -- coerce T1 S1 (coerce S1 K1 e) + add_coerce co1 (s1, _k2) (CoerceIt co2 cont) + | (_l1, t1) <- coercionKind co2 + -- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- ==> - -- e, if T1=K1 - -- coerce T1 K1 e, otherwise + -- e, if T1=T2 + -- e |> (g1 . g2 :: T1~T2) otherwise -- -- For example, in the initial form of a worker -- we may find (coerce T (coerce S (\x.e))) y @@ -804,26 +856,26 @@ simplCast env body co cont , s1 `coreEqType` t1 = cont -- The coerces cancel out | otherwise = CoerceIt (mkTransCoercion co1 co2) cont - add_coerce co (s1s2, t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) - -- (f `cast` g) ty ---> (f ty) `cast` (g @ ty) + add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) + -- (f |> g) ty ---> (f ty) |> (g @ ty) -- This implements the PushT rule from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 , 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 - add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont) + add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) | not (isTypeArg arg) -- This implements the Push rule from the paper , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied - -- co : s1s2 :=: t1t2 - -- (coerce (T1->T2) (S1->S2) F) E + -- (e |> (g :: s1s2 ~ t1->t2)) f -- ===> - -- coerce T2 S2 (F (coerce S1 T1 E)) + -- (e (f |> (arg g :: t1~s1)) + -- |> (res g :: s2->t2) -- - -- t1t2 must be a function type, T1->T2, because it's applied + -- t1t2 must be a function type, t1->t2, because it's applied -- to something but s1s2 might conceivably not be -- -- When we build the ApplyTo we can't mix the out-types @@ -834,12 +886,12 @@ simplCast env body co cont -- Example of use: Trac #995 = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont) where - -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and - -- t2 :=: s2 with left and right on the curried form: - -- (->) t1 t2 :=: (->) s1 s2 + -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and + -- t2 ~ s2 with left and right on the curried form: + -- (->) 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} @@ -857,30 +909,23 @@ simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont simplLam env [] body cont = simplExprF env body cont - -- Type-beta reduction -simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont) - = ASSERT( isTyVar bndr ) - do { tick (BetaReduction bndr) - ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg - ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } - - -- Ordinary beta reduction + -- Beta reduction simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) = do { tick (BetaReduction bndr) ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } -- Not enough args, so there are real lambdas left to put in the result simplLam env bndrs body cont - = do { (env, bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env body + = do { (env', bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env' body ; new_lam <- mkLam bndrs' body' - ; rebuild env new_lam cont } + ; rebuild env' new_lam 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) @@ -897,6 +942,13 @@ 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 `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) @@ -907,7 +959,8 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = do { (env1, bndr1) <- simplNonRecBndr env bndr + = ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se ; simplLam env3 bndrs body cont } @@ -923,6 +976,8 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont \begin{code} -- Hack alert: we only distinguish subsumed cost centre stacks for the -- purposes of inlining. All other CCCSs are mapped to currentCCS. +simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) simplNote env (SCC cc) e cont = do { e' <- simplExpr (setEnclosingCC env currentCCS) e ; rebuild env (mkSCC cc e') cont } @@ -952,6 +1007,7 @@ simplNote env (CoreNote s) e cont = do %************************************************************************ \begin{code} +simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) simplVar env var cont = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont @@ -970,6 +1026,7 @@ simplVar env var cont --------------------------------------------------------- -- Dealing with a call site +completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { dflags <- getDOptsSmpl ; let (args,call_cont) = contArgs cont @@ -1002,12 +1059,13 @@ completeCall env var cont -- is recursive, and hence a loop breaker: -- foldr k z (build g) = g k z -- So it's up to the programmer: rules can cause divergence - ; rules <- getRules + ; rule_base <- getSimplRules ; let in_scope = getInScope env + rules = getRules rule_base var maybe_rule = case activeRule dflags env of Nothing -> Nothing -- No rules apply Just act_fn -> lookupRule act_fn in_scope - rules var args + var args rules ; case maybe_rule of { Just (rule, rule_rhs) -> do tick (RuleFired (ru_name rule)) @@ -1048,16 +1106,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. @@ -1071,22 +1129,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 = fun - | otherwise = mkCoerce co fun + 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 @@ -1095,15 +1154,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 fun_ty info cont +rebuildCall env fun _ cont = rebuild env fun cont \end{code} @@ -1137,7 +1195,91 @@ all this at once is TOO HARD! %* * %************************************************************************ -Blob of helper functions for the "case-of-something-else" situation. +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in SimplUtils.prepareAlts has the effect of generalise this +idea to look for a case where we're scrutinising a variable, and we +know that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +We also make sure that we deal with this very common case: + + case e of + x -> ...x... + +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + - e is already evaluated (it may so if e is a variable) + - x is used strictly, or + +Lastly, the code in SimplUtils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be elminated by the CaseElim transformation. + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: State# RealWorld -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. \begin{code} --------------------------------------------------------- @@ -1169,9 +1311,9 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont +rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether - -- See the extensive notes on case-elimination above + -- See Note [Case eliminiation] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] @@ -1198,8 +1340,8 @@ rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont -- other problems -- Also we don't want to discard 'seq's = do { tick (CaseElim case_bndr) - ; env <- simplNonRecX env case_bndr scrut - ; simplExprF env rhs cont } + ; env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } where -- The case binder is going to be evaluated later, -- and the scrutinee is a simple variable @@ -1207,7 +1349,7 @@ rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont && not (isTickBoxOp v) -- ugly hack; covering this case is what -- exprOkForSpeculation was intended for. - var_demanded_later other = False + var_demanded_later _ = False -------------------------------------------------- @@ -1217,16 +1359,29 @@ rebuildCase env scrut case_bndr [(con,bndrs,rhs)] cont rebuildCase env scrut case_bndr alts cont = do { -- Prepare the continuation; -- The new subst_env is in place - (env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont + (env', dup_cont, nodup_cont) <- prepareCaseCont env 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 } + ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_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 = 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, @@ -1234,75 +1389,15 @@ try to eliminate uses of v in the RHSs in favour of case_bndr; that way, there's a chance that v will now only be used once, and hence inlined. -Note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~ -There is a time we *don't* want to do that, namely when --fno-case-of-case is on. This happens in the first simplifier pass, -and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) -If we eliminate the inner case, we trap it inside the I# v -> arm, -which might prevent some full laziness happening. I've seen this -in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] -Hence the check for NoCaseOfCase. - -Note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another situation when it might make sense to suppress the -case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - -We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - -But there is no point in doing it for the inner case, because w1 can't -be inlined anyway. Furthermore, doing the case-swapping involves -zapping w2's occurrence info (see paragraphs that follow), and that -forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - -This is plain silly in the common case where w2 is dead. - -Even so, I can't see a good way to implement this idea. I tried -not doing the binder-swap if the scrutinee was already evaluated -but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - -Notice that because MkT is strict, x is marked "evaluated". But to -eliminate the last case, we must either make sure that x (as well as -x1) has unfolding MkT y1. THe straightforward thing to do is to do -the binder-swap. So this whole note is a no-op. +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyer; see +OccurAnal Note [Binder swap]. Note [zapOccInfo] ~~~~~~~~~~~~~~~~~ -If we replace the scrutinee, v, by tbe case binder, then we have to nuke -any occurrence info (eg IAmDead) in the case binder, because the -case-binder now effectively occurs whenever v does. AND we have to do -the same for the pattern-bound variables! Example: - - (case x of { (a,b) -> a }) (case x of { (p,q) -> q }) - -Here, b and p are dead. But when we move the argment inside the first -case RHS, and eliminate the second case, we get - - case x of { (a,b) -> a b } - -Urk! b is alive! Reason: the scrutinee was a variable, and case elimination -happened. - -Indeed, this can happen anytime the case binder isn't dead: +If the case binder is not dead, then neither are the pattern bound +variables: case of x { (a,b) -> case x of { (p,q) -> p } } Here (a,b) both look dead, but come alive after the inner case is eliminated. @@ -1311,15 +1406,6 @@ The point is that we bring into the envt a binding after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (v `cast` co) of x { I# -> - ... (case (v `cast` co) of {...}) ... -We'd like to eliminate the inner case. We can get this neatly by -arranging that inside the outer case we add the unfolding - v |-> x `cast` (sym co) -to v. Then we should inline v at the inner case, cancel the casts, and away we go - Note [Improving seq] ~~~~~~~~~~~~~~~~~~~ Consider @@ -1350,125 +1436,82 @@ At one point I did transformation in LiberateCase, but it's more robust here. (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before LiberateCase gets to see it.) -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> e[x#/y#] - y# -> e -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in SimplUtils.prepareAlts has the effect of generalise this -idea to look for a case where we're scrutinising a variable, and we -know that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -We also make sure that we deal with this very common case: - - case e of - x -> ...x... - -Here we are using the case as a strict let; if x is used only once -then we want to inline it. We have to be careful that this doesn't -make the program terminate when it would have diverged before, so we -check that - - e is already evaluated (it may so if e is a variable) - - x is used strictly, or - -Lastly, the code in SimplUtils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be elminated by the CaseElim transformation. - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another situation when it might make sense to suppress the +case-expression binde-swap. If we have -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: State# RealWorld -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: +We'll perform the binder-swap for the outer case, giving -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } -At a particular call site we have (f v 1). So we inline to get +But there is no point in doing it for the inner case, because w1 can't +be inlined anyway. Furthermore, doing the case-swapping involves +zapping w2's occurrence info (see paragraphs that follow), and that +forces us to bind w2 when doing case merging. So we get - if v < 0 then jtos x - else if 1==0 then "" else jtos x + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } -Now simplify the 1==0 conditional: +This is plain silly in the common case where w2 is dead. - if v<0 then jtos v else jtos v +Even so, I can't see a good way to implement this idea. I tried +not doing the binder-swap if the scrutinee was already evaluated +but that failed big-time: -Now common-up the two branches of the case: + data T = MkT !Int - case (v<0) of DEFAULT -> jtos v + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. +Notice that because MkT is strict, x is marked "evaluated". But to +eliminate the last case, we must either make sure that x (as well as +x1) has unfolding MkT y1. THe straightforward thing to do is to do +the binder-swap. So this whole note is a no-op. \begin{code} -simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) -simplCaseBinder env scrut case_bndr alts - = do { (env1, case_bndr1) <- simplBinder env case_bndr - - ; fam_envs <- getFamEnvs - ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut - case_bndr case_bndr1 alts - -- Note [Improving seq] - - ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2 - -- Note [Case of cast] - - ; return (env3, scrut2, case_bndr3) } - where - - improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId FSLIT("nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) - env2 = extendIdSubst env1 case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - - improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts - = return (env1, scrut, case_bndr1) - - +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + +{- improve_case_bndr env scrut case_bndr - | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- See Note [no-case-of-case] - = (env, case_bndr) + -- See Note [no-case-of-case] + -- | switchIsOn (getSwitchChecker env) NoCaseOfCase + -- = (env, case_bndr) | otherwise -- Failed try; see Note [Suppressing the case binder-swap] -- not (isEvaldUnfolding (idUnfolding v)) @@ -1483,14 +1526,11 @@ simplCaseBinder env scrut case_bndr alts where rhs = Cast (Var case_bndr') (mkSymCoercion co) - other -> (env, case_bndr) + _ -> (env, case_bndr) where - case_bndr' = zapOccInfo case_bndr + case_bndr' = zapIdOccInfo case_bndr env1 = modifyInScope env case_bndr case_bndr' - - -zapOccInfo :: InId -> InId -- See Note [zapOccInfo] -zapOccInfo b = b `setIdOccInfo` NoOccInfo +-} \end{code} @@ -1538,19 +1578,25 @@ 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 simplAlts env scrut case_bndr alts cont' = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ - do { let alt_env = zapFloats env - ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts + do { let env0 = zapFloats env - ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts + ; (env1, case_bndr1) <- simplBinder env0 case_bndr - ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut + case_bndr case_bndr1 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts + + ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } ------------------------------------ @@ -1569,26 +1615,27 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) ; rhs' <- simplExprC env' rhs cont' ; return (DEFAULT, [], rhs') } -simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) do { let env' = addBinderUnfolding env case_bndr' (Lit lit) ; rhs' <- simplExprC env' rhs cont' ; return (LitAlt lit, [], rhs') } -simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) +simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) = do { -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. -- NB: simplLamBinders preserves this eval info - let vs_with_evals = add_evals vs (dataConRepStrictness con) - ; (env, vs') <- simplLamBndrs env vs_with_evals + let vs_with_evals = add_evals (dataConRepStrictness con) + ; (env', vs') <- simplLamBndrs env vs_with_evals -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') con_args = map Type inst_tys' ++ varsToCoreExprs vs' - env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) + env'' = addBinderUnfolding env' case_bndr' + (mkConApp con con_args) - ; rhs' <- simplExprC env' rhs cont' + ; rhs' <- simplExprC env'' rhs cont' ; return (DataAlt con, vs', rhs') } where -- add_evals records the evaluated-ness of the bound variables of @@ -1600,19 +1647,20 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. -- See Note [Data-con worker strictness] in MkId.lhs - add_evals vs strs - = go vs strs + add_evals the_strs + = go vs the_strs where go [] [] = [] - go (v:vs) strs | isTyVar v = v : go vs strs - go (v:vs) (str:strs) - | isMarkedStrict str = evald_v : go vs strs - | otherwise = zapped_v : go vs strs + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) + | isMarkedStrict str = evald_v : go vs' strs + | otherwise = zapped_v : go vs' strs where zapped_v = zap_occ_info v evald_v = zapped_v `setIdUnfolding` evaldUnfolding - go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs) + go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) + -- See Note [zapOccInfo] -- zap_occ_info: if the case binder is alive, then we add the unfolding -- case_bndr = C vs -- to the envt; so vs are now very much alive @@ -1620,16 +1668,23 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } -- ==> case e of t { (a,b) -> ...(a)... } -- Look, Ma, a is alive now. - zap_occ_info | isDeadBinder case_bndr' = \id -> id - | otherwise = zapOccInfo + zap_occ_info = zapCasePatIdOcc case_bndr' addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons - = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons) + = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) + +zapCasePatIdOcc :: Id -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapCasePatIdOcc case_bndr + | isDeadBinder case_bndr = \ pat_id -> pat_id + | otherwise = \ pat_id -> zapIdOccInfo pat_id \end{code} @@ -1653,7 +1708,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) @@ -1661,23 +1717,25 @@ knownCon env scrut con args bndr alts cont = do { tick (KnownBranch bndr) ; knownAlt env scrut args bndr (findAlt con alts) cont } -knownAlt env scrut args bndr (DEFAULT, bs, rhs) cont +knownAlt :: SimplEnv -> OutExpr -> [OutExpr] + -> InId -> (AltCon, [CoreBndr], InExpr) -> SimplCont + -> SimplM (SimplEnv, OutExpr) +knownAlt env scrut _ bndr (DEFAULT, bs, rhs) cont = ASSERT( null bs ) - do { env <- simplNonRecX env bndr scrut + do { env' <- simplNonRecX env bndr scrut -- This might give rise to a binding with non-atomic args -- like x = Node (f x) (g x) -- but simplNonRecX will atomic-ify it - ; simplExprF env rhs cont } + ; simplExprF env' rhs cont } -knownAlt env scrut args bndr (LitAlt lit, bs, rhs) cont +knownAlt env scrut _ bndr (LitAlt _, bs, rhs) cont = ASSERT( null bs ) - do { env <- simplNonRecX env bndr scrut - ; simplExprF env rhs cont } + do { env' <- simplNonRecX env bndr scrut + ; simplExprF env' rhs cont } -knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont - = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId - n_drop_tys = length (dataConUnivTyVars dc) - ; env <- bind_args env dead_bndr bs (drop n_drop_tys args) +knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont + = do { let n_drop_tys = length (dataConUnivTyVars dc) + ; env' <- bind_args env bs (drop n_drop_tys the_args) ; let -- It's useful to bind bndr to scrut, rather than to a fresh -- binding x = Con arg1 .. argn @@ -1687,35 +1745,37 @@ knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont -- about duplicating the arg redexes; in that case, make -- a new con-app from the args bndr_rhs = case scrut of - Var v -> scrut - other -> con_app - con_app = mkConApp dc (take n_drop_tys args ++ con_args) - con_args = [substExpr env (varToCoreExpr b) | b <- bs] + Var _ -> scrut + _ -> con_app + con_app = mkConApp dc (take n_drop_tys the_args ++ con_args) + con_args = [substExpr env' (varToCoreExpr b) | b <- bs] -- args are aready OutExprs, but bs are InIds - ; env <- simplNonRecX env bndr bndr_rhs - ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $ - simplExprF env rhs cont } + ; env'' <- simplNonRecX env' bndr bndr_rhs + ; simplExprF env'' rhs cont } where - -- Ugh! - bind_args env dead_bndr [] _ = return env + zap_occ = zapCasePatIdOcc bndr -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return env' - bind_args env dead_bndr (b:bs) (Type ty : args) + bind_args env' (b:bs') (Type ty : args) = ASSERT( isTyVar b ) - bind_args (extendTvSubst env b ty) dead_bndr bs args + bind_args (extendTvSubst env' b ty) bs' args - bind_args env dead_bndr (b:bs) (arg : args) + bind_args env' (b:bs') (arg : args) = ASSERT( isId b ) - do { let b' = if dead_bndr then b else zapOccInfo b - -- Note that the binder might be "dead", because it doesn't occur - -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally - -- Nevertheless we must keep it if the case-binder is alive, because it may - -- be used in the con_app. See Note [zapOccInfo] - ; env <- simplNonRecX env b' arg - ; bind_args env dead_bndr bs args } - - bind_args _ _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$ + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [zapOccInfo] + ; env'' <- simplNonRecX env' b' arg + ; bind_args env'' bs' args } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$ text "scrut:" <+> ppr scrut \end{code} @@ -1735,8 +1795,8 @@ prepareCaseCont :: SimplEnv -- continunation) -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [alt] cont = return (env, cont, mkBoringStop (contResultType cont)) -prepareCaseCont env alts cont = mkDupableCont env cont +prepareCaseCont env [_] cont = return (env, cont, mkBoringStop) +prepareCaseCont env _ cont = mkDupableCont env cont \end{code} \begin{code} @@ -1745,20 +1805,20 @@ mkDupableCont :: SimplEnv -> SimplCont mkDupableCont env cont | contIsDupable cont - = return (env, cont, mkBoringStop (contResultType cont)) + = return (env, cont, mkBoringStop) -mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn +mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableCont env (CoerceIt ty cont) - = do { (env, dup, nodup) <- mkDupableCont env cont - ; return (env, CoerceIt ty dup, nodup) } + = 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) @@ -1766,20 +1826,20 @@ mkDupableCont env (ApplyTo _ arg se cont) -- ==> -- let a = ...arg... -- in [...hole...] a - do { (env, dup_cont, nodup_cont) <- mkDupableCont env cont - ; arg <- simplExpr (se `setInScope` env) arg - ; (env, arg) <- makeTrivial env arg - ; let app_cont = ApplyTo OkToDup arg (zapSubstEnv env) dup_cont - ; return (env, app_cont, nodup_cont) } + do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont + ; arg' <- simplExpr (se `setInScope` env') arg + ; (env'', arg'') <- makeTrivial env' arg' + ; 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 _ case_bndr [(_, 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) + | all isDeadBinder bs -- InIds + && not (isUnLiftedType (idType case_bndr)) + -- Note [Single-alternative-unlifted] + = return (env, mkBoringStop, cont) mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) @@ -1787,14 +1847,14 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- let ji = \xij -> ei -- in case [...hole...] of { pi -> ji xij } do { tick (CaseOfCase case_bndr) - ; (env, dup_cont, nodup_cont) <- mkDupableCont env cont + ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont -- NB: call mkDupableCont here, *not* prepareCaseCont -- We must make a duplicable continuation, whereas prepareCaseCont -- doesn't when there is a single case branch - ; let alt_env = se `setInScope` env - ; (alt_env, case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env [] case_bndr' dup_cont) alts + ; let alt_env = se `setInScope` env' + ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr + ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness @@ -1807,10 +1867,9 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- NB: we don't use alt_env further; it has the substEnv for -- the alternatives, and we don't want that - ; (env, alts') <- mkDupableAlts env case_bndr' alts' - ; return (env, -- Note [Duplicated env] - Select OkToDup case_bndr' alts' (zapSubstEnv env) - (mkBoringStop (contResultType dup_cont)), + ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' + ; return (env'', -- Note [Duplicated env] + Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop, nodup_cont) } @@ -1818,15 +1877,17 @@ mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplM (SimplEnv, [InAlt]) -- Absorbs the continuation into the new alternatives -mkDupableAlts env case_bndr' alts - = go env alts +mkDupableAlts env case_bndr' the_alts + = go env the_alts where - go env [] = return (env, []) - go env (alt:alts) - = do { (env, alt') <- mkDupableAlt env case_bndr' alt - ; (env, alts') <- go env alts - ; return (env, alt' : alts' ) } - + go env0 [] = return (env0, []) + go env0 (alt:alts) + = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt + ; (env2, alts') <- go env1 alts + ; return (env2, alt' : alts' ) } + +mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) + -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) mkDupableAlt env case_bndr' (con, bndrs', rhs') | exprIsDupable rhs' -- Note [Small alternative rhs] = return (env, (con, bndrs', rhs')) @@ -1841,10 +1902,10 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') ; (final_bndrs', final_args) -- Note [Join point abstraction] <- if (any isId used_bndrs') then return (used_bndrs', varsToCoreExprs used_bndrs') - else do { rw_id <- newId FSLIT("w") realWorldStatePrimTy + else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy ; return ([rw_id], [Var realWorldPrimId]) } - ; join_bndr <- newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') + ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty') -- Note [Funky mkPiTypes] ; let -- We make the lambdas into one-shot-lambdas. The @@ -1857,7 +1918,7 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args - ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) } + ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) } -- See Note [Duplicated env] \end{code} @@ -2026,3 +2087,37 @@ Other choices: When x is inlined into its full context, we find that it was a bad idea to have pushed the outer case inside the (...) case. +Note [Single-alternative-unlifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's another single-alternative where we really want to do case-of-case: + +data Mk1 = Mk1 Int# +data Mk1 = Mk2 Int# + +M1.f = + \r [x_s74 y_s6X] + case + case y_s6X of tpl_s7m { + M1.Mk1 ipv_s70 -> ipv_s70; + M1.Mk2 ipv_s72 -> ipv_s72; + } + of + wild_s7c + { __DEFAULT -> + case + case x_s74 of tpl_s7n { + M1.Mk1 ipv_s77 -> ipv_s77; + M1.Mk2 ipv_s79 -> ipv_s79; + } + of + wild1_s7b + { __DEFAULT -> ==# [wild1_s7b wild_s7c]; + }; + }; + +So the outer case is doing *nothing at all*, other than serving as a +join-point. In this case we really want to do case-of-case and decide +whether to use a real join point or just duplicate the continuation. + +Hence: check whether the case binder's type is unlifted, because then +the outer case is *not* a seq.