X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=de0d323b4bd357bde869e1abf2721622a38f249a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=6e6d7baf30dcef90e997a4d38dc57cd515d1b136;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6e6d7ba..de0d323 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,61 +7,63 @@ #include "HsVersions.h" module CoreUtils ( - coreExprType, coreAltsType, + coreExprType, coreAltsType, coreExprCc, substCoreExpr, substCoreBindings , mkCoreIfThenElse , argToExpr , unTagBinders, unTagBindersAlts - , manifestlyWHNF, manifestlyBottom + , maybeErrorApp , nonErrorRHSs , squashableDictishCcExpr - , exprSmallEnoughToDup {- coreExprArity, isWrapperFor, -} ) where -import Ubiq -import IdLoop -- for pananoia-checking purposes +IMP_Ubiq() +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, IdEnv(..), + isNullIdEnv, SYN_IE(IdEnv), GenId{-instances-} ) import IdInfo ( arityMaybe ) import Literal ( literalType, isNoRepLit, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) -import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) +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 ( isNullTyVarEnv, TyVarEnv(..) ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, +import TyVar ( cloneTyVar, + isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv) + ) +import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy, + getFunTyExpandingDicts_maybe, applyTy, isPrimType, splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy ) import TysWiredIn ( trueDataCon, falseDataCon ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply + SYN_IE(UniqSM), UniqSupply ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( zipEqual, panic, pprPanic, assertPanic ) type TypeEnv = TyVarEnv Type applyUsage = panic "CoreUtils.applyUsage:ToDo" -dup_binder = panic "CoreUtils.dup_binder" \end{code} %************************************************************************ @@ -85,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) @@ -108,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" @@ -135,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@} @@ -211,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) = _trace "manifestlyWHNF:Coerce" $ 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) = _trace "manifestlyBottom:Coerce" $ 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)) @@ -728,11 +634,21 @@ do_CoreExpr venv tenv (Prim op as) do_PrimOp other_op = returnUs other_op -do_CoreExpr venv tenv (Lam binder expr) +do_CoreExpr venv tenv (Lam (ValBinder binder) expr) = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) -> let new_venv = addOneToIdEnv venv old new in do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Lam new_binder new_expr) + returnUs (Lam (ValBinder new_binder) new_expr) + +do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr) + = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) -> + let + new_tenv = addOneToTyVarEnv tenv old new + in + do_CoreExpr venv new_tenv expr `thenUs` \ new_expr -> + returnUs (Lam (TyBinder new_tyvar) new_expr) + +do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder" do_CoreExpr venv tenv (App expr arg) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> @@ -787,3 +703,28 @@ do_CoreExpr venv tenv (Coerce c ty expr) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr) \end{code} + +\begin{code} +dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type)) +dup_tyvar tyvar + = getUnique `thenUs` \ uniq -> + let new_tyvar = cloneTyVar tyvar uniq in + returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar)) + +-- same thing all over again -------------------- + +dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr)) +dup_binder tenv b + = if (toplevelishId b) then + -- binder is "top-level-ish"; -- it should *NOT* be renamed + -- ToDo: it's unsavoury that we return something to heave in env + returnUs (b, (b, Var b)) + + else -- otherwise, the full business + getUnique `thenUs` \ uniq -> + let + new_b1 = mkIdWithNewUniq b uniq + new_b2 = applyTypeEnvToId tenv new_b1 + in + returnUs (new_b2, (b, Var new_b2)) +\end{code}