X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=9f0c1a36e8b7ff49b3ea5debb3ed65df6a2c5a81;hb=cbf5bb17365e9228f3f724b87f958982c4b66cba;hp=6cacbdb613c668a3a984071d086bf2b58125ee01;hpb=9df1b97e2fcd4df84542547d57965cd46ccedcc6;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 6cacbdb..9f0c1a3 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,70 +8,61 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( intSwitchSet, switchIsOn, - opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction, - opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms, +import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, + opt_SimplNoPreInlining, SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, transformRhs, findAlt, +import SimplUtils ( mkCase, transformRhs, findAlt, simplBinder, simplBinders, simplIds, findDefault, - SimplCont(..), DupFlag(..), contResultType, analyseCont, - discardInline, countArgs, countValArgs, discardCont, contIsDupable + SimplCont(..), DupFlag(..), mkStop, mkRhsStop, + contResultType, discardInline, countArgs, contIsDupable, + getContArgs, interestingCallContext, interestingArg, isStrictType ) -import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo ) +import Var ( mkSysTyVar, tyVarKind ) import VarEnv -import VarSet -import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe, +import VarSet ( elemVarSet ) +import Id ( Id, idType, idInfo, isDataConId, idUnfolding, setIdUnfolding, isExportedId, isDeadBinder, - idSpecialisation, setIdSpecialisation, - idDemandInfo, setIdDemandInfo, - setIdInfo, + idDemandInfo, setIdInfo, idOccInfo, setIdOccInfo, - zapLamIdInfo, zapFragileIdInfo, - idStrictness, isBottomingId, - setInlinePragma, mayHaveNoBinding, - setOneShotLambda, maybeModifyIdInfo + zapLamIdInfo, setOneShotLambda, ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), - ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, - specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo, - CprInfo(..), cprInfo, occInfo +import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, + setArityInfo, unknownArity, + setUnfoldingInfo, + occInfo ) -import Demand ( Demand, isStrict, wwLazy ) -import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity, +import Demand ( isStrict ) +import DataCon ( dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) -import Name ( isLocallyDefined ) import CoreSyn -import CoreFVs ( exprFreeVars ) -import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate, - callSiteInline, hasSomeUnfolding, noUnfolding +import CoreFVs ( mustHaveLocalBinding, exprFreeVars ) +import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, + callSiteInline ) -import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, exprIsConApp_maybe, - exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap, - exprOkForSpeculation, etaReduceExpr, +import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, + exprIsConApp_maybe, mkPiType, + exprType, coreAltsType, exprIsValue, idAppIsCheap, + exprOkForSpeculation, mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) import Rules ( lookupRule ) -import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, - mkFunTy, splitFunTy, splitFunTys, splitFunTy_maybe, - splitTyConApp_maybe, - funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys +import CostCentre ( currentCCS ) +import Type ( mkTyVarTys, isUnLiftedType, seqType, + mkFunTy, splitTyConApp_maybe, tyConAppArgs, + funResultTy ) -import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr, - substEnv, isInScope, lookupIdSubst, substIdInfo +import Subst ( mkSubst, substTy, + isInScope, lookupIdSubst, substIdInfo ) -import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) +import TyCon ( isDataTyCon, tyConDataConsIfAvailable ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker ) import Maybes ( maybeToBool ) -import Util ( zipWithEqual, lengthExceeds ) -import PprCore +import Util ( zipWithEqual ) import Outputable -import Unique ( foldrIdKey ) -- Temp \end{code} @@ -79,6 +70,16 @@ The guts of the simplifier is in this module, but the driver loop for the simplifier is in SimplCore.lhs. +----------------------------------------- + *** IMPORTANT NOTE *** +----------------------------------------- +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + + + %************************************************************************ %* * \subsection{Bindings} @@ -129,33 +130,6 @@ simplRecBind top_lvl pairs bndrs' thing_inside %* * %************************************************************************ -\begin{code} -addLetBind :: OutId -> OutExpr -> SimplM (OutStuff a) -> SimplM (OutStuff a) -addLetBind bndr rhs thing_inside - = thing_inside `thenSmpl` \ (binds, res) -> - returnSmpl (NonRec bndr rhs : binds, res) - -addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a) -addLetBinds binds1 thing_inside - = thing_inside `thenSmpl` \ (binds2, res) -> - returnSmpl (binds1 ++ binds2, res) - -needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) - -addCaseBind bndr rhs thing_inside - = getInScope `thenSmpl` \ in_scope -> - thing_inside `thenSmpl` \ (floats, (_, body)) -> - returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)])) - -addNonRecBind bndr rhs thing_inside - -- Checks for needing a case binding - | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside - | otherwise = addLetBind bndr rhs thing_inside -\end{code} - The reason for this OutExprStuff stuff is that we want to float *after* simplifying a RHS, not before. If we do so naively we get quadratic behaviour as things float out. @@ -197,7 +171,7 @@ might do the same again. \begin{code} simplExpr :: CoreExpr -> SimplM CoreExpr simplExpr expr = getSubst `thenSmpl` \ subst -> - simplExprC expr (Stop (substTy subst (exprType expr))) + simplExprC expr (mkStop (substTy subst (exprType expr))) -- The type in the Stop continuation is usually not used -- It's only needed when discarding continuations after finding -- a function that returns bottom. @@ -236,7 +210,7 @@ simplExprF (Case scrut bndr alts) cont -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it simplExprC scrut (Select NoDup bndr alts subst_env - (Stop (contResultType cont))) `thenSmpl` \ case_expr' -> + (mkStop (contResultType cont))) `thenSmpl` \ case_expr' -> rebuild case_expr' cont @@ -250,7 +224,7 @@ simplExprF (Let (Rec pairs) body) cont simplExprF expr@(Lam _ _) cont = simplLam expr cont simplExprF (Type ty) cont - = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } ) + = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } ) simplType ty `thenSmpl` \ ty' -> rebuild (Type ty') cont @@ -303,9 +277,9 @@ simplExprF (Note InlineCall e) cont simplExprF (Note InlineMe e) cont = case cont of - Stop _ -> -- Totally boring continuation + Stop _ _ -> -- Totally boring continuation -- Don't inline inside an INLINE expression - switchOffInlining (simplExpr e) `thenSmpl` \ e' -> + setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' -> rebuild (mkInlineMe e') cont other -> -- Dissolve the InlineMe note if there's @@ -353,22 +327,37 @@ simplLam fun cont go expr cont = simplExprF expr cont -- completeLam deals with the case where a lambda doesn't have an ApplyTo --- continuation. --- We used to try for eta reduction here, but I found that this was --- eta reducing things like --- f = \x -> (coerce (\x -> e)) --- This made f's arity reduce, which is a bad thing, so I removed the --- eta reduction at this point, and now do it only when binding --- (at the call to postInlineUnconditionally) - -completeLam acc (Lam bndr body) cont +-- continuation, so there are real lambdas left to put in the result + +-- We try for eta reduction here, but *only* if we get all the +-- way to an exprIsTrivial expression. +-- We don't want to remove extra lambdas unless we are going +-- to avoid allocating this thing altogether + +completeLam rev_bndrs (Lam bndr body) cont = simplBinder bndr $ \ bndr' -> - completeLam (bndr':acc) body cont + completeLam (bndr':rev_bndrs) body cont -completeLam acc body cont +completeLam rev_bndrs body cont = simplExpr body `thenSmpl` \ body' -> - rebuild (foldl (flip Lam) body' acc) cont - -- Remember, acc is the *reversed* binders + case try_eta body' of + Just etad_lam -> tick (EtaReduction (head rev_bndrs)) `thenSmpl_` + rebuild etad_lam cont + + Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont + where + -- We don't use CoreUtils.etaReduce, because we can be more + -- efficient here: (a) we already have the binders, (b) we can do + -- the triviality test before computing the free vars + try_eta body | not opt_SimplDoEtaReduction = Nothing + | otherwise = go rev_bndrs body + + go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round + go [] body | ok_body body = Just body -- Success! + go _ _ = Nothing -- Failure! + + ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs) + ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg mkLamBndrZapper :: CoreExpr -- Function -> SimplCont -- The context @@ -431,11 +420,14 @@ simplBeta bndr rhs rhs_se cont_ty thing_inside | otherwise = -- Simplify the RHS simplBinder bndr $ \ bndr' -> - simplValArg (idType bndr') (idDemandInfo bndr) - rhs rhs_se cont_ty $ \ rhs' -> + let + bndr_ty' = idType bndr' + is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty' + in + simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' -> -- Now complete the binding and simplify the body - if needsCaseBinding (idType bndr') rhs' then + if needsCaseBinding bndr_ty' rhs' then addCaseBind bndr' rhs' thing_inside else completeBinding bndr bndr' False False rhs' thing_inside @@ -452,45 +444,28 @@ simplTyArg ty_arg se seqType ty_arg' `seq` returnSmpl ty_arg' -simplValArg :: OutType -- Type of arg - -> Demand -- Demand on the argument +simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally + -> Bool -- True <=> evaluate eagerly -> InExpr -> SubstEnv - -> OutType -- Type of thing computed by the context - -> (OutExpr -> SimplM OutExprStuff) - -> SimplM OutExprStuff - -simplValArg arg_ty demand arg arg_se cont_ty thing_inside - | isStrict demand || - isUnLiftedType arg_ty || - (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty) - -- Return true only for dictionary types where the dictionary - -- has more than one component (else we risk poking on the component - -- of a newtype dictionary) - = transformRhs arg `thenSmpl` \ t_arg -> - getEnv `thenSmpl` \ env -> + -> OutType -- cont_ty: Type of thing computed by the context + -> (OutExpr -> SimplM OutExprStuff) + -- Takes an expression of type rhs_ty, + -- returns an expression of type cont_ty + -> SimplM OutExprStuff -- An expression of type cont_ty + +simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside + | is_strict + = getEnv `thenSmpl` \ env -> setSubstEnv arg_se $ - simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' -> + simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' -> setAllExceptInScope env $ - etaFirst thing_inside rhs') + thing_inside rhs') | otherwise = simplRhs False {- Not top level -} True {- OK to float unboxed -} arg_ty arg arg_se thing_inside - --- Do eta-reduction on the simplified RHS, if eta reduction is on --- NB: etaFirst only eta-reduces if that results in something trivial -etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs) - | otherwise = \ thing_inside rhs -> thing_inside rhs - --- Try for eta reduction, but *only* if we get all --- the way to an exprIsTrivial expression. We don't want to remove --- extra lambdas unless we are going to avoid allocating this thing altogether -etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs' - | otherwise = rhs - where - rhs' = etaReduceExpr rhs \end{code} @@ -516,63 +491,110 @@ completeBinding :: InId -- Binder -> SimplM (OutStuff a) completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside - | (case occ_info of -- This happens; for example, the case_bndr during case of - IAmDead -> True -- known constructor: case (a,b) of x { (p,q) -> ... } - other -> False) -- Here x isn't mentioned in the RHS, so we don't want to + | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to -- create the (dead) let-binding let x = (a,b) in ... = thing_inside - | postInlineUnconditionally black_listed occ_info old_bndr new_rhs - -- Maybe we don't need a let-binding! Maybe we can just - -- inline it right away. Unlike the preInlineUnconditionally case - -- we are allowed to look at the RHS. + | exprIsTrivial new_rhs + -- We're looking at a binding with a trivial RHS, so + -- perhaps we can discard it altogether! -- -- NB: a loop breaker never has postInlineUnconditionally True -- and non-loop-breakers only have *forward* references -- Hence, it's safe to discard the binding -- - -- NB: You might think that postInlineUnconditionally is an optimisation, - -- but if we have - -- let x = f Bool in (x, y) - -- then because of the constructor, x will not be *inlined* in the pair, - -- so the trivial binding will stay. But in this postInlineUnconditionally - -- gag we use the *substitution* to substitute (f Bool) for x, and that *will* - -- happen. - = tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - extendSubst old_bndr (DoneEx new_rhs) - thing_inside + -- NOTE: This isn't our last opportunity to inline. + -- We're at the binding site right now, and + -- we'll get another opportunity when we get to the ocurrence(s) + + -- Note that we do this unconditional inlining only for trival RHSs. + -- Don't inline even WHNFs inside lambdas; doing so may + -- simply increase allocation when the function is called + -- This isn't the last chance; see NOTE above. + -- + -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here + -- Why? Because we don't even want to inline them into the + -- RHS of constructor arguments. See NOTE above + -- + -- NB: Even NOINLINEis ignored here: if the rhs is trivial + -- it's best to inline it anyway. We often get a=E; b=a + -- from desugaring, with both a and b marked NOINLINE. + = if must_keep_binding then -- Keep the binding + finally_bind_it unknownArity new_rhs + -- Arity doesn't really matter because for a trivial RHS + -- we will inline like crazy at call sites + -- If this turns out be false, we can easily compute arity + else -- Drop the binding + extendSubst old_bndr (DoneEx new_rhs) $ + -- Use the substitution to make quite, quite sure that the substitution + -- will happen, since we are going to discard the binding + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + thing_inside + + | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs + -- [NB inner_rhs is guaranteed non-trivial by now] + -- x = coerce t e ==> c = e; x = inline_me (coerce t c) + -- Now x can get inlined, which moves the coercion + -- to the usage site. This is a bit like worker/wrapper stuff, + -- but it's useful to do it very promptly, so that + -- x = coerce T (I# 3) + -- get's w/wd to + -- c = I# 3 + -- x = coerce T c + -- This in turn means that + -- case (coerce Int x) of ... + -- will inline x. + -- Also the full-blown w/w thing isn't set up for non-functions + -- + -- The inline_me note is so that the simplifier doesn't + -- just substitute c back inside x's rhs! (Typically, x will + -- get substituted away, but not if it's exported.) + = newId SLIT("c") inner_ty $ \ c_id -> + completeBinding c_id c_id top_lvl False inner_rhs $ + completeBinding old_bndr new_bndr top_lvl black_listed + (Note InlineMe (Note coercion (Var c_id))) $ + thing_inside + | otherwise - = getSubst `thenSmpl` \ subst -> - let - -- We make new IdInfo for the new binder by starting from the old binder, - -- doing appropriate substitutions. - -- Then we add arity and unfolding info to get the new binder - old_info = idInfo old_bndr - new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) - `setArityInfo` ArityAtLeast (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 we can get into an infinite loop - info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info - | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs - - final_id = new_bndr `setIdInfo` info_w_unf - in - -- These seqs forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - final_id `seq` - addLetBind final_id new_rhs $ - modifyInScope new_bndr final_id thing_inside + = transformRhs new_rhs finally_bind_it where - occ_info = idOccInfo old_bndr + old_info = idInfo old_bndr + occ_info = occInfo old_info + loop_breaker = isLoopBreaker occ_info + must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr + + finally_bind_it arity_info new_rhs + = getSubst `thenSmpl` \ subst -> + let + -- We make new IdInfo for the new binder by starting from the old binder, + -- doing appropriate substitutions. + -- Then we add arity and unfolding info to get the new binder + new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) + `setArityInfo` arity_info + + -- 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` mkUnfolding top_lvl new_rhs + + final_id = new_bndr `setIdInfo` info_w_unf + in + -- These seqs forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + final_id `seq` + addLetBind (NonRec final_id new_rhs) $ + modifyInScope new_bndr final_id thing_inside \end{code} + %************************************************************************ %* * \subsection{simplLazyBind} @@ -612,7 +634,7 @@ simplLazyBind top_lvl bndr bndr' rhs thing_inside -- Simplify the RHS getSubstEnv `thenSmpl` \ rhs_se -> - simplRhs top_lvl False {- Not ok to float unboxed -} + simplRhs top_lvl False {- Not ok to float unboxed (conservative) -} (idType bndr') rhs rhs_se $ \ rhs' -> @@ -625,21 +647,18 @@ simplLazyBind top_lvl bndr bndr' rhs thing_inside \begin{code} simplRhs :: Bool -- True <=> Top level -> Bool -- True <=> OK to float unboxed (speculative) bindings - -> OutType -> InExpr -> SubstEnv + -- False for (a) recursive and (b) top-level bindings + -> OutType -- Type of RHS; used only occasionally + -> InExpr -> SubstEnv -> (OutExpr -> SimplM (OutStuff a)) -> SimplM (OutStuff a) simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside - = -- Swizzle the inner lets past the big lambda (if any) - -- and try eta expansion - transformRhs rhs `thenSmpl` \ t_rhs -> - - -- Simplify it - setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> + = -- Simplify it + setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) -> -- Float lets out of RHS let - (floats_out, rhs'') | float_ubx = (floats, rhs') - | otherwise = splitFloats floats rhs' + (floats_out, rhs'') = splitFloats float_ubx floats rhs' in if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose @@ -656,12 +675,12 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside WARN( any demanded_float floats_out, ppr floats_out ) addLetBinds floats_out $ setInScope in_scope' $ - etaFirst thing_inside rhs'' + thing_inside rhs'' -- in_scope' may be excessive, but that's OK; -- it's a superset of what's in scope else -- Don't do the float - etaFirst thing_inside (mkLets floats rhs') + thing_inside (mkLets floats rhs') -- In a let-from-let float, we just tick once, arbitrarily -- choosing the first floated binder to identify it @@ -672,11 +691,17 @@ demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType ( -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False --- Don't float any unlifted bindings out, because the context +-- If float_ubx is true we float all the bindings, otherwise +-- we just float until we come across an unlifted one. +-- Remember that the unlifted bindings in the floats are all for +-- guaranteed-terminating non-exception-raising unlifted things, +-- which we are happy to do speculatively. However, we may still +-- not be able to float them out, because the context -- is either a Rec group, or the top level, neither of which -- can tolerate them. -splitFloats floats rhs - = go floats +splitFloats float_ubx floats rhs + | float_ubx = (floats, rhs) -- Float them all + | otherwise = go floats where go [] = ([], rhs) go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs) @@ -704,11 +729,7 @@ wantToExpose :: Int -> CoreExpr -> Bool -- v = E -- z = \w -> g v w -- Which is what we want; chances are z will be inlined now. --- --- This defn isn't quite like --- exprIsCheap (it ignores non-cheap args) --- exprIsValue (may not say True for a lone variable) --- which is slightly weird + wantToExpose n (Var v) = idAppIsCheap v n wantToExpose n (Lit l) = True wantToExpose n (Lam _ e) = True @@ -732,11 +753,8 @@ simplVar var cont case lookupIdSubst subst var of DoneEx e -> zapSubstEnv (simplExprF e cont) ContEx env1 e -> setSubstEnv env1 (simplExprF e cont) - DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1), + DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1, text "simplVar:" <+> ppr var ) - -- The mayHaveNoBinding test accouunts for the fact - -- that class dictionary constructors dont have top level - -- bindings and hence aren't in scope. zapSubstEnv (completeCall var1 occ cont) -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -751,31 +769,37 @@ simplVar var cont -- Dealing with a call completeCall var occ cont - = getBlackList `thenSmpl` \ black_list_fn -> - getInScope `thenSmpl` \ in_scope -> - getSwitchChecker `thenSmpl` \ chkr -> + = getBlackList `thenSmpl` \ black_list_fn -> + getInScope `thenSmpl` \ in_scope -> + getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) -> + getDOptsSmpl `thenSmpl` \ dflags -> let - dont_use_rules = switchIsOn chkr DontApplyRules - no_case_of_case = switchIsOn chkr NoCaseOfCase black_listed = black_list_fn var + arg_infos = [ interestingArg in_scope arg subst + | (arg, subst, _) <- args, isValArg arg] - (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont - discard_inline_cont | inline_call = discardInline cont - | otherwise = cont + interesting_cont = interestingCallContext (not (null args)) + (not (null arg_infos)) + call_cont - maybe_inline = callSiteInline black_listed inline_call occ + inline_cont | inline_call = discardInline cont + | otherwise = cont + + maybe_inline = callSiteInline dflags black_listed inline_call occ var arg_infos interesting_cont in -- First, look for an inlining - case maybe_inline of { Just unfolding -- There is an inlining! -> tick (UnfoldingDone var) `thenSmpl_` - simplExprF unfolding discard_inline_cont + simplExprF unfolding inline_cont ; Nothing -> -- No inlining! + + simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' -> + -- Next, look for rules or specialisations that match -- -- It's important to simplify the args first, because the rule-matcher @@ -790,133 +814,110 @@ completeCall var occ cont -- won't occur for things that have specialisations till a later phase, so -- it's ok to try for inlining first. - prepareArgs no_case_of_case var cont $ \ args' cont' -> + getSwitchChecker `thenSmpl` \ chkr -> let - maybe_rule | dont_use_rules = Nothing - | otherwise = lookupRule in_scope var args' + maybe_rule | switchIsOn chkr DontApplyRules = Nothing + | otherwise = lookupRule in_scope var args' in case maybe_rule of { Just (rule_name, rule_rhs) -> tick (RuleFired rule_name) `thenSmpl_` - simplExprF rule_rhs cont' ; + simplExprF rule_rhs call_cont ; Nothing -> -- No rules -- Done - rebuild (mkApps (Var var) args') cont' + rebuild (mkApps (Var var) args') call_cont }} -\end{code} -\begin{code} --------------------------------------------------------- --- Preparing arguments for a call - -prepareArgs :: Bool -- True if the no-case-of-case switch is on - -> OutId -> SimplCont - -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff) - -> SimplM OutExprStuff -prepareArgs no_case_of_case fun orig_cont thing_inside - = go [] demands orig_fun_ty orig_cont - where - orig_fun_ty = idType fun - is_data_con = isDataConId fun - - (demands, result_bot) - | no_case_of_case = ([], False) -- Ignore strictness info if the no-case-of-case - -- flag is on. Strictness changes evaluation order - -- and that can change full laziness - | otherwise - = case idStrictness fun of - StrictnessInfo demands result_bot - | not (demands `lengthExceeds` countValArgs orig_cont) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - (demands, result_bot) - - other -> ([], False) -- Not enough args, or no strictness - - -- Main game plan: loop through the arguments, simplifying - -- each of them in turn. We carry with us a list of demands, - -- and the type of the function-applied-to-earlier-args - - -- We've run out of demands, and the result is now bottom - -- This deals with - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - go acc [] fun_ty cont - | result_bot - = tick_case_of_error cont `thenSmpl_` - thing_inside (reverse acc) (discardCont cont) - - -- Type argument - go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont) - = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg -> - go (Type new_ty_arg : acc) ds (applyTy fun_ty new_ty_arg) cont - - -- Value argument - go acc ds fun_ty (ApplyTo _ val_arg se cont) - | not is_data_con -- Function isn't a data constructor - = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg -> - go (new_arg : acc) ds' res_ty cont - - | exprIsTrivial val_arg -- Function is a data contstructor, arg is trivial - = getInScope `thenSmpl` \ in_scope -> - let - new_arg = substExpr (mkSubst in_scope se) val_arg - -- Simplify the RHS with inlining switched off, so that - -- only absolutely essential things will happen. +-- Simplifying the arguments of a call + +simplifyArgs :: Bool -- It's a data constructor + -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments + -> OutType -- Type of the continuation + -> ([OutExpr] -> SimplM OutExprStuff) + -> SimplM OutExprStuff + +-- Simplify the arguments to a call. +-- This part of the simplifier may break the no-shadowing invariant +-- Consider +-- f (...(\a -> e)...) (case y of (a,b) -> e') +-- where f is strict in its second arg +-- If we simplify the innermost one first we get (...(\a -> e)...) +-- Simplifying the second arg makes us float the case out, so we end up with +-- case y of (a,b) -> f (...(\a -> e)...) e' +-- So the output does not have the no-shadowing invariant. However, there is +-- no danger of getting name-capture, because when the first arg was simplified +-- we used an in-scope set that at least mentioned all the variables free in its +-- static environment, and that is enough. +-- +-- We can't just do innermost first, or we'd end up with a dual problem: +-- case x of (a,b) -> f e (...(\a -> e')...) +-- +-- I spent hours trying to recover the no-shadowing invariant, but I just could +-- not think of an elegant way to do it. The simplifier is already knee-deep in +-- continuations. We have to keep the right in-scope set around; AND we have +-- to get the effect that finding (error "foo") in a strict arg position will +-- discard the entire application and replace it with (error "foo"). Getting +-- all this at once is TOO HARD! + +simplifyArgs is_data_con args cont_ty thing_inside + | not is_data_con + = go args thing_inside + + | otherwise -- It's a data constructor, so we want + -- to switch off inlining in the arguments -- If we don't do this, consider: -- let x = +# p q in C {x} -- Even though x get's an occurrence of 'many', its RHS looks cheap, -- and there's a good chance it'll get inlined back into C's RHS. Urgh! - -- - -- It's important that the substitution *does* deal with case-binder synonyms: - -- case x of y { True -> (x,1) } - -- Here we must be sure to substitute y for x when simplifying the args of the pair, - -- to increase the chances of being able to inline x. The substituter will do - -- that because the x->y mapping is held in the in-scope set. - in - -- It's not always the case that the new arg will be trivial - -- Consider f x - -- where, in one pass, f gets substituted by a constructor, - -- but x gets substituted by an expression (assume this is the - -- unique occurrence of x). It doesn't really matter -- it'll get - -- fixed up next pass. And it happens for dictionary construction, - -- which mentions the wrapper constructor to start with. - - go (new_arg : acc) ds' res_ty cont - - | otherwise - = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg -> - -- A data constructor whose argument is now non-trivial; - -- so let/case bind it. - newId arg_ty $ \ arg_id -> - addNonRecBind arg_id new_arg $ - go (Var arg_id : acc) ds' res_ty cont + = getBlackList `thenSmpl` \ old_bl -> + setBlackList noInlineBlackList $ + go args $ \ args' -> + setBlackList old_bl $ + thing_inside args' - where - (arg_ty, res_ty) = splitFunTy fun_ty - (dem, ds') = case ds of - [] -> (wwLazy, []) - (d:ds) -> (d,ds) - - -- We're run out of arguments and the result ain't bottom - go acc ds fun_ty cont = thing_inside (reverse acc) cont - --- Boring: we must only record a tick if there was an interesting --- continuation to discard. If not, we tick forever. -tick_case_of_error (Stop _) = returnSmpl () -tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl () -tick_case_of_error other = tick BottomFound -\end{code} + where + go [] thing_inside = thing_inside [] + go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' -> + go args $ \ args' -> + thing_inside (arg':args') + +simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside + = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg -> + thing_inside (Type new_ty_arg) + +simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside + = getInScope `thenSmpl` \ in_scope -> + let + arg_ty = substTy (mkSubst in_scope se) (exprType val_arg) + in + if not is_data_con then + -- An ordinary function + simplValArg arg_ty is_strict val_arg se cont_ty thing_inside + else + -- A data constructor + -- simplifyArgs has already switched off inlining, so + -- all we have to do here is to let-bind any non-trivial argument + + -- It's not always the case that new_arg will be trivial + -- Consider f x + -- where, in one pass, f gets substituted by a constructor, + -- but x gets substituted by an expression (assume this is the + -- unique occurrence of x). It doesn't really matter -- it'll get + -- fixed up next pass. And it happens for dictionary construction, + -- which mentions the wrapper constructor to start with. + simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' -> + + if exprIsTrivial arg' then + thing_inside arg' + else + newId SLIT("a") (exprType arg') $ \ arg_id -> + addNonRecBind arg_id arg' $ + thing_inside (Var arg_id) +\end{code} %************************************************************************ @@ -930,7 +931,7 @@ even if they occur exactly once. Reason: (a) some might appear as a function argument, so we simply replace static allocation with dynamic allocation: l = <...> - x = f x + x = f l becomes x = f <...> @@ -971,35 +972,6 @@ preInlineUnconditionally black_listed bndr OneOcc in_lam once -> not in_lam && once -- Not inside a lambda, one occurrence ==> safe! other -> False - - -postInlineUnconditionally :: Bool -- Black listed - -> OccInfo - -> InId -> OutExpr -> Bool - -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified - -- It returns True if it's ok to discard the binding and inline the - -- RHS at every use site. - - -- NOTE: This isn't our last opportunity to inline. - -- We're at the binding site right now, and - -- we'll get another opportunity when we get to the ocurrence(s) - -postInlineUnconditionally black_listed occ_info bndr rhs - | isExportedId bndr || - black_listed || - isLoopBreaker occ_info = False -- Don't inline these - | otherwise = exprIsTrivial rhs -- Duplicating is free - -- Don't inline even WHNFs inside lambdas; doing so may - -- simply increase allocation when the function is called - -- This isn't the last chance; see NOTE above. - -- - -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here - -- Why? Because we don't even want to inline them into the - -- RHS of constructor arguments. See NOTE above - -- - -- NB: Even NOINLINEis ignored here: if the rhs is trivial - -- it's best to inline it anyway. We often get a=E; b=a - -- from desugaring, with both a and b marked NOINLINE. \end{code} @@ -1021,7 +993,7 @@ rebuild_done expr rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff -- Stop continuation -rebuild expr (Stop _) = rebuild_done expr +rebuild expr (Stop _ _) = rebuild_done expr -- ArgOf continuation rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr @@ -1271,13 +1243,14 @@ prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSm -- (using funResultTy) in mkDupableCont. \end{code} -simplCaseBinder checks whether the scrutinee is a variable, v. -If so, 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. +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +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. -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: +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 @@ -1345,10 +1318,10 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts let ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars mk uniq tv = mkSysTyVar uniq (tyVarKind tv) + arg_tys = dataConArgTys data_con + (inst_tys ++ mkTyVarTys ex_tyvars') in - newIds (dataConArgTys - data_con - (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs -> + newIds SLIT("a") arg_tys $ \ bndrs -> returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) other -> returnSmpl filtered_alts @@ -1358,7 +1331,7 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts [] -> alts other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)] - missing_cons = [data_con | data_con <- tyConDataCons tycon, + missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon, not (data_con `elem` handled_data_cons)] handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ [data_con | (DataAlt data_con, _, _) <- filtered_alts] @@ -1372,8 +1345,7 @@ prepareCaseAlts _ _ scrut_cons alts simplAlts zap_occ_info scrut_cons case_bndr' alts cont' = mapSmpl simpl_alt alts where - inst_tys' = case splitTyConApp_maybe (idType case_bndr') of - Just (tycon, inst_tys) -> inst_tys + 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 @@ -1452,13 +1424,16 @@ mkDupableCont ty (InlinePlease cont) thing_inside mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside = -- Build the RHS of the join point - newId join_arg_ty ( \ arg_id -> + newId SLIT("a") join_arg_ty ( \ arg_id -> cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation - newId (exprType join_rhs) $ \ join_id -> + -- 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) $ \ join_id -> let new_cont = ArgOf OkToDup cont_ty (\arg' -> rebuild_done (App (Var join_id) arg')) @@ -1468,7 +1443,8 @@ mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside -- Want to tick here so that we go round again, -- and maybe copy or inline the code; -- not strictly CaseOf Case - addLetBind join_id join_rhs (thing_inside new_cont) + addLetBind (NonRec join_id join_rhs) $ + thing_inside new_cont mkDupableCont ty (ApplyTo _ arg se cont) thing_inside = mkDupableCont (funResultTy ty) cont $ \ cont' -> @@ -1476,14 +1452,14 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside if exprIsDupable arg' then thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') else - newId (exprType arg') $ \ bndr -> + newId SLIT("a") (exprType arg') $ \ bndr -> - tick (CaseOfCase bndr) `thenSmpl_` + tick (CaseOfCase bndr) `thenSmpl_` -- Want to tick here so that we go round again, -- and maybe copy or inline the code; -- not strictly CaseOf Case - addLetBind bndr arg' $ + addLetBind (NonRec bndr arg') $ -- But what if the arg should be case-bound? We can't use -- addNonRecBind here because its type is too specific. -- This has been this way for a long time, so I'll leave it, @@ -1501,7 +1477,7 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside returnSmpl (concat alt_binds_s, alts') ) `thenSmpl` \ (alt_binds, alts') -> - extendInScopes [b | NonRec b _ <- alt_binds] $ + addAuxiliaryBinds alt_binds $ -- NB that the new alternatives, alts', are still InAlts, using the original -- binders. That means we can keep the case_bndr intact. This is important @@ -1510,15 +1486,14 @@ mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside -- This is VITAL when the type of case_bndr is an unboxed pair (often the -- case in I/O rich code. We aren't allowed a lambda bound -- arg of unboxed tuple type, and indeed such a case_bndr is always dead - addLetBinds alt_binds $ - thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) + thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont))) mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt) mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) = simplBinders bndrs $ \ bndrs' -> simplExprC rhs cont `thenSmpl` \ rhs' -> - if (case cont of { Stop _ -> exprIsDupable rhs'; other -> False}) then + if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then -- It is worth checking for a small RHS because otherwise we -- get extra let bindings that may cause an extra iteration of the simplifier to -- inline back in place. Quite often the rhs is just a variable or constructor. @@ -1574,19 +1549,39 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) -- then 78 -- else 5 - then newId realWorldStatePrimTy $ \ rw_id -> + then newId SLIT("w") realWorldStatePrimTy $ \ rw_id -> returnSmpl ([rw_id], [Var realWorldPrimId]) else returnSmpl (used_bndrs', map varToCoreExpr used_bndrs) ) `thenSmpl` \ (final_bndrs', final_args) -> - newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> - - -- Notice that we make the lambdas into one-shot-lambdas. The + -- See comment about "$j" name above + newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr -> + -- Notice the funky mkPiType. 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 + -- data T = forall t. C [t] + -- Then faced with + -- case (case e of ...) of + -- C t xs::[t] -> rhs + -- We get the join point + -- let j :: forall t. [t] -> ... + -- j = /\t \xs::[t] -> rhs + -- in + -- case (case e of ...) of + -- C t xs::[t] -> j t xs + + let + -- We make the lambdas into one-shot-lambdas. The -- join point is sure to be applied at most once, and doing so -- prevents the body of the join point being floated out by -- the full laziness pass - returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')], + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + in + returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')], (con, bndrs, mkApps (Var join_bndr) final_args)) \end{code}