X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=d7a91a00be06dab9ec6c2aeee6f9da1fa9cea908;hb=979947f545d70c63edb7ca96f6e47008ac90e3bf;hp=1ca6d37b4dcaa2c794f1b3df19dc29f9519f1ee3;hpb=f659cb97f97051c2a5fa443e2baaa13fb5db87b9;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 1ca6d37..d7a91a0 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,22 @@ 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 PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId + isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId ) import IdInfo ( LBVarInfo(..), 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 +69,7 @@ import BasicTypes ( Arity ) import Unique ( Unique ) import Outputable import TysPrim ( alphaTy ) -- Debugging only +import Util ( equalLength, lengthAtLeast ) \end{code} @@ -102,26 +105,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 +310,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 +485,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 +634,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 +655,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) @@ -804,14 +837,17 @@ eta_expand n us expr ty -- Saturated, so nothing to do = expr - -- Short cut for the case where there already - -- is a lambda; no point in gratuitously adding more 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 - = Note note (eta_expand n us 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 | isTyVar v = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v))) @@ -881,7 +917,6 @@ exprArity e = go e go _ = 0 \end{code} - %************************************************************************ %* * \subsection{Equality} @@ -936,7 +971,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 @@ -944,7 +979,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 @@ -980,7 +1015,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