X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=471e2b5bf33cbaabce075ad6f6f40b64afbd2a31;hb=0e271e92565344d9e41d2ae544422d0ce77211af;hp=3721baaaf9d468d0d77932c5a5ed0e4e499d5ed3;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 3721baa..471e2b5 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,62 +7,60 @@ #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 + ) where -import Ubiq -import IdLoop -- for pananoia-checking purposes +IMP_Ubiq() import CoreSyn -import CostCentre ( isDictCC ) -import Id ( idType, mkSysLocal, getIdArity, isBottomingId, +import CostCentre ( isDictCC, CostCentre, noCostCentre ) +import Id ( idType, mkSysLocal, isBottomingId, + toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, + dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, IdEnv(..), - GenId{-instances-} + isNullIdEnv, SYN_IE(IdEnv), + GenId{-instances-}, SYN_IE(Id) ) -import IdInfo ( arityMaybe ) import Literal ( literalType, isNoRepLit, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) -import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) -import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instances-} ) -import Pretty ( ppAboves ) -import PrelInfo ( trueDataCon, falseDataCon, - augmentId, buildId +import PprCore +import Outputable ( PprStyle(..), Outputable(..) ) +import PprType ( GenType{-instances-}, GenTyVar ) +import Pretty ( vcat, text ) +import PrimOp ( primOpType, PrimOp(..) ) +import SrcLoc ( noSrcLoc ) +import TyVar ( cloneTyVar, + isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv), + SYN_IE(TyVar), GenTyVar ) -import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) -import SrcLoc ( mkUnknownSrcLoc ) -import TyVar ( isNullTyVarEnv, TyVarEnv(..) ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy +import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy, + getFunTyExpandingDicts_maybe, applyTy, isPrimType, + splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy, + SYN_IE(Type) ) +import TysWiredIn ( trueDataCon, falseDataCon ) +import Unique ( Unique ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply + SYN_IE(UniqSM), UniqSupply ) -import Usage ( UVar(..) ) -import Util ( zipEqual, panic, pprPanic, assertPanic ) +import Usage ( SYN_IE(UVar) ) +import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic ) +import Pretty type TypeEnv = TyVarEnv Type applyUsage = panic "CoreUtils.applyUsage:ToDo" -dup_binder = panic "CoreUtils.dup_binder" \end{code} %************************************************************************ @@ -86,11 +84,18 @@ 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) = +-- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi, +-- ppr PprDebug con_ty, semi, +-- ppr PprDebug args]) $ + applyTypeToArgs con_ty args + where + con_ty = dataConRepType con + 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) @@ -99,7 +104,11 @@ coreExprType (Lam (UsageBinder uvar) expr) = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) coreExprType (App expr (TyArg ty)) - = applyTy (coreExprType expr) ty + = +-- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $ + applyTy fun_ty ty + where + fun_ty = coreExprType expr coreExprType (App expr (UsageArg use)) = applyUsage (coreExprType expr) use @@ -109,11 +118,11 @@ 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" - (ppAboves [ppr PprDebug fun_ty, + (vcat [ppr PprDebug fun_ty, ppr PprShowAll (App expr val_arg)]) #endif \end{code} @@ -136,10 +145,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@} @@ -198,7 +217,7 @@ co_thing thing arg_exprs in getUnique `thenUs` \ uniq -> let - new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc + new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc in returnUs (VarArg new_var, Just (NonRec new_var other_expr)) \end{code} @@ -211,200 +230,6 @@ argToExpr (VarArg v) = Var v 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)) - -> GenCoreExpr bndr Id - -> Int -coreExprArity f (Lam _ expr) = coreExprArity f expr + 1 -coreExprArity f (CoTyLam _ expr) = coreExprArity f expr -coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0 -coreExprArity f (CoTyApp expr _) = coreExprArity f expr -coreExprArity f (Var v) = max further info - where - further - = case f v of - Nothing -> 0 - Just expr -> coreExprArity f expr - info = case (arityMaybe (getIdArity v)) of - Nothing -> 0 - Just arity -> arity -coreExprArity f _ = 0 -\end{code} - -@isWrapperFor@: we want to see exactly: -\begin{verbatim} -/\ ... \ args -> case of ... -> case of ... -> wrkr -\end{verbatim} - -Probably a little too HACKY [WDP]. - -\begin{code} -isWrapperFor :: CoreExpr -> Id -> Bool - -expr `isWrapperFor` var - = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front - unravel_casing args body - --NO, THANKS: && not (null args) - } - where - var's_worker = getWorkerId (getIdStrictness var) - - is_elem = isIn "isWrapperFor" - - -------------- - unravel_casing case_ables (Case scrut alts) - = case (collectArgs scrut) of { (fun, _, _, vargs) -> - case fun of - Var scrut_var -> let - answer = - scrut_var /= var && all (doesn't_mention var) vargs - && scrut_var `is_elem` case_ables - && unravel_alts case_ables alts - in - answer - - _ -> False - } - - unravel_casing case_ables other_expr - = case (collectArgs other_expr) of { (fun, _, _, vargs) -> - case fun of - Var wrkr -> let - answer = - -- DOESN'T WORK: wrkr == var's_worker - wrkr /= var - && isWorkerId wrkr - && all (doesn't_mention var) vargs - && all (only_from case_ables) vargs - in - answer - - _ -> False - } - - -------------- - unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault) - = unravel_casing (params ++ case_ables) rhs - unravel_alts case_ables other = False - - ------------------------- - doesn't_mention var (ValArg (VarArg v)) = v /= var - doesn't_mention var other = True - - ------------------------- - only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables - only_from case_ables other = True --} -\end{code} - All the following functions operate on binders, perform a uniform transformation on them; ie. the function @(\ x -> (x,False))@ annotates all binders with False. @@ -547,7 +372,7 @@ maybeErrorApp -- *pretend* that the result ty won't be -- primitive -- somebody later must -- ensure this. - -> Maybe (GenCoreExpr a Id TyVar UVar) + -> Maybe (GenCoreExpr b Id TyVar UVar) maybeErrorApp expr result_ty_maybe = case (collectArgs expr) of @@ -671,7 +496,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} @@ -729,11 +554,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 -> @@ -788,3 +623,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}