X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=ab99d49a644d76cc52fe3a7b01d7e9508ec1e695;hb=0171936c9092666692c69a7f93fa75af976330cb;hp=c8f800f6986560db6300868c59759f53543fe791;hpb=93436263afc077d487937c45a12f38ad841dc9f0;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index c8f800f..ab99d49 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -8,7 +8,7 @@ module CoreUtils ( -- Construction mkNote, mkInlineMe, mkSCC, mkCoerce, bindNonRec, needsCaseBinding, - mkIfThenElse, mkAltExpr, mkPiType, + mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart findDefault, findAlt, hasDefault, @@ -19,10 +19,11 @@ module CoreUtils ( exprIsValue,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsAtom, idAppIsBottom, idAppIsCheap, - exprArity, - -- Expr transformation - etaExpand, exprArity, exprEtaExpandArity, + + -- Arity and eta expansion + manifestArity, exprArity, + exprEtaExpandArity, etaExpand, -- Size coreBindsSize, @@ -31,7 +32,7 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, eqExpr, applyTypeToArgs + cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg ) where #include "HsVersions.h" @@ -44,21 +45,21 @@ 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, hasNoBinding, isDataConId, isBottomingId + 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 ) @@ -67,6 +68,7 @@ import BasicTypes ( Arity ) import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only +import Util ( equalLength, lengthAtLeast ) \end{code} @@ -102,26 +104,35 @@ lbvarinfo field to figure out the right annotation for the arrove in 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 @@ -298,26 +309,25 @@ findAlt con alts @exprIsBottom@ is true of expressions that are guaranteed to diverge +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like $wJust, is +really short for (\x -> $wJust x), becuase $wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + \begin{code} -exprIsTrivial (Var v) - | hasNoBinding v = idArity v == 0 - -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op - -- The idea here is that a constructor worker, like $wJust, is - -- really short for (\x -> $wJust x), becuase $wJust has no binding. - -- So it should be treated like a lambda. - -- Ditto unsaturated primops. - -- This came up when dealing with eta expansion/reduction for - -- x = $wJust - -- Here we want to eta-expand. This looks like an optimisation, - -- but it's important (albeit tiresome) that CoreSat doesn't increase - -- anything's arity - | otherwise = True -exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body -exprIsTrivial other = False +exprIsTrivial (Var v) = True -- See notes above +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = True +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial other = False exprIsAtom :: CoreExpr -> Bool -- Used to decide whether to let-binding an STG argument @@ -474,28 +484,50 @@ side effects, and can't diverge or raise an exception. \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} @@ -601,7 +633,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) 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) }} @@ -622,7 +654,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) 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) @@ -831,7 +863,7 @@ eta_expand n us expr 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 -> @@ -884,7 +916,6 @@ exprArity e = go e go _ = 0 \end{code} - %************************************************************************ %* * \subsection{Equality} @@ -939,7 +970,7 @@ eqExpr e1 e2 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 @@ -947,7 +978,7 @@ eqExpr e1 e2 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 @@ -983,7 +1014,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs 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