X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=de0d323b4bd357bde869e1abf2721622a38f249a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=e0e65de4af05d64e16c9815d27612f4fffe0bef6;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index e0e65de..de0d323 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,18 +7,17 @@ #include "HsVersions.h" module CoreUtils ( - coreExprType, coreAltsType, + coreExprType, coreAltsType, coreExprCc, substCoreExpr, substCoreBindings , mkCoreIfThenElse , argToExpr , unTagBinders, unTagBindersAlts - , manifestlyWHNF, manifestlyBottom + , maybeErrorApp , nonErrorRHSs , squashableDictishCcExpr - , exprSmallEnoughToDup {- coreExprArity, isWrapperFor, @@ -30,9 +29,10 @@ IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes import CoreSyn -import CostCentre ( isDictCC ) +import CostCentre ( isDictCC, CostCentre, noCostCentre ) import Id ( idType, mkSysLocal, getIdArity, isBottomingId, toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, + dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, isNullIdEnv, SYN_IE(IdEnv), GenId{-instances-} @@ -43,15 +43,15 @@ import Maybes ( catMaybes, maybeToBool ) import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) -import Pretty ( ppAboves ) +import Pretty ( ppAboves, ppStr ) import PrelVals ( augmentId, buildId ) -import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) +import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) import TyVar ( cloneTyVar, isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv) ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, +import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy, + getFunTyExpandingDicts_maybe, applyTy, isPrimType, splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy ) import TysWiredIn ( trueDataCon, falseDataCon ) @@ -87,11 +87,11 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point! -- a Con is a fully-saturated application of a data constructor -- a Prim is of a PrimOp -coreExprType (Con con args) = applyTypeToArgs (idType con) args +coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args coreExprType (Lam (ValBinder binder) expr) - = mkFunTys [idType binder] (coreExprType expr) + = idType binder `mkFunTy` coreExprType expr coreExprType (Lam (TyBinder tyvar) expr) = mkForAllTy tyvar (coreExprType expr) @@ -110,7 +110,7 @@ coreExprType (App expr val_arg) let fun_ty = coreExprType expr in - case (getFunTy_maybe fun_ty) of + case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of Just (_, result_ty) -> result_ty #ifdef DEBUG Nothing -> pprPanic "coreExprType:\n" @@ -137,10 +137,20 @@ applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg" -applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of +applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of Just (_, res_ty) -> res_ty \end{code} +coreExprCc gets the cost centre enclosing an expression, if any. +It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e + +\begin{code} +coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre +coreExprCc (SCC cc e) = cc +coreExprCc (Lam _ e) = coreExprCc e +coreExprCc other = noCostCentre +\end{code} + %************************************************************************ %* * \subsection{Routines to manufacture bits of @CoreExpr@} @@ -213,112 +223,6 @@ argToExpr (LitArg lit) = Lit lit \end{code} \begin{code} -exprSmallEnoughToDup (Con _ _) = True -- Could check # of args -exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args -exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) -exprSmallEnoughToDup expr - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v | length vargs == 0 -> True - _ -> False - } - -{- LATER: -WAS: MORE CLEVER: -exprSmallEnoughToDup expr -- for now, just: applied to - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v -> v /= buildId - && v /= augmentId - && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish. - _ -> False - } --} -\end{code} -Question (ADR): What is the above used for? Is a _ccall_ really small -enough? - -@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if -it is obviously in weak head normal form. It isn't a disaster if it -errs on the conservative side (returning \tr{False})---I've probably -left something out... [WDP] - -\begin{code} -manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool - -manifestlyWHNF (Var _) = True -manifestlyWHNF (Lit _) = True -manifestlyWHNF (Con _ _) = True -manifestlyWHNF (SCC _ e) = manifestlyWHNF e -manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e -manifestlyWHNF (Let _ e) = False -manifestlyWHNF (Case _ _) = False - -manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e - -manifestlyWHNF other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, _, _, vargs) -> - case fun of - Var f -> let - num_val_args = length vargs - in - num_val_args == 0 -- Just a type application of - -- a variable (f t1 t2 t3); - -- counts as WHNF. - || - case (arityMaybe (getIdArity f)) of - Nothing -> False - Just arity -> num_val_args < arity - - _ -> False - } -\end{code} - -@manifestlyBottom@ looks at a Core expression and returns \tr{True} if -it is obviously bottom, that is, it will certainly return bottom at -some point. It isn't a disaster if it errs on the conservative side -(returning \tr{False}). - -\begin{code} -manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool - -manifestlyBottom (Var v) = isBottomingId v -manifestlyBottom (Lit _) = False -manifestlyBottom (Con _ _) = False -manifestlyBottom (Prim _ _) = False -manifestlyBottom (SCC _ e) = manifestlyBottom e -manifestlyBottom (Coerce _ _ e) = manifestlyBottom e -manifestlyBottom (Let _ e) = manifestlyBottom e - - -- We do not assume \x.bottom == bottom: -manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e - -manifestlyBottom (Case e a) - = manifestlyBottom e - || (case a of - AlgAlts alts def -> all mbalg alts && mbdef def - PrimAlts alts def -> all mbprim alts && mbdef def - ) - where - mbalg (_,_,e') = manifestlyBottom e' - - mbprim (_,e') = manifestlyBottom e' - - mbdef NoDefault = True - mbdef (BindDefault _ e') = manifestlyBottom e' - -manifestlyBottom other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, _, _, _) -> - case fun of - Var f | isBottomingId f -> True - -- Application of a function which always gives - -- bottom; we treat this as a WHNF, because it - -- certainly doesn't need to be shared! - _ -> False - } -\end{code} - -\begin{code} {-LATER: coreExprArity :: (Id -> Maybe (GenCoreExpr bndr Id))