X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=1a217043262624cd7e5c518a8f108f7e0dcb2087;hp=23eec4917bfdc5f92b48553f78ab346c9a8687bd;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=bcadca676448e38427b910bad5d7063f948a99c8 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 23eec49..1a21704 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -27,7 +27,7 @@ module CoreUtils ( exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, - rhsIsStatic, + rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size coreBindsSize, exprSize, @@ -36,7 +36,10 @@ module CoreUtils ( hashExpr, -- * Equality - cheapEqExpr, + cheapEqExpr, eqExpr, eqExprX, + + -- * Eta reduction + tryEtaReduce, -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, @@ -61,6 +64,7 @@ import DataCon import PrimOp import Id import IdInfo +import TcType ( isPredTy ) import Type import Coercion import TyCon @@ -108,7 +112,7 @@ coreAltType (_,bs,rhs) where ty = exprType rhs free_tvs = tyVarsOfType ty - bad_binder b = isTyVar b && b `elemVarSet` free_tvs + bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives @@ -141,10 +145,10 @@ Various possibilities suggest themselves: we are doing here. It's not too expensive, I think. \begin{code} -mkPiType :: Var -> Type -> Type +mkPiType :: EvVar -> Type -> Type -- ^ Makes a @(->)@ type or a forall type, depending -- on whether it is given a type variable or a term variable. -mkPiTypes :: [Var] -> Type -> Type +mkPiTypes :: [EvVar] -> Type -> Type -- ^ 'mkPiType' for multiple type or value arguments mkPiType v ty @@ -194,7 +198,7 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty \begin{code} -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr -mkCoerceI IdCo e = e +mkCoerceI (IdCo _) e = e mkCoerceI (ACo co) e = mkCoerce co e -- | Wrap the given expression in the coercion safely, coalescing nested coercions @@ -210,7 +214,7 @@ mkCoerce co expr -- if to_ty `coreEqType` from_ty -- then expr -- else - ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) + WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) (Cast expr co) \end{code} @@ -468,8 +472,8 @@ dupAppSize = 4 -- Size of application we are prepared to duplicate %* * %************************************************************************ -Note [exprIsCheap] -~~~~~~~~~~~~~~~~~~ +Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs @exprIsCheap@ looks at a Core expression and returns \tr{True} if it is obviously in weak head normal form, or is cheap to get to WHNF. [Note that that's not the same as exprIsDupable; an expression might be @@ -498,28 +502,46 @@ shared. The main examples of things which aren't WHNF but are Notice that a variable is considered 'cheap': we can push it inside a lambda, because sharing will make sure it is only evaluated once. +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + \begin{code} -exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Var _) = True -exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x - || exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && - and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts] +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheap' isCheapApp + +exprIsExpandable :: CoreExpr -> Bool +exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes + + +exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e + +exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && + and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) -- This improves arities of overloaded functions where -- there is only dictionary selection (no construction) involved -exprIsCheap' is_conlike (Let (NonRec x _) e) - | isUnLiftedType (idType x) = exprIsCheap' is_conlike e - | otherwise = False - -- strict lets always have cheap right hand sides, - -- and do no allocation. -exprIsCheap' is_conlike other_expr -- Applications and variables +exprIsCheap' good_app (Let (NonRec x _) e) + | isUnLiftedType (idType x) = exprIsCheap' good_app e + | otherwise = False + -- Strict lets always have cheap right hand sides, + -- and do no allocation, so just look at the body + -- Non-strict lets do allocation so we don't treat them as cheap + -- See also + +exprIsCheap' good_app other_expr -- Applications and variables = go other_expr [] where -- Accumulate value arguments, then decide @@ -530,14 +552,12 @@ exprIsCheap' is_conlike other_expr -- Applications and variables -- (f t1 t2 t3) counts as WHNF go (Var f) args = case idDetails f of - RecSelId {} -> go_sel args - ClassOpId {} -> go_sel args - PrimOpId op -> go_primop op args - - _ | is_conlike f -> go_pap args - | length args < idArity f -> go_pap args - - _ -> isBottomingId f + RecSelId {} -> go_sel args + ClassOpId {} -> go_sel args + PrimOpId op -> go_primop op args + _ | good_app f (length args) -> go_pap args + | isBottomingId f -> True + | otherwise -> False -- Application of a function which -- always gives bottom; we treat this as cheap -- because it certainly doesn't need to be shared! @@ -552,26 +572,53 @@ exprIsCheap' is_conlike other_expr -- Applications and variables -- We'll put up with one constructor application, but not dozens -------------- - go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args + go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args -- In principle we should worry about primops -- that return a type variable, since the result -- might be applied to something, but I'm not going -- to bother to check the number of args -------------- - go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection + go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection go_sel _ = False -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection. -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) -exprIsCheap :: CoreExpr -> Bool -exprIsCheap = exprIsCheap' isDataConWorkId +isCheapApp :: Id -> Int -> Bool +isCheapApp fn n_val_args + = isDataConWorkId fn + || n_val_args < idArity fn -exprIsExpandable :: CoreExpr -> Bool -exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in BasicTypes +isExpandableApp :: Id -> Int -> Bool +isExpandableApp fn n_val_args + = isConLikeId fn + || n_val_args < idArity fn + || go n_val_args (idType fn) + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + go 0 _ = True + go n_val_args ty + | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty + | Just (arg, ty) <- splitFunTy_maybe ty + , isPredTy arg = go (n_val_args-1) ty + | otherwise = False \end{code} +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + %************************************************************************ %* * exprOkForSpeculation @@ -589,11 +636,8 @@ exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in Basi -- Precisely, it returns @True@ iff: -- -- * The expression guarantees to terminate, --- -- * soon, --- -- * without raising an exception, --- -- * without causing a side effect (e.g. writing a mutable variable) -- -- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@. @@ -619,6 +663,11 @@ exprOkForSpeculation (Var v) = isUnLiftedType (idType v) && not (isTickBoxOp v) exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e _) = exprOkForSpeculation e + +exprOkForSpeculation (Case e _ _ alts) + = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts + exprOkForSpeculation other_expr = case collectArgs other_expr of (Var f, args) -> spec_ok (idDetails f) args @@ -663,6 +712,36 @@ isDivOp DoubleDivOp = True isDivOp _ = False \end{code} +Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It's always sound for exprOkForSpeculation to return False, and we +don't want it to take too long, so it bales out on complicated-looking +terms. Notably lets, which can be stacked very deeply; and in any +case the argument of exprOkForSpeculation is usually in a strict context, +so any lets will have been floated away. + +However, we keep going on case-expressions. An example like this one +showed up in DPH code: + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +If exprOkForSpeculation doesn't look through case expressions, you get this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Bool.False -> lvl1; + GHC.Bool.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 + } + +The inner case is redundant, and should be nuked. + + %************************************************************************ %* * exprIsHNF, exprIsConLike @@ -670,7 +749,7 @@ isDivOp _ = False %************************************************************************ \begin{code} --- Note [exprIsHNF] +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] -- ~~~~~~~~~~~~~~~~ -- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok @@ -725,8 +804,9 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value - -- A worry: what if an Id's unfolding is just itself: - -- then we could get an infinite loop... + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop is_hnf_like (Lit _) = True is_hnf_like (Type _) = True -- Types are honorary Values; @@ -736,6 +816,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e (Type _)) = is_hnf_like e is_hnf_like (App e a) = app_is_value e [a] + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like _ = False -- There is at least one value argument @@ -875,7 +956,9 @@ cheapEqExpr (Cast e1 t1) (Cast e2 t2) = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 cheapEqExpr _ _ = False +\end{code} +\begin{code} exprIsBig :: Expr b -> Bool -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False @@ -887,6 +970,86 @@ exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig _ = True \end{code} +\begin{code} +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = eqExprX id_unf (mkRnEnv2 in_scope) e1 e2 + where + id_unf _ = noUnfolding -- Don't expand +\end{code} + +\begin{code} +eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool +-- ^ Compares expressions for equality, modulo alpha. +-- Does /not/ look through newtypes or predicate types +-- Used in rule matching, and also CSE + +eqExprX id_unfolding_fun env e1 e2 + = go env e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + -- The next two rules expand non-local variables + -- C.f. Note [Expanding variables] in Rules.lhs + -- and Note [Do not expand locally-bound variables] in Rules.lhs + go env (Var v1) e2 + | not (locallyBoundL env v1) + , Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1)) + = go (nukeRnEnvL env) e1' e2 + + go env e1 (Var v2) + | not (locallyBoundR env v2) + , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2)) + = go (nukeRnEnvR env) e1 e2' + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = tcEqTypeX env t1 t2 + go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) + = go env e1 e2 + && tcEqTypeX env (idType b1) (idType b2) + && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + + ----------- + go_note (SCC cc1) (SCC cc2) = cc1 == cc2 + go_note (CoreNote s1) (CoreNote s2) = s1 == s2 + go_note _ _ = False +\end{code} + +Auxiliary functions + +\begin{code} +locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool +locallyBoundL rn_env v = inRnEnvL rn_env v +locallyBoundR rn_env v = inRnEnvR rn_env v +\end{code} %************************************************************************ @@ -917,7 +1080,7 @@ noteSize (SCC cc) = cc `seq` 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int -varSize b | isTyVar b = 1 +varSize b | isTyCoVar b = 1 | otherwise = seqType (idType b) `seq` megaSeqIdInfo (idInfo b) `seq` 1 @@ -1001,6 +1164,100 @@ hashVar (_,env) v = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v)) \end{code} + +%************************************************************************ +%* * + Eta reduction +%* * +%************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try for eta reduction here, but *only* if we get all the way to an +trivial expression. We don't want to remove extra lambdas unless we +are going to avoid allocating this thing altogether. + +There are some particularly delicate points here: + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it + *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands + the definition again, so that it does not termninate after all. + Result: seg-fault because the boolean case actually gets a function value. + See Trac #1947. + + So it's important to to the right thing. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in SimplEnv) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminiating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity; and for primops we + must, since they have no unfolding. + +* Regardless of whether 'f' is a value, we always want to + reduce (/\a -> f a) to f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc isDictId + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +\begin{code} +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body + where + incoming_arity = count isId bndrs + + go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round + go [] fun | ok_fun fun = Just fun -- Success! + go _ _ = Nothing -- Failure! + + -- Note [Eta reduction conditions] + ok_fun (App fun (Type ty)) + | not (any (`elemVarSet` tyVarsOfType ty) bndrs) + = ok_fun fun + ok_fun (Var fun_id) + = not (fun_id `elem` bndrs) + && (ok_fun_id fun_id || all ok_lam bndrs) + ok_fun _fun = False + + ok_fun_id fun = fun_arity fun >= incoming_arity + + fun_arity fun -- See Note [Arity care] + | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0 + | otherwise = idArity fun + + ok_lam v = isTyCoVar v || isDictId v + + ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg +\end{code} + %************************************************************************ %* * \subsection{Determining non-updatable right-hand-sides}