-- 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"
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
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)
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