X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=7dc3cfced2228ed6d831de00bc4e8937edeb8fcf;hb=76fcd85d57595f9d864dea60f4d738ff59959326;hp=774fa5701972876b2a8c3db2ade57175c2106610;hpb=d8af6b8ce9d241a8f8d6878e2400aa8577f552bc;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 774fa57..7dc3cfc 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -12,7 +12,7 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, mkLam, newId, +import SimplUtils ( mkCase, mkLam, newId, prepareAlts, simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, SimplCont(..), DupFlag(..), LetRhsFlag(..), mkStop, mkBoringStop, pushContArgs, @@ -21,13 +21,14 @@ import SimplUtils ( mkCase, mkLam, newId, ) import Var ( mustHaveLocalBinding ) import VarEnv -import Id ( Id, idType, idInfo, idArity, isDataConId, - idUnfolding, setIdUnfolding, isDeadBinder, +import Id ( Id, idType, idInfo, idArity, isDataConWorkId, + setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) +import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, - setArityInfo, + setArityInfo, zapDemandInfo, setUnfoldingInfo, occInfo ) @@ -35,20 +36,20 @@ import NewDemand ( isStrictDmd ) import DataCon ( dataConNumInstArgs, dataConRepStrictness ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) +import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, - exprType, coreAltsType, exprIsValue, - exprOkForSpeculation, exprArity, findDefault, - mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg + exprType, exprIsValue, + exprOkForSpeculation, exprArity, + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) -import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs, funArgTy, - funResultTy, splitFunTy_maybe, splitFunTy, eqType +import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy, + splitFunTy_maybe, splitFunTy, eqType ) -import Subst ( mkSubst, substTy, substExpr, +import Subst ( mkSubst, substTy, substExpr, isInScope, lookupIdSubst, simplIdInfo ) import TysPrim ( realWorldStatePrimTy ) @@ -58,7 +59,9 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, ) import OrdList import Maybe ( Maybe ) +import Maybes ( orElse ) import Outputable +import Util ( notNull ) \end{code} @@ -246,8 +249,15 @@ simplTopBinds env binds drop_bs (NonRec _ _) (_ : bs) = bs drop_bs (Rec prs) bs = drop (length prs) bs - simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r - simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' + simpl_bind env bind bs + = getDOptsSmpl `thenSmpl` \ dflags -> + if dopt Opt_D_dump_inlinings dflags then + pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs + else + simpl_bind1 env bind bs + + simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r + simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' \end{code} @@ -294,16 +304,22 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr1) -> + simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> -- Now complete the binding and simplify the body - completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env2 = modifyInScope env1 bndr2 bndr2 + in + completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence in the substitution + -- fragile occurrence info in the substitution simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> @@ -321,6 +337,18 @@ simplNonRecX :: SimplEnv -> SimplM FloatsWithExpr simplNonRecX env bndr new_rhs thing_inside + | needsCaseBinding (idType bndr) new_rhs + -- Make this test *before* the preInlineUnconditionally + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + thing_inside env `thenSmpl` \ (floats, body) -> + returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)]) + | preInlineUnconditionally env NotTopLevel bndr -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } @@ -338,11 +366,6 @@ simplNonRecX env bndr new_rhs thing_inside bndr bndr' new_rhs thing_inside completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside - | needsCaseBinding (idType new_bndr) new_rhs - = thing_inside env `thenSmpl` \ (floats, body) -> - returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)]) - - | otherwise = mkAtomicArgs is_strict True {- OK to float unlifted -} new_rhs `thenSmpl` \ (aux_binds, rhs2) -> @@ -429,25 +452,43 @@ simplLazyBind :: SimplEnv -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM (FloatsWith SimplEnv) -simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se - = -- Substitute IdInfo on binder, in the light of earlier - -- substitutions in this very letrec, and extend the - -- in-scope env, so that the IdInfo for this binder extends - -- over the RHS for the binder itself. +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = let -- Transfer the IdInfo of the original binder to the new binder + -- This is crucial: we must preserve + -- strictness + -- rules + -- worker info + -- etc. To do this we must apply the current substitution, + -- which incorporates earlier substitutions in this very letrec group. -- + -- NB 1. We do this *before* processing the RHS of the binder, so that + -- its substituted rules are visible in its own RHS. -- This is important. Manuel found cases where he really, really -- wanted a RULE for a recursive function to apply in that function's - -- own right-hand side. + -- own right-hand side. -- - -- NB: does no harm for non-recursive bindings - let - is_top_level = isTopLevel top_lvl - bndr_ty' = idType bndr' - bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr' - env1 = modifyInScope env bndr'' bndr'' + -- NB 2: We do not transfer the arity (see Subst.substIdInfo) + -- The arity of an Id should not be visible + -- in its own RHS, else we eta-reduce + -- f = \x -> f x + -- to + -- f = f + -- which isn't sound. And it makes the arity in f's IdInfo greater than + -- the manifest arity, which isn't good. + -- The arity will get added later. + -- + -- NB 3: It's important that we *do* transer the loop-breaker OccInfo, + -- because that's what stops the Id getting inlined infinitely, in the body + -- of the letrec. + + -- NB 4: does no harm for non-recursive bindings + + bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr2 bndr2 rhs_env = setInScope rhs_se env1 + is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkStop bndr_ty' AnRhs + rhs_cont = mkStop (idType bndr1) AnRhs in -- Simplify the RHS; note the mkStop, which tells -- the simplifier that this is the RHS of a let. @@ -456,7 +497,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- If any of the floats can't be floated, give up now -- (The allLifted predicate says True for empty floats.) if (not ok_float_unlifted && not (allLifted floats)) then - completeLazyBind env1 top_lvl bndr bndr'' + completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) else @@ -467,38 +508,53 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- If the result is a PAP, float the floats out, else wrap them -- By this time it's already been ANF-ised (if necessary) if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case - completeLazyBind env1 top_lvl bndr bndr'' rhs2 + completeLazyBind env1 top_lvl bndr bndr2 rhs2 - -- We use exprIsTrivial here because we want to reveal lone variables. - -- E.g. let { x = letrec { y = E } in y } in ... - -- Here we definitely want to float the y=E defn. - -- exprIsValue definitely isn't right for that. - -- - -- BUT we can't use "exprIsCheap", because that causes a strictness bug. + else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- WARNING: long dodgy argument coming up + -- WANTED: a better way to do this + -- + -- We can't use "exprIsCheap" instead of exprIsValue, + -- because that causes a strictness bug. -- x = let y* = E in case (scc y) of { T -> F; F -> T} -- The case expression is 'cheap', but it's wrong to transform to -- y* = E; x = case (scc y) of {...} -- Either we must be careful not to float demanded non-values, or -- we must use exprIsValue for the test, which ensures that the - -- thing is non-strict. I think. The WARN below tests for this. - else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- thing is non-strict. So exprIsValue => bindings are non-strict + -- I think. The WARN below tests for this. + -- + -- We use exprIsTrivial here because we want to reveal lone variables. + -- E.g. let { x = letrec { y = E } in y } in ... + -- Here we definitely want to float the y=E defn. + -- exprIsValue definitely isn't right for that. + -- + -- Again, the floated binding can't be strict; if it's recursive it'll + -- be non-strict; if it's non-recursive it'd be inlined. + -- + -- Note [SCC-and-exprIsTrivial] + -- If we have + -- y = let { x* = E } in scc "foo" x + -- then we do *not* want to float out the x binding, because + -- it's strict! Fortunately, exprIsTrivial replies False to + -- (scc "foo" x). -- There's a subtlety here. There may be a binding (x* = e) in the -- floats, where the '*' means 'will be demanded'. So is it safe -- to float it out? Answer no, but it won't matter because - -- we only float if arg' is a WHNF, + -- we only float if (a) arg' is a WHNF, or (b) it's going to top level -- and so there can't be any 'will be demanded' bindings in the floats. - -- Hence the assert - WARN( any demanded_float (floatBinds floats), - ppr (filter demanded_float (floatBinds floats)) ) + -- Hence the warning + ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)), + ppr (filter demanded_float (floatBinds floats)) ) tick LetFloatFromLet `thenSmpl_` ( addFloats env1 floats $ \ env2 -> addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> - completeLazyBind env3 top_lvl bndr bndr'' rhs2) + completeLazyBind env3 top_lvl bndr bndr2 rhs2) else - completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1) + completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) #ifdef DEBUG demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) @@ -545,7 +601,7 @@ completeLazyBind :: SimplEnv -- (as usual) use the in-scope-env from the floats completeLazyBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env new_bndr loop_breaker new_rhs + | postInlineUnconditionally env new_bndr occ_info new_rhs = -- Drop the binding tick (PostInlineUnconditionally old_bndr) `thenSmpl_` returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs)) @@ -557,16 +613,32 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- Add arity info new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs - -- Add the unfolding *only* for non-loop-breakers - -- Making loop breakers not have an unfolding at all - -- means that we can avoid tests in exprIsConApp, for example. - -- This is important: if exprIsConApp says 'yes' for a recursive - -- thing, then we can get into an infinite loop - info_w_unf | loop_breaker = new_bndr_info - | otherwise = new_bndr_info `setUnfoldingInfo` unfolding - unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - - final_id = new_bndr `setIdInfo` info_w_unf + -- Add the unfolding *only* for non-loop-breakers + -- Making loop breakers not have an unfolding at all + -- means that we can avoid tests in exprIsConApp, for example. + -- This is important: if exprIsConApp says 'yes' for a recursive + -- thing, then we can get into an infinite loop + + -- If the unfolding is a value, the demand info may + -- go pear-shaped, so we nuke it. Example: + -- let x = (a,b) in + -- case x of (p,q) -> h p q x + -- Here x is certainly demanded. But after we've nuked + -- the case, we'll get just + -- let x = (a,b) in h a b x + -- and now x is not demanded (I'm assuming h is lazy) + -- This really happens. Similarly + -- let f = \x -> e in ...f..f... + -- After inling f at some of its call sites the original binding may + -- (for example) be no longer strictly demanded. + -- The solution here is a bit ad hoc... + unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding + final_info | loop_breaker = new_bndr_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 @@ -671,8 +743,8 @@ simplExprF env (Case scrut bndr alts) cont simplExprF env (Let (Rec pairs) body) cont = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> - -- NB: bndrs' don't have unfoldings or spec-envs - -- We add them as we go down, using simplPrags + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> addFloats env floats $ \ env -> @@ -774,12 +846,14 @@ simplNote env (Coerce to from) body cont -- the inner one is redundant addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) - | Just (s1, s2) <- splitFunTy_maybe s1s2 + | not (isTypeArg arg), -- This whole case only works for value args + -- Could upgrade to have equiv thing for type apps too + Just (s1, s2) <- splitFunTy_maybe s1s2 -- (coerce (T1->T2) (S1->S2) F) E -- ===> -- coerce T2 S2 (F (coerce S1 T1 E)) -- - -- t1t2 must be a function type, T1->T2 + -- 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 @@ -788,7 +862,7 @@ simplNote env (Coerce to from) body cont -- But it isn't a common case. = let (t1,t2) = splitFunTy t1t2 - new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg) + new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg) in ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) @@ -819,6 +893,10 @@ simplNote env InlineMe e cont -- an interesting context of any kind to combine with -- (even a type application -- anything except Stop) = simplExprF env e cont + +simplNote env (CoreNote s) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note (CoreNote s) e') cont \end{code} @@ -895,7 +973,7 @@ completeCall env var occ_info cont tick (RuleFired rule_name) `thenSmpl_` (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ptext rule_name, + text "Rule:" <+> ftext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) @@ -909,8 +987,8 @@ completeCall env var occ_info cont let arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - interesting_cont = interestingCallContext (not (null args)) - (not (null arg_infos)) + interesting_cont = interestingCallContext (notNull args) + (notNull arg_infos) call_cont active_inline = activeInline env var occ_info @@ -1024,11 +1102,14 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside | is_strict = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside - | otherwise - = simplExprF (setInScope arg_se env) val_arg - (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) -> - addFloats env floats $ \ env -> - thing_inside env arg1 + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = simplExprC (setInScope arg_se env) val_arg + (mkStop arg_ty AnArg) `thenSmpl` \ arg1 -> + thing_inside env arg1 where arg_ty = funArgTy fn_ty @@ -1105,8 +1186,8 @@ mkAtomicArgs :: Bool -- A strict binding -- if the strict-binding flag is on mkAtomicArgs is_strict ok_float_unlifted rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP = go fun nilOL [] args -- Have a go | otherwise = bale_out -- Give up @@ -1127,7 +1208,7 @@ mkAtomicArgs is_strict ok_float_unlifted rhs | otherwise -- Don't forget to do it recursively -- E.g. x = a:b:c:[] = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> - newId SLIT("a") arg_ty `thenSmpl` \ arg_id -> + newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) (Var arg_id : rev_args) args where @@ -1175,7 +1256,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr rebuild env expr (Stop _ _ _) = rebuildDone env expr rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr -rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont +rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont @@ -1218,38 +1299,22 @@ rebuildCase env scrut case_bndr alts cont = knownCon env (LitAlt lit) [] case_bndr alts cont | otherwise - = -- Prepare case alternatives - -- Filter out alternatives that can't possibly match - let - impossible_cons = case scrut of - Var v -> otherCons (idUnfolding v) - other -> [] - better_alts = case impossible_cons of - [] -> alts - other -> [alt | alt@(con,_,_) <- alts, - not (con `elem` impossible_cons)] - - -- "handled_cons" are handled either by the context, - -- or by a branch in this case expression - -- Don't add DEFAULT to the handled_cons!! - (alts_wo_default, _) = findDefault better_alts - handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default] - in - + = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> + -- Deal with the case binder, and prepare the continuation; -- The new subst_env is in place - prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> - addFloats env floats $ \ env -> + prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + addFloats env floats $ \ env -> -- Deal with variable scrutinee - simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> + simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> -- Deal with the case alternatives simplAlts alt_env zap_occ_info handled_cons - case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> + case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> -- Put the case back together - mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr -> + mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr -> -- Notice that rebuildDone returns the in-scope set from env, not alt_env -- The case binder *not* scope over the whole returned case-expression @@ -1285,10 +1350,10 @@ 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 +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 @@ -1402,17 +1467,21 @@ simplAlts env zap_occ_info handled_cons case_bndr' alts cont' -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. - add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc) + add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc) add_evals other_con vs = vs - cat_evals [] [] = [] - cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | isMarkedStrict str = evald_v : cat_evals vs strs - | otherwise = zapped_v : cat_evals vs strs + cat_evals dc vs strs + = go vs strs where - zapped_v = zap_occ_info v - evald_v = zapped_v `setIdUnfolding` mkOtherCon [] + go [] [] = [] + go (v:vs) (str:strs) + | isTyVar v = v : go 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` mkOtherCon [] + go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) \end{code} @@ -1556,7 +1625,7 @@ mkDupableCont env (ApplyTo _ arg se cont) if exprIsDupable arg' then returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont)) else - newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id -> + newId FSLIT("a") (exprType arg') `thenSmpl` \ arg_id -> tick (CaseOfCase arg_id) `thenSmpl_` -- Want to tick here so that we go round again, @@ -1675,14 +1744,14 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) -- (the \v alone is enough to make CPR happy) but I think it's rare ( if null used_bndrs' - then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> + then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> returnSmpl ([rw_id], [Var realWorldPrimId]) else returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId SLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> -- Notice the funky mkPiTypes. If the contructor has existentials -- it's possible that the join point will be abstracted over -- type varaibles as well as term variables.