X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=de0d323b4bd357bde869e1abf2721622a38f249a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=d3afc57ce04d04a2a02a8d85738a47a67c51920f;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d3afc57..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 PrelInfo ( trueDataCon, falseDataCon, - augmentId, buildId - ) +import Pretty ( ppAboves, ppStr ) +import PrelVals ( augmentId, buildId ) 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} %************************************************************************ @@ -80,14 +82,16 @@ coreExprType (Let _ body) = coreExprType body coreExprType (SCC _ expr) = coreExprType expr coreExprType (Case _ alts) = coreAltsType alts +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) @@ -106,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" @@ -129,8 +133,22 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \end{code} \begin{code} -applyTypeToArgs op_ty args - = foldl applyTy op_ty [ ty | TyArg ty <- args ] +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 (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} %************************************************************************ @@ -205,105 +223,6 @@ argToExpr (LitArg lit) = Lit lit \end{code} \begin{code} -{- LATER: -exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool - -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 -- 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 (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 (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)) @@ -413,6 +332,7 @@ bop_expr f (Prim op args) = Prim op args bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr) bop_expr f (App expr arg) = App (bop_expr f expr) arg bop_expr f (SCC label expr) = SCC label (bop_expr f expr) +bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e) bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr) bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts) @@ -656,7 +576,7 @@ do_CoreBinding venv tenv (Rec binds) let new_venv = growIdEnvList venv new_maps in mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss -> - returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv) + returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv) where (binders, rhss) = unzip binds \end{code} @@ -714,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 -> @@ -768,4 +698,33 @@ do_CoreExpr venv tenv (Let core_bind expr) do_CoreExpr venv tenv (SCC label expr) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> returnUs (SCC label new_expr) + +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}