exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
- rhsIsStatic,
+ rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size
coreBindsSize, exprSize,
hashExpr,
-- * Equality
- cheapEqExpr,
+ cheapEqExpr, eqExpr, eqExprX,
+
+ -- * Eta reduction
+ tryEtaReduce,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
import PrimOp
import Id
import IdInfo
+import TcType ( isPredTy )
import Type
import Coercion
import TyCon
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
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
\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
-- 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}
%* *
%************************************************************************
-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
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
-- (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!
-- 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
-- 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@.
&& 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
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
%************************************************************************
\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
|| 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;
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
= 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
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}
%************************************************************************
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
= 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}
projects / ghc-hetmet.git / blobdiff