X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=379fce155509bb9633067c023e9f82b7dafe7a0e;hb=a06cc26192b0df5726e7ae201e94379c734423fc;hp=1b4bfe4953765ffb4eb857417cd7ceff7e887e9e;hpb=18603f72fc20954b785a2bca81bed6c5571481f6;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1b4bfe4..379fce1 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -10,12 +10,13 @@ module Simplify ( simplTopBinds, simplExpr ) where import DynFlags import SimplMonad -import Type hiding ( substTy, extendTvSubst ) +import Type hiding ( substTy, extendTvSubst, substTyVar ) import SimplEnv import SimplUtils import FamInstEnv ( FamInstEnv ) import Id -import MkId ( mkImpossibleExpr, seqId ) +import MkId ( seqId, realWorldPrimId ) +import MkCore ( mkImpossibleExpr ) import Var import IdInfo import Name ( mkSystemVarName, isExternalName ) @@ -27,8 +28,9 @@ import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, - exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding + , mkInlineUnfolding, mkSimpleUnfolding + , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst import CoreArity ( exprArity ) @@ -36,7 +38,6 @@ import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) -import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) @@ -338,12 +339,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- Simplify the RHS ; (body_env1, body1) <- simplExprF body_env body mkRhsStop -- ANF-ise a constructor or PAP rhs - ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1 + ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) - then -- No floating, just wrap up! - do { rhs' <- mkLam env tvs' (wrapFloats body_env2 body2) + then -- No floating, revert to body1 + do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) ; return (env, rhs') } else if null tvs then -- Simple floating @@ -374,17 +375,18 @@ simplNonRecX env bndr new_rhs = 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 NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things -completeNonRecX :: SimplEnv +completeNonRecX :: TopLevelFlag -> SimplEnv -> Bool -> InId -- Old binder -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv -completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -435,19 +437,19 @@ Here we want to make e1,e2 trivial and get That's what the 'go' loop in prepareRhs does \begin{code} -prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) +prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS -prepareRhs env id (Cast rhs co) -- Note [Float coercions] +prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] | (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') <- makeTrivialWithInfo env sanitised_info rhs + = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } where sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info `setDemandInfo` demandInfo info info = idInfo id -prepareRhs env0 _ rhs0 +prepareRhs top_lvl env0 _ rhs0 = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where @@ -460,7 +462,7 @@ prepareRhs env0 _ rhs0 go n_val_args env (App fun arg) = do { (is_exp, env', fun') <- go (n_val_args+1) env fun ; case is_exp of - True -> do { (env'', arg') <- makeTrivial env' arg + True -> do { (env'', arg') <- makeTrivial top_lvl env' arg ; return (True, env'', App fun' arg') } False -> return (False, env, App fun arg) } go n_val_args env (Var fun) @@ -527,31 +529,68 @@ These strange casts can happen as a result of case-of-case \begin{code} -makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr +makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr -makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) +makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo + -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Propagate strictness and demand info to the new binder -- Note [Preserve strictness when floating coercions] -makeTrivialWithInfo env info expr - | exprIsTrivial expr +-- Returned SimplEnv has same substitution as incoming one +makeTrivialWithInfo top_lvl env info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] = return (env, expr) | otherwise -- See Note [Take care] below = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") - var = mkLocalIdWithInfo name (exprType expr) info - ; env' <- completeNonRecX env False var var expr - ; return (env', substExpr env' (Var var)) } - -- The substitution is needed becase we're constructing a new binding + var = mkLocalIdWithInfo name expr_ty info + ; env' <- completeNonRecX top_lvl env False var var expr + ; expr' <- simplVar env' var + ; return (env', expr') } + -- The simplVar 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 + -- To put it another way, it's as if we'd simplified + -- let var = e in var + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl _ expr_ty + | isTopLevel top_lvl = not (isUnLiftedType expr_ty) + | otherwise = True \end{code} +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tih + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +A case in point is literal strings (a MachStr is not regarded as +trivial): + + foo = Ptr "blob"# + +We don't want to ANF-ise this. %************************************************************************ %* * @@ -667,18 +706,17 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> OccInfo -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ _ (DFunUnfolding con ops) - = return (DFunUnfolding con ops') +simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) + = return (DFunUnfolding ar con ops') where - ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops + ops' = map (substExpr (text "simplUnfolding") env) ops simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src - = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $ - do { expr' <- simplExpr rule_env expr - ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src + | isStableSource src + = do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } -- See Note [Top-level flag on inline rules] in CoreUnfold where @@ -687,7 +725,7 @@ simplUnfolding env top_lvl id _ _ -- See Note [Simplifying gently inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In TidyPgm we currently assume that, if we want to @@ -820,7 +858,7 @@ simplExprF env e cont simplExprF' :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVar env v cont +simplExprF' env (Var v) cont = simplVarF env v cont simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont simplExprF' env (Note n expr) cont = simplNote env n expr cont simplExprF' env (Cast body co) cont = simplCast env body co cont @@ -840,7 +878,7 @@ simplExprF' env expr@(Lam _ _) cont n_params = length bndrs (bndrs, body) = collectBinders expr zap | n_args >= n_params = \b -> b - | otherwise = \b -> if isTyVar b then b + | otherwise = \b -> if isTyCoVar b then b else zapLamIdInfo b -- NB: we count all the args incl type args -- so we must count all the binders (incl type lambdas) @@ -990,7 +1028,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 `setInScope` env) arg + arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg add_coerce co _ cont = CoerceIt co cont \end{code} @@ -1044,7 +1082,7 @@ simplNonRecE :: SimplEnv -- 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 ) + = ASSERT( isTyCoVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } @@ -1058,7 +1096,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyVar bndr) ) + = ASSERT( not (isTyCoVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1092,13 +1130,24 @@ simplNote env (CoreNote s) e cont %************************************************************************ %* * -\subsection{Dealing with calls} + Variables %* * %************************************************************************ \begin{code} -simplVar :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVar env var cont +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyCoVar var + = return (Type (substTyVar env var)) + | otherwise + = case substId env var of + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + +simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplVarF env var cont = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont @@ -1120,24 +1169,23 @@ completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { ------------- Try inlining ---------------- dflags <- getDOptsSmpl - ; let (args,call_cont) = contArgs cont + ; let (lone_variable, arg_infos, call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined -- to limited depth (unless a rule fires). But we must do -- the substitution; rule matching on un-simplified args would -- be bogus - arg_infos = [interestingArg arg | arg <- args, isValArg arg] n_val_args = length arg_infos interesting_cont = interestingCallContext call_cont unfolding = activeUnfolding env var maybe_inline = callSiteInline dflags var unfolding - (null args) arg_infos interesting_cont + lone_variable arg_infos interesting_cont ; case maybe_inline of { - Just unfolding -- There is an inlining! + Just expr -- There is an inlining! -> do { tick (UnfoldingDone var) - ; trace_inline dflags unfolding args call_cont $ - simplExprF (zapSubstEnv env) unfolding cont } + ; trace_inline dflags expr cont $ + simplExprF (zapSubstEnv env) expr cont } ; Nothing -> do -- No inlining! @@ -1146,7 +1194,7 @@ completeCall env var cont ; rebuildCall env info cont }}} where - trace_inline dflags unfolding args call_cont stuff + trace_inline dflags unfolding cont stuff | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then @@ -1154,9 +1202,8 @@ completeCall env var cont else stuff | otherwise = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) - (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr call_cont]) + (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont]) stuff rebuildCall :: SimplEnv @@ -1457,7 +1504,7 @@ rebuildCase env scrut case_bndr alts cont rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether - -- See Note [Case eliminiation] + -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] @@ -1501,7 +1548,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' - = do { let rhs' = substExpr env rhs + = do { let rhs' = substExpr (text "rebuild-case") env rhs out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this @@ -1638,7 +1685,7 @@ simplAlts :: SimplEnv -- it does not return an environment simplAlts env scrut case_bndr alts cont' - = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ + = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ do { let env0 = zapFloats env ; (env1, case_bndr1) <- simplBinder env0 case_bndr @@ -1722,7 +1769,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') strs | isTyCoVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs @@ -1743,7 +1790,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -1787,23 +1834,8 @@ knownCon :: SimplEnv -> SimplM (SimplEnv, OutExpr) knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont - = do { env' <- bind_args env bs dc_args - ; let - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bndr_rhs | exprIsTrivial scrut = scrut - | otherwise = con_app - con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] - -- dc_ty_args are aready OutTypes, but bs are InBndrs - - ; env'' <- simplNonRecX env' bndr bndr_rhs + = do { env' <- bind_args env bs dc_args + ; env'' <- bind_case_bndr env' ; simplExprF env'' rhs cont } where zap_occ = zapCasePatIdOcc bndr -- bndr is an InId @@ -1812,7 +1844,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyVar b ) + = ASSERT( isTyCoVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -1830,6 +1862,24 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return env + | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are aready OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. @@ -1885,7 +1935,7 @@ mkDupableCont env cont@(StrictBind {}) mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', args') <- mapAccumLM makeTrivial env' (ai_args info) + ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) @@ -1895,7 +1945,7 @@ mkDupableCont env (ApplyTo _ arg se cont) -- in [...hole...] a do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont ; arg' <- simplExpr (se `setInScope` env') arg - ; (env'', arg'') <- makeTrivial env' arg' + ; (env'', arg'') <- makeTrivial NotTopLevel env' arg' ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont ; return (env'', app_cont, nodup_cont) } @@ -1967,7 +2017,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule needSaturated rhs 0 + unf = mkInlineUnfolding Nothing rhs rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -1981,7 +2031,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyVar bndr = True -- Abstract over all type variables just in case + | isTyCoVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders @@ -2033,12 +2083,22 @@ An alternative plan is this: but that is bad if 'c' is *not* later scrutinised. So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -that it's really I# c#, thus +(an InlineRule) that it's really I# c#, thus $j = \c# -> \c[=I# c#] -> ...c.... Absence analysis may later discard 'c'. +NB: take great care when doing strictness analysis; + see Note [Lamba-bound unfoldings] in DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~ @@ -2212,10 +2272,14 @@ strict computation enclosing the orginal call to MkT. Then, it won't "see" the MkT any more, because it's big and won't get duplicated. And, what is worse, nothing was gained by the case-of-case transform. -When should use this case of mkDupableCont? -However, matching on *any* single-alternative case is a *disaster*; +So, in circumstances like these, we don't want to build join points +and push the outer case into the branches of the inner one. Instead, +don't duplicate the continuation. + +When should we use this strategy? We should not use it on *every* +single-alternative case: e.g. case (case ....) of (a,b) -> (# a,b #) - We must push the outer case into the inner one! +Here we must push the outer case into the inner one! Other choices: * Match [(DEFAULT,_,_)], but in the common case of Int, @@ -2237,7 +2301,7 @@ Other choices: the *un-simplified* rhs, which is fine. It might get bigger or smaller after simplification; if it gets smaller, this case might fire next time round. NB also that we must test contIsDupable - case_cont *btoo, because case_cont might be big! + case_cont *too, because case_cont might be big! HOWEVER: I found that this version doesn't work well, because we can get let x = case (...) of { small } in ...case x...