X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=49bbf151267d1c7c7560ec89fa8b98dd120c4dce;hb=cfcebde74cf826af12143a92bcffa8c995eee135;hp=bb73e018646efebd05b4e04db917b22ddd67f879;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index bb73e01..49bbf15 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -1,71 +1,50 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CoreUtils]{Utility functions on @Core@ syntax} \begin{code} -#include "HsVersions.h" - module CoreUtils ( coreExprType, coreAltsType, - substCoreExpr, substCoreBindings - - , mkCoreIfThenElse - , argToExpr - , unTagBinders, unTagBindersAlts - , manifestlyWHNF, manifestlyBottom - , maybeErrorApp - , nonErrorRHSs - , squashableDictishCcExpr - , exprSmallEnoughToDup -{- - coreExprArity, - isWrapperFor, + exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, exprIsValue, + exprOkForSpeculation, + FormSummary(..), mkFormSummary, whnfOrBottom, exprArity, + cheapEqExpr, eqExpr, applyTypeToArgs + ) where --} ) where +#include "HsVersions.h" -IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes import CoreSyn - -import CostCentre ( isDictCC ) -import Id ( idType, mkSysLocal, getIdArity, isBottomingId, - toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, - addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, IdEnv(..), - GenId{-instances-} - ) -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 PrelVals ( augmentId, buildId ) -import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) -import SrcLoc ( mkUnknownSrcLoc ) -import TyVar ( cloneTyVar, - isNullTyVarEnv, addOneToTyVarEnv, TyVarEnv(..) +import PprCore ( pprCoreExpr ) +import Var ( IdOrTyVar, isId, isTyVar ) +import VarSet +import VarEnv +import Name ( isLocallyDefined ) +import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable, + conType, conOkForSpeculation, conStrictness ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy +import Id ( Id, idType, setIdType, idUnique, idAppIsBottom, + getIdArity, + getIdSpecialisation, setIdSpecialisation, + getInlinePragma, setInlinePragma, + getIdUnfolding, setIdUnfolding, idInfo ) -import TysWiredIn ( trueDataCon, falseDataCon ) -import UniqSupply ( initUs, returnUs, thenUs, - mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply +import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) ) +import Type ( Type, mkFunTy, mkForAllTy, + splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, + isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..), + tidyTyVar, applyTys, isUnLiftedType ) -import Usage ( UVar(..) ) -import Util ( zipEqual, panic, pprPanic, assertPanic ) - -type TypeEnv = TyVarEnv Type -applyUsage = panic "CoreUtils.applyUsage:ToDo" +import Demand ( isPrim, isLazy ) +import Unique ( buildIdKey, augmentIdKey ) +import Util ( zipWithEqual, mapAccumL ) +import Outputable +import TysPrim ( alphaTy ) -- Debugging only \end{code} + %************************************************************************ %* * \subsection{Find the type of a Core atom/expression} @@ -75,752 +54,412 @@ applyUsage = panic "CoreUtils.applyUsage:ToDo" \begin{code} coreExprType :: CoreExpr -> Type -coreExprType (Var var) = idType var -coreExprType (Lit lit) = literalType lit - -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 (Prim op args) = applyTypeToArgs (primOpType op) args - -coreExprType (Lam (ValBinder binder) expr) - = mkFunTys [idType binder] (coreExprType expr) - -coreExprType (Lam (TyBinder tyvar) expr) - = mkForAllTy tyvar (coreExprType expr) - -coreExprType (Lam (UsageBinder uvar) expr) - = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) - -coreExprType (App expr (TyArg ty)) - = applyTy (coreExprType expr) ty - -coreExprType (App expr (UsageArg use)) - = applyUsage (coreExprType expr) use - -coreExprType (App expr val_arg) - = ASSERT(isValArg val_arg) - let - fun_ty = coreExprType expr - in - case (getFunTy_maybe fun_ty) of - Just (_, result_ty) -> result_ty -#ifdef DEBUG - Nothing -> pprPanic "coreExprType:\n" - (ppAboves [ppr PprDebug fun_ty, - ppr PprShowAll (App expr val_arg)]) -#endif +coreExprType (Var var) = idType var +coreExprType (Let _ body) = coreExprType body +coreExprType (Case _ _ alts) = coreAltsType alts +coreExprType (Note (Coerce ty _) e) = ty +coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e)) +coreExprType (Note other_note e) = coreExprType e +coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args + +coreExprType (Lam binder expr) + | isId binder = (case (lbvarInfo . idInfo) binder of + IsOneShotLambda -> mkUsgTy UsOnce + otherwise -> id) $ + idType binder `mkFunTy` coreExprType expr + | isTyVar binder = mkForAllTy binder (coreExprType expr) + +coreExprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (coreExprType fun) args + +coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy + +coreAltsType :: [CoreAlt] -> Type +coreAltsType ((_,_,rhs) : _) = coreExprType rhs \end{code} \begin{code} -coreAltsType :: CoreCaseAlts -> Type - -coreAltsType (AlgAlts [] deflt) = default_ty deflt -coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1 - -coreAltsType (PrimAlts [] deflt) = default_ty deflt -coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1 - -default_ty NoDefault = panic "coreExprType:Case:default_ty" -default_ty (BindDefault _ rhs) = coreExprType rhs +-- The first argument is just for debugging +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +applyTypeToArgs e op_ty [] = op_ty + +applyTypeToArgs e op_ty (Type ty : args) + = -- Accumulate type arguments so we can instantiate all at once + ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys ) + applyTypeToArgs e (applyTys op_ty tys) rest_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) + +applyTypeToArgs e op_ty (other_arg : args) + = case (splitFunTy_maybe op_ty) of + Just (_, res_ty) -> applyTypeToArgs e res_ty args + Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e) \end{code} -\begin{code} -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 - Just (_, res_ty) -> res_ty -\end{code} %************************************************************************ %* * -\subsection{Routines to manufacture bits of @CoreExpr@} +\subsection{Figuring out things about expressions} %* * %************************************************************************ \begin{code} -mkCoreIfThenElse (Var bool) then_expr else_expr - | bool == trueDataCon = then_expr - | bool == falseDataCon = else_expr - -mkCoreIfThenElse guard then_expr else_expr - = Case guard - (AlgAlts [ (trueDataCon, [], then_expr), - (falseDataCon, [], else_expr) ] - NoDefault ) +data FormSummary + = VarForm -- Expression is a variable (or scc var, etc) + + | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal + -- May 1999: I'm experimenting with allowing "cheap" non-values + -- here. + + | BottomForm -- Expression is guaranteed to be bottom. We're more gung + -- ho about inlining such things, because it can't waste work + | OtherForm -- Anything else + +instance Outputable FormSummary where + ppr VarForm = ptext SLIT("Var") + ppr ValueForm = ptext SLIT("Value") + ppr BottomForm = ptext SLIT("Bot") + ppr OtherForm = ptext SLIT("Other") + +whnfOrBottom :: FormSummary -> Bool +whnfOrBottom VarForm = True +whnfOrBottom ValueForm = True +whnfOrBottom BottomForm = True +whnfOrBottom OtherForm = False \end{code} -For making @Apps@ and @Lets@, we must take appropriate evasive -action if the thing being bound has unboxed type. @mkCoApp@ requires -a name supply to do its work. - -@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the -arguments-must-be-atoms constraint. - \begin{code} -data CoreArgOrExpr - = AnArg CoreArg - | AnExpr CoreExpr +mkFormSummary :: CoreExpr -> FormSummary + -- Used exclusively by CoreUnfold.mkUnfolding + -- Returns ValueForm for cheap things, not just values +mkFormSummary expr + = go (0::Int) expr -- The "n" is the number of *value* arguments so far + where + go n (Con con _) | isWHNFCon con = ValueForm + | otherwise = OtherForm -mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr -mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr -mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr + go n (Note _ e) = go n e -mkCoApps fun args = co_thing (mkGenApp fun) args -mkCoCon con args = co_thing (Con con) args -mkCoPrim op args = co_thing (Prim op) args + go n (Let (NonRec b r) e) | exprIsCheap r = go n e -- let f = f' alpha in (f,g) + -- should be treated as a value + go n (Let _ e) = OtherForm -co_thing :: ([CoreArg] -> CoreExpr) - -> [CoreArgOrExpr] - -> UniqSM CoreExpr + -- We want selectors to look like values + -- e.g. case x of { (a,b) -> a } + -- should give a ValueForm, so that it will be inlined vigorously + -- [June 99. I can't remember why this is a good idea. It means that + -- all overloading selectors get inlined at their usage sites, which is + -- not at all necessarily a good thing. So I'm rescinding this decision for now.] +-- go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm -co_thing thing arg_exprs - = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) -> - returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args)) - where - expr_to_arg :: CoreArgOrExpr - -> UniqSM (CoreArg, Maybe CoreBinding) - - expr_to_arg (AnArg arg) = returnUs (arg, Nothing) - expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing) - expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing) - expr_to_arg (AnExpr other_expr) - = let - e_ty = coreExprType other_expr - in - getUnique `thenUs` \ uniq -> - let - new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc - in - returnUs (VarArg new_var, Just (NonRec new_var other_expr)) -\end{code} + go n expr@(Case _ _ _) = OtherForm -\begin{code} -argToExpr :: - GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar + go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom! + | otherwise = go 0 e + go n (Lam x e) | isId x = go (n-1) e -- Applied lambda + | otherwise = go n e -argToExpr (VarArg v) = Var v -argToExpr (LitArg lit) = Lit lit -\end{code} + go n (App fun (Type _)) = go n fun -- Ignore type args + go n (App fun arg) = go (n+1) fun -\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 - } --} + go n (Var f) | idAppIsBottom f n = BottomForm + go 0 (Var f) = VarForm + go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm + | otherwise = OtherForm \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] +@exprIsTrivial@ is true of expressions we are unconditionally + happy to duplicate; simple variables and constants, + and type applications. -\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} +@exprIsBottom@ is true of expressions that are guaranteed to diverge -@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 - } +exprIsTrivial (Type _) = True +exprIsTrivial (Var v) = True +exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args +exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body +exprIsTrivial other = 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} +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in space. This will only happen in different case + branches, so there's no issue about duplicating work. + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points -Probably a little too HACKY [WDP]. \begin{code} -isWrapperFor :: CoreExpr -> Id -> Bool +exprIsDupable (Type _) = True +exprIsDupable (Con con args) = conIsDupable con && + all exprIsDupable args && + valArgCount args <= dupAppSize + +exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable expr = case collectArgs expr of + (Var f, args) -> valArgCount args <= dupAppSize + other -> False + +dupAppSize :: Int +dupAppSize = 4 -- Size of application we are prepared to duplicate +\end{code} -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 - } +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +[Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap.] +By ``cheap'' we mean a computation we're willing to push inside a lambda +in order to bring a couple of lambdas together. That might mean it gets +evaluated more than once, instead of being shared. The main examples of things +which aren't WHNF but are ``cheap'' are: - 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 - } + * case e of + pi -> ei - -------------- - unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault) - = unravel_casing (params ++ case_ables) rhs - unravel_alts case_ables other = False + where e, and all the ei are cheap; and - ------------------------- - doesn't_mention var (ValArg (VarArg v)) = v /= var - doesn't_mention var other = True + * let x = e + in b - ------------------------- - only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables - only_from case_ables other = True --} -\end{code} + where e and b are cheap; and -All the following functions operate on binders, perform a uniform -transformation on them; ie. the function @(\ x -> (x,False))@ -annotates all binders with False. + * op x1 ... xn -\begin{code} -unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv -unTagBinders expr = bop_expr fst expr + where op is a cheap primitive operator -unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv -unTagBindersAlts alts = bop_alts fst alts -\end{code} +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. \begin{code} -bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv - -bop_expr f (Var b) = Var b -bop_expr f (Lit lit) = Lit lit -bop_expr f (Con con args) = Con con args -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) - -bop_binder f (ValBinder v) = ValBinder (f v) -bop_binder f (TyBinder t) = TyBinder t -bop_binder f (UsageBinder u) = UsageBinder u - -bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e) -bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs] - -bop_alts f (AlgAlts alts deflt) - = AlgAlts [ (con, [f b | b <- binders], bop_expr f e) - | (con, binders, e) <- alts ] - (bop_deflt f deflt) - -bop_alts f (PrimAlts alts deflt) - = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ] - (bop_deflt f deflt) - -bop_deflt f (NoDefault) = NoDefault -bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr) +exprIsCheap :: CoreExpr -> Bool +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e +exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body +exprIsCheap (Case scrut _ alts) = exprIsCheap scrut && + all (\(_,_,rhs) -> exprIsCheap rhs) alts + +exprIsCheap other_expr -- look for manifest partial application + = case collectArgs other_expr of + (f, args) -> isPap f (valArgCount args) && all exprIsCheap args \end{code} -OLD (but left here because of the nice example): @singleAlt@ checks -whether a bunch of case alternatives is actually just one alternative. -It specifically {\em ignores} alternatives which consist of just a -call to @error@, because they won't result in any code duplication. - -Example: -\begin{verbatim} - case (case of - True -> - False -> error "Foo") of - - -===> - - case of - True -> case of - - False -> case error "Foo" of - +\begin{code} +isPap :: CoreExpr -- Function + -> Int -- Number of value args + -> Bool +isPap (Var f) n_val_args + = idAppIsBottom f n_val_args + -- Application of a function which + -- always gives bottom; we treat this as + -- a WHNF, because it certainly doesn't + -- need to be shared! + + || n_val_args == 0 -- Just a type application of + -- a variable (f t1 t2 t3) + -- counts as WHNF + + || n_val_args < arityLowerBound (getIdArity f) + +isPap fun n_val_args = False +\end{code} -===> +exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe +to evaluate even if normal order eval might not evaluate the expression +at all. E.G. + let x = case y# +# 1# of { r# -> I# r# } + in E +==> + case y# +# 1# of { r# -> + let x = I# r# + in E + } - case of - True -> case of - - False -> error "Foo" -\end{verbatim} -Notice that the \tr{} don't get duplicated. +We can only do this if the (y+1) is ok for speculation: it has no +side effects, and can't diverge or raise an exception. \begin{code} -nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar] - -nonErrorRHSs alts - = filter not_error_app (find_rhss alts) +exprOkForSpeculation :: CoreExpr -> Bool +exprOkForSpeculation (Var v) = True -- Unlifted type => already evaluated + +exprOkForSpeculation (Note _ e) = exprOkForSpeculation e +exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) && + exprOkForSpeculation r && + exprOkForSpeculation e +exprOkForSpeculation (Let (Rec _) _) = False +exprOkForSpeculation (Case _ _ _) = False -- Conservative +exprOkForSpeculation (App _ _) = False + +exprOkForSpeculation (Con con args) + = conOkForSpeculation con && + and (zipWith ok (filter isValArg args) (fst (conStrictness con))) where - find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt - find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt + ok arg demand | isLazy demand = True + | isPrim demand = exprOkForSpeculation arg + | otherwise = False - deflt_rhs NoDefault = [] - deflt_rhs (BindDefault _ rhs) = [rhs] - - not_error_app rhs - = case (maybeErrorApp rhs Nothing) of - Just _ -> False - Nothing -> True +exprOkForSpeculation other = panic "exprOkForSpeculation" + -- Lam, Type \end{code} -maybeErrorApp checks whether an expression is of the form - - error ty args -If so, it returns - - Just (error ty' args) - -where ty' is supplied as an argument to maybeErrorApp. - -Here's where it is useful: - - case (error ty "Foo" e1 e2) of - ===> - error ty' "Foo" - -where ty' is the type of any of the alternatives. You might think -this never occurs, but see the comments on the definition of -@singleAlt@. - -Note: we *avoid* the case where ty' might end up as a primitive type: -this is very uncool (totally wrong). - -NOTICE: in the example above we threw away e1 and e2, but not the -string "Foo". How did we know to do that? - -Answer: for now anyway, we only handle the case of a function whose -type is of form +\begin{code} +exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom +exprIsBottom e = go 0 e + where + -- n is the number of args + go n (Note _ e) = go n e + go n (Let _ e) = go n e + go n (Case e _ _) = go 0 e -- Just check the scrut + go n (App e _) = go (n+1) e + go n (Var v) = idAppIsBottom v n + go n (Con _ _) = False + go n (Lam _ _) = False +\end{code} - bottomingFn :: forall a. t1 -> ... -> tn -> a - ^---------------------^ NB! +@exprIsValue@ returns true for expressions that are evaluated. +It does not treat variables as evaluated. -Furthermore, we only count a bottomingApp if the function is applied -to more than n args. If so, we transform: +\begin{code} +exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind + -- copying them +exprIsValue (Var v) = False +exprIsValue (Lam b e) = isId b || exprIsValue e +exprIsValue (Note _ e) = exprIsValue e +exprIsValue (Let _ e) = False +exprIsValue (Case _ _ _) = False +exprIsValue (Con con _) = isWHNFCon con +exprIsValue e@(App _ _) = case collectArgs e of + (Var v, args) -> fun_arity > valArgCount args + where + fun_arity = arityLowerBound (getIdArity v) + _ -> False +\end{code} - bottomingFn ty e1 ... en en+1 ... em -to - bottomingFn ty' e1 ... en +exprIsWHNF reports True for head normal forms. Note that does not necessarily +mean *normal* forms; constructors might have non-trivial argument expressions, for +example. We use a let binding for WHNFs, rather than a case binding, even if it's +used strictly. We try to expose WHNFs by floating lets out of the RHS of lets. -That is, we discard en+1 .. em + We treat applications of buildId and augmentId as honorary WHNFs, + because we want them to get exposed. + [May 99: I've disabled this because it looks jolly dangerous: + we'll substitute inside lambda with potential big loss of sharing.] \begin{code} -maybeErrorApp - :: GenCoreExpr a Id TyVar UVar -- Expr to look at - -> Maybe Type -- Just ty => a result type *already cloned*; - -- Nothing => don't know result ty; we - -- *pretend* that the result ty won't be - -- primitive -- somebody later must - -- ensure this. - -> Maybe (GenCoreExpr a Id TyVar UVar) - -maybeErrorApp expr result_ty_maybe - = case (collectArgs expr) of - (Var fun, [{-no usage???-}], [ty], other_args) - | isBottomingId fun - && maybeToBool result_ty_maybe -- we *know* the result type - -- (otherwise: live a fairy-tale existence...) - && not (isPrimType result_ty) -> - - case (splitSigmaTy (idType fun)) of - ([tyvar], [], tau_ty) -> - case (splitFunTy tau_ty) of { (arg_tys, res_ty) -> - let - n_args_to_keep = length arg_tys - args_to_keep = take n_args_to_keep other_args - in - if (res_ty `eqTy` mkTyVarTy tyvar) - && n_args_to_keep <= length other_args - then - -- Phew! We're in business - Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep)) - else - Nothing - } - - other -> Nothing -- Function type wrong shape - other -> Nothing - where - Just result_ty = result_ty_maybe +exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP +exprIsWHNF (Type ty) = True -- Types are honorary WHNFs; we don't mind + -- copying them +exprIsWHNF (Var v) = True +exprIsWHNF (Lam b e) = isId b || exprIsWHNF e +exprIsWHNF (Note _ e) = exprIsWHNF e +exprIsWHNF (Let _ e) = False +exprIsWHNF (Case _ _ _) = False +exprIsWHNF (Con con _) = isWHNFCon con +exprIsWHNF e@(App _ _) = case collectArgs e of + (Var v, args) -> n_val_args == 0 + || fun_arity > n_val_args +-- [May 99: disabled. See note above] || v_uniq == buildIdKey +-- || v_uniq == augmentIdKey + where + n_val_args = valArgCount args + fun_arity = arityLowerBound (getIdArity v) + v_uniq = idUnique v + + _ -> False \end{code} \begin{code} -squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool - -squashableDictishCcExpr cc expr - = if not (isDictCC cc) then - False -- that was easy... - else - squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier - where - squashable (Var _) = True - squashable (Con _ _) = True -- I think so... WDP 94/09 - squashable (Prim _ _) = True -- ditto - squashable (App f a) - | notValArg a = squashable f - squashable other = False +exprArity :: CoreExpr -> Int -- How many value lambdas are at the top +exprArity (Lam b e) | isTyVar b = exprArity e + | otherwise = 1 + exprArity e +exprArity other = 0 \end{code} + %************************************************************************ %* * -\subsection{Core-renaming utils} +\subsection{Equality} %* * %************************************************************************ -\begin{code} -substCoreBindings :: ValEnv - -> TypeEnv -- TyVar=>Type - -> [CoreBinding] - -> UniqSM [CoreBinding] - -substCoreExpr :: ValEnv - -> TypeEnv -- TyVar=>Type - -> CoreExpr - -> UniqSM CoreExpr - -substCoreBindings venv tenv binds - -- if the envs are empty, then avoid doing anything - = if (isNullIdEnv venv && isNullTyVarEnv tenv) then - returnUs binds - else - do_CoreBindings venv tenv binds - -substCoreExpr venv tenv expr - = if (isNullIdEnv venv && isNullTyVarEnv tenv) then - returnUs expr - else - do_CoreExpr venv tenv expr -\end{code} - -The equiv code for @Types@ is in @TyUtils@. - -Because binders aren't necessarily unique: we don't do @plusEnvs@ -(which check for duplicates); rather, we use the shadowing version, -@growIdEnv@ (and shorthand @addOneToIdEnv@). - -@do_CoreBindings@ takes into account the semantics of a list of -@CoreBindings@---things defined early in the list are visible later in -the list, but not vice versa. +@cheapEqExpr@ is a cheap equality test which bales out fast! + True => definitely equal + False => may or may not be equal \begin{code} -type ValEnv = IdEnv CoreExpr +cheapEqExpr :: Expr b -> Expr b -> Bool -do_CoreBindings :: ValEnv - -> TypeEnv - -> [CoreBinding] - -> UniqSM [CoreBinding] +cheapEqExpr (Var v1) (Var v2) = v1==v2 +cheapEqExpr (Con con1 args1) (Con con2 args2) + = con1 == con2 && + and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2) -do_CoreBinding :: ValEnv - -> TypeEnv - -> CoreBinding - -> UniqSM (CoreBinding, ValEnv) +cheapEqExpr (App f1 a1) (App f2 a2) + = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 -do_CoreBindings venv tenv [] = returnUs [] -do_CoreBindings venv tenv (b:bs) - = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) -> - do_CoreBindings new_venv tenv bs `thenUs` \ new_bs -> - returnUs (new_b : new_bs) +cheapEqExpr (Type t1) (Type t2) = t1 == t2 -do_CoreBinding venv tenv (NonRec binder rhs) - = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs -> - - dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> - -- now plug new bindings into envs - let new_venv = addOneToIdEnv venv old new in - - returnUs (NonRec new_binder new_rhs, new_venv) - -do_CoreBinding venv tenv (Rec binds) - = -- for letrec, we plug in new bindings BEFORE cloning rhss - mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) -> - let new_venv = growIdEnvList venv new_maps in - - mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss -> - returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv) - where - (binders, rhss) = unzip binds +cheapEqExpr _ _ = False \end{code} -\begin{code} -do_CoreArg :: ValEnv - -> TypeEnv - -> CoreArg - -> UniqSM CoreArgOrExpr - -do_CoreArg venv tenv a@(VarArg v) - = returnUs ( - case (lookupIdEnv venv v) of - Nothing -> AnArg a - Just expr -> AnExpr expr - ) - -do_CoreArg venv tenv (TyArg ty) - = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty))) - -do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg) -\end{code} \begin{code} -do_CoreExpr :: ValEnv - -> TypeEnv - -> CoreExpr - -> UniqSM CoreExpr - -do_CoreExpr venv tenv orig_expr@(Var var) - = returnUs ( - case (lookupIdEnv venv var) of - Nothing -> --false:ASSERT(toplevelishId var) (SIGH) - orig_expr - Just expr -> expr - ) - -do_CoreExpr venv tenv e@(Lit _) = returnUs e - -do_CoreExpr venv tenv (Con con as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - mkCoCon con new_as - -do_CoreExpr venv tenv (Prim op as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - do_PrimOp op `thenUs` \ new_op -> - mkCoPrim new_op new_as - where - do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty) - = let - new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys - new_result_ty = applyTypeEnvToTy tenv result_ty - in - returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty) - - do_PrimOp other_op = returnUs other_op - -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 (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 -> - do_CoreArg venv tenv arg `thenUs` \ new_arg -> - mkCoApps new_expr [new_arg] -- ToDo: more efficiently? - -do_CoreExpr venv tenv (Case expr alts) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - do_alts venv tenv alts `thenUs` \ new_alts -> - returnUs (Case new_expr new_alts) +eqExpr :: CoreExpr -> CoreExpr -> Bool + -- Works ok at more general type, but only needed at CoreExpr +eqExpr e1 e2 + = eq emptyVarEnv e1 e2 where - do_alts venv tenv (AlgAlts alts deflt) - = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (AlgAlts new_alts new_deflt) - where - do_boxed_alt venv tenv (con, binders, expr) - = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) -> - let new_venv = growIdEnvList venv new_vmaps in - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (con, new_binders, new_expr) - - - do_alts venv tenv (PrimAlts alts deflt) - = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (PrimAlts new_alts new_deflt) - where - do_unboxed_alt venv tenv (lit, expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (lit, new_expr) - - do_default venv tenv NoDefault = returnUs NoDefault - - do_default venv tenv (BindDefault 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 (BindDefault new_binder new_expr) - -do_CoreExpr venv tenv (Let core_bind expr) - = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) -> - -- and do the body of the let - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Let new_bind new_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) + -- The "env" maps variables in e1 to variables in ty2 + -- So when comparing lambdas etc, + -- we in effect substitute v2 for v1 in e1 before continuing + eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of + Just v1' -> v1' == v2 + Nothing -> v1 == v2 + + eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2 + eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2 + eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) 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 && + and (zipWith eq_rhs ps1 ps2) && + eq env' e1 e2 + where + env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2] + 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 && + and (zipWith (eq_alt env') a1 a2) + where + env' = extendVarEnv env v1 v2 + + eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2 + eq env (Type t1) (Type t2) = t1 == t2 + eq env e1 e2 = False + + eq_list env [] [] = True + eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2 + eq_list env es1 es2 = False + + eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && + eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2 + + eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 + eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2 + eq_note env InlineCall InlineCall = True + eq_note env other1 other2 = False \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}