\begin{code}
module CoreUtils (
-- Construction
- mkNote, mkInlineMe, mkSCC, mkCoerce,
+ mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
bindNonRec, needsCaseBinding,
- mkIfThenElse, mkAltExpr, mkPiType,
+ mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
findDefault, findAlt, hasDefault,
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
-import GlaExts -- For `xori`
+import GLAEXTS -- For `xori`
import CoreSyn
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
import Name ( hashName )
-import Literal ( hashLiteral, literalType, litIsDupable )
+import Literal ( hashLiteral, literalType, litIsDupable, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo,
+import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
+import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
)
-import IdInfo ( LBVarInfo(..),
- GlobalIdDetails(..),
+import IdInfo ( GlobalIdDetails(..),
megaSeqIdInfo )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
- applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
+ applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
- splitTyConApp_maybe, eqType, funResultTy, applyTy
+ splitTyConApp_maybe, eqType, funResultTy, applyTy,
+ funResultTy, applyTy
)
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
+import Util ( equalLength, lengthAtLeast )
+import TysPrim ( statePrimTyCon )
\end{code}
case of a term variable.
\begin{code}
-mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v = (case idLBVarInfo v of
- LBVarInfo u -> mkUTy u
- otherwise -> id) $
- mkFunTy (idType v) ty
- | isTyVar v = mkForAllTy v ty
+mkPiType :: Var -> Type -> Type -- The more polymorphic version
+mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
+
+mkPiTypes vs ty = foldr mkPiType ty vs
+
+mkPiType v ty
+ | isId v = mkFunTy (idType v) ty
+ | otherwise = mkForAllTy v ty
\end{code}
\begin{code}
--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg = funResultTy fun_ty
+
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+-- A more efficient version of applyTypeToArg
+-- when we have several args
+-- The first argument is just for debugging
applyTypeToArgs e op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
- applyTypeToArgs e (applyTys op_ty tys) rest_args
+ go [ty] args
where
- (tys, rest_args) = go [ty] args
- go tys (Type ty : args) = go (ty:tys) args
- go tys rest_args = (reverse tys, rest_args)
+ go rev_tys (Type ty : args) = go (ty:rev_tys) args
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTys op_ty (reverse rev_tys)
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
\begin{code}
mkNote :: Note -> CoreExpr -> CoreExpr
-mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
+mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
mkNote (SCC cc) expr = mkSCC cc expr
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
\begin{code}
-mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
-mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty `eqType` to_ty2 )
- mkCoerce to_ty from_ty2 expr
+ mkCoerce2 to_ty from_ty2 expr
-mkCoerce to_ty from_ty expr
+mkCoerce2 to_ty from_ty expr
| to_ty `eqType` from_ty = expr
| otherwise = ASSERT( from_ty `eqType` exprType expr )
Note (Coerce to_ty from_ty) expr
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation other_expr
- = go other_expr 0 True
+ = case collectArgs other_expr of
+ (Var f, args) -> spec_ok (globalIdDetails f) args
+ other -> False
+
where
- go (Var f) n_args args_ok
- = case globalIdDetails f of
- DataConId _ -> True -- The strictness of the constructor has already
- -- been expressed by its "wrapper", so we don't need
- -- to take the arguments into account
-
- PrimOpId op -> primOpOkForSpeculation op && args_ok
+ spec_ok (DataConId _) args
+ = True -- The strictness of the constructor has already
+ -- been expressed by its "wrapper", so we don't need
+ -- to take the arguments into account
+
+ spec_ok (PrimOpId op) args
+ | isDivOp op, -- Special case for dividing operations that fail
+ [arg1, Lit lit] <- args -- only if the divisor is zero
+ = not (isZeroLit lit) && exprOkForSpeculation arg1
+ -- Often there is a literal divisor, and this
+ -- can get rid of a thunk in an inner looop
+
+ | otherwise
+ = primOpOkForSpeculation op &&
+ all exprOkForSpeculation args
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- other -> False
-
- go (App f a) n_args args_ok
- | not (isRuntimeArg a) = go f n_args args_ok
- | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
-
- go other n_args args_ok = False
+ spec_ok other args = False
+
+isDivOp :: PrimOp -> Bool
+-- True of dyadic operators that can fail
+-- only if the second arg is zero
+-- This function probably belongs in PrimOp, or even in
+-- an automagically generated file.. but it's such a
+-- special case I thought I'd leave it here for now.
+isDivOp IntQuotOp = True
+isDivOp IntRemOp = True
+isDivOp WordQuotOp = True
+isDivOp WordRemOp = True
+isDivOp IntegerQuotRemOp = True
+isDivOp IntegerDivModOp = True
+isDivOp FloatDivOp = True
+isDivOp DoubleDivOp = True
+isDivOp other = False
\end{code}
\begin{code}
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
-exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
- -- copying them
-exprIsValue (Lit l) = True
-exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
-exprIsValue (Note _ e) = exprIsValue e
-exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
- -- The idArity case catches data cons and primops that
- -- don't have unfoldings
+exprIsValue (Var v) -- NB: There are no value args at this point
+ = isDataConId v -- Catches nullary constructors,
+ -- so that [] and () are values, for example
+ || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
+ || isEvaldUnfolding (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...
-exprIsValue other_expr
- | (Var fun, args) <- collectArgs other_expr,
- isDataConId fun || valArgCount args < idArity fun
- = check (idType fun) args
- | otherwise
- = False
+
+exprIsValue (Lit l) = True
+exprIsValue (Type ty) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
+exprIsValue (Note _ e) = exprIsValue e
+exprIsValue (App e (Type _)) = exprIsValue e
+exprIsValue (App e a) = app_is_value e [a]
+exprIsValue other = False
+
+-- There is at least one value argument
+app_is_value (Var fun) args
+ | isDataConId fun -- Constructor apps are values
+ || idArity fun > valArgCount args -- Under-applied function
+ = check_args (idType fun) args
+app_is_value (App f a) as = app_is_value f (a:as)
+app_is_value other as = False
+
+ -- 'check_args' checks that unlifted-type args
+ -- are in fact guaranteed non-divergent
+check_args fun_ty [] = True
+check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
+ Just (_, ty) -> check_args ty args
+check_args fun_ty (arg : args)
+ | isUnLiftedType arg_ty = exprOkForSpeculation arg
+ | otherwise = check_args res_ty args
where
- -- 'check' checks that unlifted-type args are in
- -- fact guaranteed non-divergent
- check fun_ty [] = True
- check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
- Just (_, ty) -> check ty args
- check fun_ty (arg : args)
- | isUnLiftedType arg_ty = exprOkForSpeculation arg
- | otherwise = check res_ty args
- where
- (arg_ty, res_ty) = splitFunTy fun_ty
+ (arg_ty, res_ty) = splitFunTy fun_ty
\end{code}
\begin{code}
arity = tyConArity tc
val_args = drop arity args
to_arg_tys = dataConArgTys dc tc_arg_tys
- mk_coerce ty arg = mkCoerce ty (exprType arg) arg
+ mk_coerce ty arg = mkCoerce ty arg
new_val_args = zipWith mk_coerce to_arg_tys val_args
in
ASSERT( all isTypeArg (take arity args) )
- ASSERT( length val_args == length to_arg_tys )
+ ASSERT( equalLength val_args to_arg_tys )
Just (dc, map Type tc_arg_tys ++ new_val_args)
}}
where
analyse (Var fun, args)
| Just con <- isDataConId_maybe fun,
- length args >= dataConRepArity con
+ args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
= Just (con,args)
-- use the idinfo here
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e)
+arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
| otherwise = arityType e
-- Applications; decrease arity
arityType (App f (Type _)) = arityType f
arityType (App f a) = case arityType f of
- AFun one_shot xs | one_shot -> xs
- | exprIsCheap a -> xs
+ AFun one_shot xs | exprIsCheap a -> xs
other -> ATop
-- Case/Let; keep arity if either the expression is cheap
arityType other = ATop
+isStateHack id = case splitTyConApp_maybe (idType id) of
+ Just (tycon,_) | tycon == statePrimTyCon -> True
+ other -> False
+
+ -- The last clause is a gross hack. It claims that
+ -- every function over realWorldStatePrimTy is a one-shot
+ -- function. This is pretty true in practice, and makes a big
+ -- difference. For example, consider
+ -- a `thenST` \ r -> ...E...
+ -- The early full laziness pass, if it doesn't know that r is one-shot
+ -- will pull out E (let's say it doesn't mention r) to give
+ -- let lvl = E in a `thenST` \ r -> ...lvl...
+ -- When `thenST` gets inlined, we end up with
+ -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
+ -- and we don't re-inline E.
+ --
+ -- It would be better to spot that r was one-shot to start with, but
+ -- I don't want to rely on that.
+ --
+ -- Another good example is in fill_in in PrelPack.lhs. We should be able to
+ -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
ok_note other = True
-- Given e' = etaExpand n us e ty
-- We should have
-- ty = exprType e = exprType e'
+--
+-- Note that SCCs are not treated specially. If we have
+-- etaExpand 2 (\x -> scc "foo" e)
+-- = (\xy -> (scc "foo" e) y)
+-- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
etaExpand n us expr ty
| manifestArity expr >= n = expr -- The no-op case
-- The ILX code generator requires eta expansion for type arguments
-- too, but alas the 'n' doesn't tell us how many of them there
-- may be. So we eagerly eta expand any big lambdas, and just
- -- cross our fingers about possible loss of sharing in the
- -- ILX case.
+ -- cross our fingers about possible loss of sharing in the ILX case.
-- The Right Thing is probably to make 'arity' include
-- type variables throughout the compiler. (ToDo.)
not (isForAllTy ty)
-- Saturated, so nothing to do
= expr
-eta_expand n us (Note note@(Coerce _ ty) e) _
- = Note note (eta_expand n us e ty)
-
- -- Use mkNote so that _scc_s get pushed inside any lambdas that
- -- are generated as part of the eta expansion. We rely on this
- -- behaviour in CorePrep, when we eta expand an already-prepped RHS.
-eta_expand n us (Note note e) ty
- = mkNote note (eta_expand n us e ty)
-
-- Short cut for the case where there already
-- is a lambda; no point in gratuitously adding more
eta_expand n us (Lam v body) ty
| otherwise
= Lam v (eta_expand (n-1) us body (funResultTy ty))
+-- We used to have a special case that stepped inside Coerces here,
+-- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
+-- = Note note (eta_expand n us e ty)
+-- BUT this led to an infinite loop
+-- Example: newtype T = MkT (Int -> Int)
+-- eta_expand 1 (coerce (Int->Int) e)
+-- --> coerce (Int->Int) (eta_expand 1 T e)
+-- by the bogus eqn
+-- --> coerce (Int->Int) (coerce T
+-- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
+-- by the splitNewType_maybe case below
+-- and round we go
+
eta_expand n us expr ty
= case splitForAllTy_maybe ty of {
Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
- arg1 = mkSysLocal SLIT("eta") uniq arg_ty
+ arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
(uniq:us2) = us
; Nothing ->
+ -- Given this:
+ -- newtype T = MkT (Int -> Int)
+ -- Consider eta-expanding this
+ -- eta_expand 1 e T
+ -- We want to get
+ -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
+
case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
+ Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{code}
go _ = 0
\end{code}
-
%************************************************************************
%* *
\subsection{Equality}
eq env (Let (NonRec v1 r1) e1)
(Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
eq env (Let (Rec ps1) e1)
- (Let (Rec ps2) e2) = length ps1 == length ps2 &&
+ (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
and (zipWith eq_rhs ps1 ps2) &&
eq env' e1 e2
where
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
eq env (Case e1 v1 a1)
(Case e2 v2 a2) = eq env e1 e2 &&
- length a1 == length a2 &&
+ equalLength a1 a2 &&
and (zipWith (eq_alt env') a1 a2)
where
env' = extendVarEnv env v1 v2
exprSize :: CoreExpr -> Int
-- A measure of the size of the expressions
-- It also forces the expression pretty drastically as a side effect
-exprSize (Var v) = varSize v
+exprSize (Var v) = v `seq` 1
exprSize (Lit lit) = lit `seq` 1
exprSize (App f a) = exprSize f + exprSize a
exprSize (Lam b e) = varSize b + exprSize e
projects / ghc-hetmet.git / blobdiff