X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=371a0c78e2c9f0080dece73493def9cf43f6cf99;hb=b0604aad2c311d8713c2497afa6373bd938d501b;hp=05c989cc84631a9a04ea9b7bd5217fa3ccbab459;hpb=243dedb8741d13162fe944ebf2adace921e0108d;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 05c989c..371a0c7 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -5,9 +5,9 @@ \begin{code} module SimplUtils ( - simplBinder, simplBinders, simplIds, - transformRhs, - mkCase, findAlt, findDefault, + simplBinder, simplBinders, simplRecIds, simplLetId, + tryRhsTyLam, tryEtaExpansion, + mkCase, -- The continuation type SimplCont(..), DupFlag(..), contIsDupable, contResultType, @@ -19,30 +19,34 @@ module SimplUtils ( #include "HsVersions.h" import CmdLineOpts ( switchIsOn, SimplifierSwitch(..), - opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict, + opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn -import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec ) -import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr ) +import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, + etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce, + findDefault + ) +import Subst ( InScopeSet, mkSubst, substExpr ) +import qualified Subst ( simplBndrs, simplBndr, simplLetId ) import Id ( idType, idName, - idUnfolding, idStrictness, - mkId, idInfo + idUnfolding, idNewStrictness, + mkLocalId, idInfo ) -import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo ) +import IdInfo ( StrictnessInfo(..) ) import Maybes ( maybeToBool, catMaybes ) import Name ( setNameUnique ) -import Demand ( isStrict ) +import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, mkForAllTys, seqType, repType, - splitTyConApp_maybe, mkTyVarTys, splitFunTys, - isDictTy, isDataType, isUnLiftedType, +import Type ( Type, mkForAllTys, seqType, + splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, + isUnLiftedType, isStrictType, splitRepFunTys ) import TyCon ( tyConDataConsIfAvailable ) import DataCon ( dataConRepArity ) import VarEnv ( SubstEnv ) -import Util ( lengthExceeds ) +import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -225,8 +229,8 @@ getContArgs fun orig_cont -- after that number of value args have been consumed -- Otherwise it's infinite, extended with False fun_stricts - = case idStrictness fun of - StrictnessInfo demands result_bot + = case splitStrictSig (idNewStrictness fun) of + (demands, result_info) | not (demands `lengthExceeds` countValArgs orig_cont) -> -- Enough args, use the strictness given. -- For bottoming functions we used to pretend that the arg @@ -235,26 +239,13 @@ getContArgs fun orig_cont -- 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) - if result_bot then - map isStrict demands -- Finite => result is bottom + if isBotRes result_info then + map isStrictDmd demands -- Finite => result is bottom else - map isStrict demands ++ vanilla_stricts + map isStrictDmd demands ++ vanilla_stricts other -> vanilla_stricts -- Not enough args, or no strictness - -------------------- -isStrictType :: Type -> Bool - -- isStrictType computes whether an argument (or let RHS) should - -- be computed strictly or lazily, based only on its type -isStrictType ty - | isUnLiftedType ty = True - | opt_DictsStrict && isDictTy ty && isDataType ty = True - | otherwise = False - -- 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) - ------------------- interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool -- An argument is interesting if it has *some* structure @@ -365,7 +356,10 @@ interestingCallContext some_args some_val_args cont where interesting (InlinePlease _) = True interesting (Select _ _ _ _ _) = some_args - interesting (ApplyTo _ _ _ _) = some_args -- Can happen if we have (coerce t (f x)) y + interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y + -- Perhaps True is a bit over-keen, but I've + -- seen (coerce f) x, where f has an INLINE prag, + -- So we have to give some motivaiton for inlining it interesting (ArgOf _ _ _) = some_val_args interesting (Stop ty upd_in_place) = some_val_args && upd_in_place interesting (CoerceIt _ cont) = interesting cont @@ -395,21 +389,16 @@ canUpdateInPlace :: Type -> Bool -- small arity. But arity zero isn't good -- we share the single copy -- for that case, so no point in sharing. --- Note the repType: we want to look through newtypes for this purpose - canUpdateInPlace ty | not opt_UF_UpdateInPlace = False | otherwise - = case splitTyConApp_maybe (repType ty) of { - Nothing -> False ; - Just (tycon, _) -> - - case tyConDataConsIfAvailable tycon of - [dc] -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc - other -> False - } + = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, _) -> case tyConDataConsIfAvailable tycon of + [dc] -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc + other -> False \end{code} @@ -425,7 +414,7 @@ simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a simplBinders bndrs thing_inside = getSubst `thenSmpl` \ subst -> let - (subst', bndrs') = substBndrs subst bndrs + (subst', bndrs') = Subst.simplBndrs subst bndrs in seqBndrs bndrs' `seq` setSubst subst' (thing_inside bndrs') @@ -434,23 +423,29 @@ simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a simplBinder bndr thing_inside = getSubst `thenSmpl` \ subst -> let - (subst', bndr') = substBndr subst bndr + (subst', bndr') = Subst.simplBndr subst bndr in seqBndr bndr' `seq` setSubst subst' (thing_inside bndr') --- Same semantics as simplBinders, but a little less --- plumbing and hence a little more efficient. --- Maybe not worth the candle? -simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a -simplIds ids thing_inside +simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a +simplRecIds ids thing_inside = getSubst `thenSmpl` \ subst -> let - (subst', bndrs') = substIds subst ids + (subst', ids') = mapAccumL Subst.simplLetId subst ids in - seqBndrs bndrs' `seq` - setSubst subst' (thing_inside bndrs') + seqBndrs ids' `seq` + setSubst subst' (thing_inside ids') + +simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a +simplLetId id thing_inside + = getSubst `thenSmpl` \ subst -> + let + (subst', id') = Subst.simplLetId subst id + in + seqBndr id' `seq` + setSubst subst' (thing_inside id') seqBndrs [] = () seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs @@ -464,26 +459,6 @@ seqBndr b | isTyVar b = b `seq` () %************************************************************************ %* * -\subsection{Transform a RHS} -%* * -%************************************************************************ - -Try (a) eta expansion - (b) type-lambda swizzling - -\begin{code} -transformRhs :: OutExpr - -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) - -transformRhs rhs thing_inside - = tryRhsTyLam rhs $ \ rhs1 -> - tryEtaExpansion rhs1 thing_inside -\end{code} - - -%************************************************************************ -%* * \subsection{Local tyvar-lifting} %* * %************************************************************************ @@ -553,30 +528,34 @@ as we would normally do. \begin{code} -tryRhsTyLam rhs thing_inside -- Only does something if there's a let - | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that - = thing_inside rhs +tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr) + +tryRhsTyLam rhs -- Only does something if there's a let + | null tyvars || not (worth_it body) -- inside a type lambda, + = returnSmpl ([], rhs) -- and a WHNF inside that + | otherwise - = go (\x -> x) body $ \ body' -> - thing_inside (mkLams tyvars body') + = go (\x -> x) body `thenSmpl` \ (binds, body') -> + returnSmpl (binds, mkLams tyvars body') where (tyvars, body) = collectTyBinders rhs - worth_it (Let _ e) = whnf_in_middle e - worth_it other = False + worth_it e@(Let _ _) = whnf_in_middle e + worth_it e = False + + whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False whnf_in_middle (Let _ e) = whnf_in_middle e whnf_in_middle e = exprIsCheap e - - go fn (Let bind@(NonRec var rhs) body) thing_inside + go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs - = go (fn . Let bind) body thing_inside + = go (fn . Let bind) body - go fn (Let bind@(NonRec var rhs) body) thing_inside - = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') -> - addAuxiliaryBind (NonRec var' (mkLams tyvars_here (fn rhs))) $ - go (fn . Let (mk_silly_bind var rhs')) body thing_inside + go fn (Let (NonRec var rhs) body) + = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') -> + go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ (binds, body') -> + returnSmpl (NonRec var' (mkLams tyvars_here (fn rhs)) : binds, body') where tyvars_here = tyvars @@ -599,13 +578,14 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- abstracting wrt *all* the tyvars. We'll see if that -- gives rise to problems. SLPJ June 98 - go fn (Let (Rec prs) body) thing_inside + go fn (Let (Rec prs) body) = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') -> let - gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss')) + gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss')) + new_bind = Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]) in - addAuxiliaryBind (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) $ - go gn body thing_inside + go gn body `thenSmpl` \ (binds, body') -> + returnSmpl (new_bind : binds, body') where (vars,rhss) = unzip prs tyvars_here = tyvars @@ -613,15 +593,14 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- var_tys = map idType vars -- See notes with tyvars_here above - - go fn body thing_inside = thing_inside (fn body) + go fn body = returnSmpl ([], fn body) mk_poly tyvars_here var = getUniqueSmpl `thenSmpl` \ uniq -> let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course - poly_id = mkId poly_name poly_ty vanillaIdInfo + poly_id = mkLocalId poly_name poly_ty -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! @@ -635,24 +614,29 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- where x* has an INLINE prag on it. Now, once x* is inlined, -- the occurrences of x' will be just the occurrences originally -- pinned on x. - -- poly_info = vanillaIdInfo `setOccInfo` idOccInfo var in returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here)) - mk_silly_bind var rhs = NonRec var rhs + mk_silly_bind var rhs = NonRec var (Note InlineMe rhs) -- Suppose we start with: -- - -- x = let g = /\a -> \x -> f x x - -- in - -- /\ b -> let g* = g b in E + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E -- - -- Then: * the binding for g gets floated out - -- * but then it MIGHT get inlined into the rhs of g* - -- * then the binding for g* is floated out of the /\b - -- * so we're back to square one - -- We rely on the simplifier not to inline g into the RHS of g*, - -- because it's a "lone" occurrence, and there is no benefit in - -- inlining. But it's a slightly delicate property; hence this comment + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) \end{code} @@ -688,82 +672,45 @@ There is no point in looking for a combination of the two, because that would leave use with some lets sandwiched between lambdas; that's what the final test in the first equation is for. -\begin{code} -tryEtaExpansion :: OutExpr - -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) - -> SimplM (OutStuff a) -tryEtaExpansion rhs thing_inside - | not opt_SimplDoLambdaEtaExpansion - || null y_tys -- No useful expansion - || not (is_case1 || is_case2) -- Neither case matches - = thing_inside final_arity rhs -- So, no eta expansion, but - -- return a good arity - - | is_case1 - = make_y_bndrs $ \ y_bndrs -> - thing_inside final_arity - (mkLams x_bndrs $ mkLams y_bndrs $ - mkApps body (map Var y_bndrs)) - - | otherwise -- Must be case 2 - = mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) -> - addAuxiliaryBinds (catMaybes maybe_z_binds) $ - make_y_bndrs $ \ y_bndrs -> - thing_inside final_arity - (mkLams y_bndrs $ - mkApps (mkApps fun z_args) (map Var y_bndrs)) - where - all_trivial_args = all is_trivial arg_infos - is_case1 = all_trivial_args - is_case2 = null x_bndrs && not (any unlifted_non_trivial arg_infos) - - (x_bndrs, body) = collectBinders rhs -- NB: x_bndrs can include type variables - x_arity = valBndrCount x_bndrs +In Case 1, we may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. - (fun, args) = collectArgs body - arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args] - - is_trivial (_, _, triv) = triv - unlifted_non_trivial (_, ty, triv) = not triv && isUnLiftedType ty - - fun_arity = exprEtaExpandArity fun +\begin{code} +tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr) +tryEtaExpansion rhs rhs_ty + | not opt_SimplDoLambdaEtaExpansion -- Not if switched off + || exprIsTrivial rhs -- Not if RHS is trivial + || final_arity == 0 -- Not if arity is zero + = returnSmpl ([], rhs) + + | n_val_args == 0 && not arity_is_manifest + = -- Some lambdas but not enough: case 1 + getUniqSupplySmpl `thenSmpl` \ us -> + returnSmpl ([], etaExpand final_arity us rhs rhs_ty) + + | n_val_args > 0 && not (any cant_bind arg_infos) + = -- Partial application: case 2 + mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) -> + getUniqSupplySmpl `thenSmpl` \ us -> + returnSmpl (catMaybes maybe_z_binds, + etaExpand final_arity us (mkApps fun z_args) rhs_ty) - final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted) - | otherwise = atLeastArity x_arity - -- Arity can be more than the number of lambdas - -- because of coerces. E.g. \x -> coerce t (\y -> e) - -- will have arity at least 2 - -- The worker/wrapper pass will bring the coerce out to the top + | otherwise + = returnSmpl ([], rhs) + where + (fun, args) = collectArgs rhs + n_val_args = valArgCount args + (fun_arity, arity_is_manifest) = exprEtaExpandArity fun + final_arity = 0 `max` (fun_arity - n_val_args) + arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args] + cant_bind (_, ty, triv) = not triv && isUnLiftedType ty bind_z_arg (arg, arg_ty, trivial_arg) | trivial_arg = returnSmpl (Nothing, arg) | otherwise = newId SLIT("z") arg_ty $ \ z -> returnSmpl (Just (NonRec z arg), Var z) - - make_y_bndrs thing_inside - = ASSERT( not (exprIsTrivial rhs) ) - newIds SLIT("y") y_tys $ \ y_bndrs -> - tick (EtaExpansion (head y_bndrs)) `thenSmpl_` - thing_inside y_bndrs - - (potential_extra_arg_tys, _) = splitFunTys (exprType body) - - y_tys :: [InType] - y_tys = take extra_args_wanted potential_extra_arg_tys - - extra_args_wanted :: Int -- Number of extra args we want - extra_args_wanted = 0 `max` (fun_arity - valArgCount args) - - -- We used to expand the arity to the previous arity fo the - -- function; but this is pretty dangerous. Consdier - -- f = \xy -> e - -- so that f has arity 2. Now float something into f's RHS: - -- f = let z = BIG in \xy -> e - -- The last thing we want to do now is to put some lambdas - -- outside, to get - -- f = \xy -> let z = BIG in e - -- - -- (bndr_arity - no_of_xs) `max` \end{code} @@ -809,11 +756,12 @@ mkCase scrut outer_bndr outer_alts -- Secondly, if you do, you get an infinite loop, because the bindNonRec -- in munge_rhs puts a case into the DEFAULT branch! where - new_alts = outer_alts_without_deflt ++ munged_inner_alts + new_alts = add_default maybe_inner_default + (outer_alts_without_deflt ++ inner_con_alts) + maybe_case_in_default = case findDefault outer_alts of (outer_alts_without_default, Just (Case (Var scrut_var) inner_bndr inner_alts)) - | outer_bndr == scrut_var -> Just (outer_alts_without_default, inner_bndr, inner_alts) other -> Nothing @@ -828,12 +776,17 @@ mkCase scrut outer_bndr outer_alts not (con `elem` outer_cons) -- Eliminate shadowed inner alts ] munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs + + (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts + + add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts + add_default Nothing alts = alts \end{code} Now the identity-case transformation: case e of ===> e - True -> True; + True -> True; False -> False and similar friends. @@ -842,41 +795,67 @@ and similar friends. mkCase scrut case_bndr alts | all identity_alt alts = tick (CaseIdentity case_bndr) `thenSmpl_` - returnSmpl scrut + returnSmpl (re_note scrut) where - identity_alt (DEFAULT, [], Var v) = v == case_bndr - identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs - (mkConApp con (map Type arg_tys ++ map varToCoreExpr args)) - identity_alt other = False - - arg_tys = case splitTyConApp_maybe (idType case_bndr) of - Just (tycon, arg_tys) -> arg_tys + identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args + + identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args) + identity_rhs (LitAlt lit) _ = Lit lit + identity_rhs DEFAULT _ = Var case_bndr + + arg_tys = map Type (tyConAppArgs (idType case_bndr)) + + -- We've seen this: + -- case coerce T e of x { _ -> coerce T' x } + -- And we definitely want to eliminate this case! + -- So we throw away notes from the RHS, and reconstruct + -- (at least an approximation) at the other end + de_note (Note _ e) = de_note e + de_note e = e + + -- re_note wraps a coerce if it might be necessary + re_note scrut = case head alts of + (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut + other -> scrut \end{code} -The catch-all case +The catch-all case. We do a final transformation that I've +occasionally seen making a big difference: -\begin{code} -mkCase other_scrut case_bndr other_alts - = returnSmpl (Case other_scrut case_bndr other_alts) -\end{code} + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +The case where this came up was like this (lib/std/PrelCError.lhs): -\begin{code} -findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) -findDefault [] = ([], Nothing) -findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) - ([], Just rhs) -findDefault (alt : alts) = case findDefault alts of - (alts', deflt) -> (alt : alts', deflt) - -findAlt :: AltCon -> [CoreAlt] -> CoreAlt -findAlt con alts - = go alts - where - go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - go (alt : alts) | matches alt = alt - | otherwise = go alts + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases - matches (DEFAULT, _, _) = True - matches (con1, _, _) = con == con1 + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +\begin{code} +mkCase other_scrut case_bndr other_alts + = returnSmpl (Case other_scrut case_bndr (mergeDefault other_alts)) + +mergeDefault (deflt_alt@(DEFAULT,_,deflt_rhs) : con_alts) + = deflt_alt : [alt | alt@(con,_,rhs) <- con_alts, not (rhs `cheapEqExpr` deflt_rhs)] + -- NB: we can neglect the binders because we won't get equality if the + -- binders are mentioned in rhs (no shadowing) +mergeDefault other_alts + = other_alts \end{code}