X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=f5af0d1693c72f86ce38f443d007cda23f0b90ac;hb=95581e0c3b2d4d6edd33fdd6e135aa3917072c4c;hp=e966509d55803d451896e7b979a0745e89305870;hpb=5d89d8eb1712aba2226af68d10b04354cd939cc5;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index e966509..f5af0d1 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -12,8 +12,8 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, mkLam, newId, - simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId, +import SimplUtils ( mkCase, mkLam, newId, prepareAlts, + simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, SimplCont(..), DupFlag(..), LetRhsFlag(..), mkStop, mkBoringStop, pushContArgs, contResultType, countArgs, contIsDupable, contIsRhsOrArg, @@ -22,11 +22,11 @@ import SimplUtils ( mkCase, mkLam, newId, import Var ( mustHaveLocalBinding ) import VarEnv import Id ( Id, idType, idInfo, idArity, isDataConId, - idUnfolding, setIdUnfolding, isDeadBinder, + setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, - setIdOccInfo, - zapLamIdInfo, setOneShotLambda, + setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) +import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, setUnfoldingInfo, @@ -36,25 +36,25 @@ 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, mkPiType, findAlt, findDefault, - exprType, coreAltsType, exprIsValue, + exprIsConApp_maybe, mkPiTypes, findAlt, + exprType, exprIsValue, exprOkForSpeculation, exprArity, - mkCoerce, mkSCC, mkInlineMe, mkAltExpr + mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) -import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs, - funResultTy, splitFunTy_maybe, splitFunTy, eqType +import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy, + splitFunTy_maybe, splitFunTy, eqType ) import Subst ( mkSubst, substTy, substExpr, isInScope, lookupIdSubst, simplIdInfo ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRec ) import OrdList @@ -230,7 +230,7 @@ simplTopBinds env binds -- 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. - simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> freeTick SimplifierDone `thenSmpl_` returnSmpl (floatBinds floats) @@ -295,17 +295,23 @@ 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 - simplLetId env bndr `thenSmpl` \ (env, bndr') -> - simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 -> + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr'' bndr'' + in + simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> -- Now complete the binding and simplify the body - completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside + completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence in the substitution - simplLetId env bndr `thenSmpl` \ (env, bndr') -> + -- fragile occurrence info in the substitution + simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside @@ -322,6 +328,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) -> ... } @@ -339,18 +357,13 @@ 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) -> -- Make the arguments atomic if necessary, -- adding suitable bindings - addAtomicBindsE env aux_binds $ \ env -> + addAtomicBindsE env (fromOL aux_binds) $ \ env -> completeLazyBind env NotTopLevel old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside @@ -442,12 +455,12 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- -- NB: does no harm for non-recursive bindings let - bndr_ty' = idType bndr' - bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr' + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) env1 = modifyInScope env bndr'' bndr'' rhs_env = setInScope rhs_se env1 - ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec - rhs_cont = mkStop bndr_ty' AnRhs + is_top_level = isTopLevel top_lvl + ok_float_unlifted = not is_top_level && isNonRec is_rec + rhs_cont = mkStop (idType bndr') AnRhs in -- Simplify the RHS; note the mkStop, which tells -- the simplifier that this is the RHS of a let. @@ -466,7 +479,7 @@ 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 && null aux_binds then -- Shortcut a common case + if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case completeLazyBind env1 top_lvl bndr bndr'' rhs2 -- We use exprIsTrivial here because we want to reveal lone variables. @@ -480,8 +493,9 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- 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 exprIsTrivial rhs2 || exprIsValue rhs2 then + -- thing is non-strict. I think. The WARN below tests for this. + else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- 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 @@ -493,7 +507,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se tick LetFloatFromLet `thenSmpl_` ( addFloats env1 floats $ \ env2 -> - addAtomicBinds env2 aux_binds $ \ env3 -> + addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> completeLazyBind env3 top_lvl bndr bndr'' rhs2) else @@ -544,7 +558,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)) @@ -626,7 +640,7 @@ might do the same again. \begin{code} simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') +simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg) where expr_ty' = substTy (getSubst env) (exprType expr) -- The type in the Stop continuation, expr_ty', is usually not used @@ -669,7 +683,7 @@ simplExprF env (Case scrut bndr alts) cont case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont)) simplExprF env (Let (Rec pairs) body) cont - = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + = 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 @@ -721,7 +735,7 @@ simplLam env fun cont -- Not enough args, so there are real lambdas left to put in the result go env lam@(Lam _ _) cont - = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') -> + = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') -> simplExpr env body `thenSmpl` \ body' -> mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) -> addFloats env floats $ \ env -> @@ -853,8 +867,9 @@ completeCall env var occ_info cont let chkr = getSwitchChecker env (args, call_cont, inline_call) = getContArgs chkr var cont + fn_ty = idType var in - simplifyArgs env args (contResultType call_cont) $ \ env args -> + simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args -> -- Next, look for rules or specialisations that match -- @@ -895,7 +910,8 @@ completeCall env var occ_info cont pprTrace "Rule fired" (vcat [ text "Rule:" <+> ptext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "After: " <+> pprCoreExpr rule_rhs]) + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) else id) $ simplExprF env rule_rhs call_cont ; @@ -910,7 +926,7 @@ completeCall env var occ_info cont (not (null arg_infos)) call_cont - active_inline = activeInline env var + active_inline = activeInline env var occ_info maybe_inline = callSiteInline dflags active_inline inline_call occ_info var arg_infos interesting_cont in @@ -974,6 +990,7 @@ makeThatCall env var fun args cont -- Simplifying the arguments of a call simplifyArgs :: SimplEnv + -> OutType -- Type of the function -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments -> OutType -- Type of the continuation -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr) @@ -1004,35 +1021,35 @@ simplifyArgs :: SimplEnv -- discard the entire application and replace it with (error "foo"). Getting -- all this at once is TOO HARD! -simplifyArgs env args cont_ty thing_inside - = go env args thing_inside +simplifyArgs env fn_ty args cont_ty thing_inside + = go env fn_ty args thing_inside where - go env [] thing_inside = thing_inside env [] - go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' -> - go env args $ \ env args' -> - thing_inside env (arg':args') + go env fn_ty [] thing_inside = thing_inside env [] + go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' -> + go env (applyTypeToArg fn_ty arg') args $ \ env args' -> + thing_inside env (arg':args') -simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside +simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg -> thing_inside env (Type new_ty_arg) -simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside +simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside | is_strict - = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside + = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside | otherwise - = let - arg_env = setInScope arg_se env - in - simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty -> - simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) -> - addFloats env floats $ \ env -> + = simplExprF (setInScope arg_se env) val_arg + (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) -> + addFloats env floats $ \ env -> thing_inside env arg1 + where + arg_ty = funArgTy fn_ty -simplStrictArg :: SimplEnv -- The env of the call - -> LetRhsFlag - -> InExpr -> SimplEnv -- The arg plus its env +simplStrictArg :: LetRhsFlag + -> SimplEnv -- The env of the call + -> InExpr -> SimplEnv -- The arg plus its env + -> OutType -- arg_ty: type of the argument -> OutType -- cont_ty: Type of thing computed by the context -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- Takes an expression of type rhs_ty, @@ -1041,9 +1058,9 @@ simplStrictArg :: SimplEnv -- The env of the call -- env of the call, plus any new in-scope variables -> SimplM FloatsWithExpr -- An expression of type cont_ty -simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside +simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside = simplExprF (setInScope arg_env call_env) arg - (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env))) + (ArgOf is_rhs arg_ty cont_ty (\ new_env -> thing_inside (setInScope call_env new_env))) -- Notice the way we use arg_env (augmented with in-scope vars from call_env) -- to simplify the argument -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation @@ -1096,57 +1113,43 @@ context information. mkAtomicArgs :: Bool -- A strict binding -> Bool -- OK to float unlifted args -> OutExpr - -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include - OutExpr) -- things that need case-binding, - -- if the strict-binding flag is on + -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include + OutExpr) -- things that need case-binding, + -- if the strict-binding flag is on mkAtomicArgs is_strict ok_float_unlifted rhs - = mk_atomic_args rhs `thenSmpl` \ maybe_stuff -> - case maybe_stuff of - Nothing -> returnSmpl ([], rhs) - Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs') + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + = go fun nilOL [] args -- Have a go + + | otherwise = bale_out -- Give up where - mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr)) - -- Nothing => no change - mk_atomic_args rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP - = -- Worth a try - go nilOL [] args `thenSmpl` \ maybe_stuff -> - case maybe_stuff of - Nothing -> returnSmpl Nothing - Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args')) - - | otherwise - = returnSmpl Nothing + bale_out = returnSmpl (nilOL, rhs) - go binds rev_args [] - = returnSmpl (Just (binds, reverse rev_args)) - go binds rev_args (arg : args) - | exprIsTrivial arg -- Easy case - = go binds (arg:rev_args) args + go fun binds rev_args [] + = returnSmpl (binds, mkApps (Var fun) (reverse rev_args)) + + go fun binds rev_args (arg : args) + | exprIsTrivial arg -- Easy case + = go fun binds (arg:rev_args) args | not can_float_arg -- Can't make this arg atomic - = returnSmpl Nothing -- ... so give up + = bale_out -- ... so give up | otherwise -- Don't forget to do it recursively -- E.g. x = a:b:c:[] - = mk_atomic_args arg `thenSmpl` \ maybe_anf -> - case maybe_anf of { - Nothing -> returnSmpl Nothing ; - Just (arg_binds,arg') -> - - newId SLIT("a") arg_ty `thenSmpl` \ arg_id -> - go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) + = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> + 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 arg_ty = exprType arg can_float_arg = is_strict || not (isUnLiftedType arg_ty) || (ok_float_unlifted && exprOkForSpeculation arg) + addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)] -> (SimplEnv -> SimplM (FloatsWith a)) -> SimplM (FloatsWith a) @@ -1228,36 +1231,26 @@ 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)] - 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, 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 impossible_cons - case_bndr' better_alts cont' `thenSmpl` \ alts' -> + simplAlts alt_env zap_occ_info handled_cons + case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> -- Put the case back together - mkCase scrut 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 - rebuildDone env case_expr + rebuild env case_expr nondup_cont \end{code} simplCaseBinder checks whether the scrutinee is a variable, v. If so, @@ -1289,10 +1282,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 @@ -1358,20 +1351,16 @@ simplCaseBinder env other_scrut case_bndr simplAlts :: SimplEnv -> (InId -> InId) -- Occ-info zapper -> [AltCon] -- Alternatives the scrutinee can't be + -- in the default case -> OutId -- Case binder -> [InAlt] -> SimplCont -> SimplM [OutAlt] -- Includes the continuation -simplAlts env zap_occ_info impossible_cons case_bndr' alts cont' +simplAlts env zap_occ_info handled_cons case_bndr' alts cont' = mapSmpl simpl_alt alts where inst_tys' = tyConAppArgs (idType case_bndr') - -- handled_cons is all the constructors that are dealt - -- with, either by being impossible, or by there being an alternative - (con_alts,_) = findDefault alts - handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts] - simpl_alt (DEFAULT, _, rhs) = let -- In the default case we record the constructors that the @@ -1498,79 +1487,73 @@ bind_args env (b:bs) (arg : args) thing_inside \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation, - -- plus some extra bindings + -> SimplM (FloatsWith (SimplCont,SimplCont)) + -- Return a duplicatable continuation, a non-duplicable part + -- plus some extra bindings -prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont) -- No need to make it duplicatable if there's only one alternative - -prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty -> - mkDupableCont env alts_ty cont - -- At one time I passed in the un-simplified type, and simplified - -- it only if we needed to construct a join binder, but that - -- didn't work because we have to decompse function types - -- (using funResultTy) in mkDupableCont. +prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) +prepareCaseCont env alts cont = mkDupableCont env cont \end{code} \begin{code} -mkDupableCont :: SimplEnv - -> OutType -- Type of the thing to be given to the continuation - -> SimplCont - -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation, - -- plus some extra bindings +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM (FloatsWith (SimplCont, SimplCont)) -mkDupableCont env ty cont +mkDupableCont env cont | contIsDupable cont - = returnSmpl (emptyFloats env, cont) - -mkDupableCont env _ (CoerceIt ty cont) - = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') -> - returnSmpl (floats, CoerceIt ty cont') - -mkDupableCont env ty (InlinePlease cont) - = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') -> - returnSmpl (floats, InlinePlease cont') - -mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn) - = -- e.g. (...strict-fn...) [...hole...] + = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont))) + +mkDupableCont env (CoerceIt ty cont) + = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont)) + +mkDupableCont env (InlinePlease cont) + = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + returnSmpl (floats, (InlinePlease dup_cont, nondup_cont)) + +mkDupableCont env cont@(ArgOf _ arg_ty _ _) + = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont)) + -- Do *not* duplicate an ArgOf continuation + -- Because ArgOf continuations are opaque, we gain nothing by + -- propagating them into the expressions, and we do lose a lot. + -- Here's an example: + -- && (case x of { T -> F; F -> T }) E + -- Now, && is strict so we end up simplifying the case with + -- an ArgOf continuation. If we let-bind it, we get + -- + -- let $j = \v -> && v E + -- in simplExpr (case x of { T -> F; F -> T }) + -- (ArgOf (\r -> $j r) + -- And after simplifying more we get + -- + -- let $j = \v -> && v E + -- in case of { T -> $j F; F -> $j T } + -- Which is a Very Bad Thing + -- + -- The desire not to duplicate is the entire reason that + -- mkDupableCont returns a pair of continuations. + -- + -- The original plan had: + -- e.g. (...strict-fn...) [...hole...] -- ==> -- let $j = \a -> ...strict-fn... -- in $j [...hole...] - -- Build the join Id and continuation - -- We give it a "$j" name just so that for later amusement - -- we can identify any join points that don't end up as let-no-escapes - -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.] - newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id -> - newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id -> - - cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) -> - let - cont_fn env arg' = rebuildDone env (App (Var join_id) arg') - join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs) - in - - tick (CaseOfCase join_id) `thenSmpl_` - -- Want to tick here so that we go round again, - -- and maybe copy or inline the code; - -- not strictly CaseOf Case - - returnSmpl (unitFloat env join_id join_rhs, - ArgOf OkToDup is_rhs cont_ty cont_fn) - -mkDupableCont env ty (ApplyTo _ arg se cont) +mkDupableCont env (ApplyTo _ arg se cont) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... -- in [...hole...] a - mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') -> + simplExpr (setInScope se env) arg `thenSmpl` \ arg' -> + + mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> addFloats env floats $ \ env -> - simplExpr (setInScope se env) arg `thenSmpl` \ arg' -> if exprIsDupable arg' then - returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont') + 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, @@ -1578,13 +1561,14 @@ mkDupableCont env ty (ApplyTo _ arg se cont) -- Not strictly CaseOfCase, but never mind returnSmpl (unitFloat env arg_id arg', - ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont') + (ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) dup_cont, + nondup_cont)) -- But what if the arg should be case-bound? -- This has been this way for a long time, so I'll leave it, -- but I can't convince myself that it's right. -mkDupableCont env ty (Select _ case_bndr alts se cont) +mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) -- ===> -- let ji = \xij -> ei @@ -1593,7 +1577,7 @@ mkDupableCont env ty (Select _ case_bndr alts se cont) let alt_env = setInScope se env in - prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) -> + prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, (dup_cont, nondup_cont)) -> addFloats alt_env floats1 $ \ alt_env -> simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') -> @@ -1606,10 +1590,12 @@ mkDupableCont env ty (Select _ case_bndr alts se cont) -- In the new alts we build, we have the new case binder, so it must retain -- its deadness. - mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') -> + mkDupableAlts alt_env case_bndr' alts dup_cont `thenSmpl` \ (floats2, alts') -> addFloats alt_env floats2 $ \ alt_env -> - returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se) - (mkBoringStop (contResultType cont))) + returnSmpl (emptyFloats alt_env, + (Select OkToDup case_bndr' alts' (zapSubstEnv se) + (mkBoringStop (contResultType dup_cont)), + nondup_cont)) mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont -> SimplM (FloatsWith [InAlt]) @@ -1686,15 +1672,15 @@ 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") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr -> - -- Notice the funky mkPiType. If the contructor has existentials + newId (encodeFS SLIT("$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. -- Example: Suppose we have