-- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
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 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 )
\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}
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}
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)
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 ->
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