X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=24b1f35cf2a5fec6ce9a8cc9161417d743d7b19b;hb=fda5605a79bc7bc5f0ef5bbaf241f89d951b65ce;hp=6e6d7baf30dcef90e997a4d38dc57cd515d1b136;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6e6d7ba..24b1f35 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -1,69 +1,73 @@ % -% (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, + -- Construction + mkNote, mkInlineMe, mkSCC, mkCoerce, + bindNonRec, mkIfThenElse, mkAltExpr, + mkPiType, - substCoreExpr, substCoreBindings + -- Properties of expressions + exprType, coreAltsType, + exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, + exprIsValue,exprOkForSpeculation, exprIsBig, + exprIsConApp_maybe, + idAppIsBottom, idAppIsCheap, - , mkCoreIfThenElse - , argToExpr - , unTagBinders, unTagBindersAlts - , manifestlyWHNF, manifestlyBottom - , maybeErrorApp - , nonErrorRHSs - , squashableDictishCcExpr - , exprSmallEnoughToDup -{- - coreExprArity, - isWrapperFor, + -- Expr transformation + etaReduceExpr, exprEtaExpandArity, --} ) where + -- Size + coreBindsSize, -import Ubiq -import IdLoop -- for pananoia-checking purposes + -- Hashing + hashExpr, -import CoreSyn + -- Equality + cheapEqExpr, eqExpr, applyTypeToArgs + ) where -import CostCentre ( isDictCC ) -import Id ( idType, mkSysLocal, getIdArity, isBottomingId, - 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 ( isNullTyVarEnv, TyVarEnv(..) ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTy_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy +#include "HsVersions.h" + + +import GlaExts -- For `xori` + +import CoreSyn +import CoreFVs ( exprFreeVars ) +import PprCore ( pprCoreExpr ) +import Var ( Var, isId, isTyVar ) +import VarSet +import VarEnv +import Name ( isLocallyDefined, hashName ) +import Literal ( Literal, hashLiteral, literalType, litIsDupable ) +import DataCon ( DataCon, dataConRepArity ) +import PrimOp ( primOpOkForSpeculation, primOpIsCheap, + primOpIsDupable ) +import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, + mkWildId, idArity, idName, idUnfolding, idInfo, + isDataConId_maybe, isPrimOpId_maybe ) -import TysWiredIn ( trueDataCon, falseDataCon ) -import UniqSupply ( initUs, returnUs, thenUs, - mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply +import IdInfo ( arityLowerBound, InlinePragInfo(..), + LBVarInfo(..), + IdFlavour(..), + megaSeqIdInfo ) +import Demand ( appIsBottom ) +import Type ( Type, mkFunTy, mkForAllTy, + splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, + isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..), + applyTys, isUnLiftedType, seqType ) -import Usage ( UVar(..) ) -import Util ( zipEqual, panic, pprPanic, assertPanic ) - -type TypeEnv = TyVarEnv Type -applyUsage = panic "CoreUtils.applyUsage:ToDo" -dup_binder = panic "CoreUtils.dup_binder" +import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon ) +import CostCentre ( CostCentre ) +import Maybes ( maybeToBool ) +import Outputable +import TysPrim ( alphaTy ) -- Debugging only \end{code} + %************************************************************************ %* * \subsection{Find the type of a Core atom/expression} @@ -71,719 +75,682 @@ dup_binder = panic "CoreUtils.dup_binder" %************************************************************************ \begin{code} -coreExprType :: CoreExpr -> Type - -coreExprType (Var var) = idType var -coreExprType (Lit lit) = literalType lit +exprType :: CoreExpr -> Type + +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Let _ body) = exprType body +exprType (Case _ _ alts) = coreAltsType alts +exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e +exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e)) +exprType (Note other_note e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy + +coreAltsType :: [CoreAlt] -> Type +coreAltsType ((_,_,rhs) : _) = exprType rhs +\end{code} -coreExprType (Let _ body) = coreExprType body -coreExprType (SCC _ expr) = coreExprType expr -coreExprType (Case _ alts) = coreAltsType alts +@mkPiType@ makes a (->) type or a forall type, depending on whether +it is given a type variable or a term variable. We cleverly use the +lbvarinfo field to figure out the right annotation for the arrove in +case of a term variable. -coreExprType (Coerce _ ty _) = ty -- that's the whole point! +\begin{code} +mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work... +mkPiType v ty | isId v = (case idLBVarInfo v of + IsOneShotLambda -> mkUsgTy UsOnce + otherwise -> id) $ + mkFunTy (idType v) ty + | isTyVar v = mkForAllTy v ty +\end{code} --- a Con is a fully-saturated application of a data constructor --- a Prim is of a PrimOp +\begin{code} +-- 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} -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) +%************************************************************************ +%* * +\subsection{Attaching notes} +%* * +%************************************************************************ -coreExprType (Lam (UsageBinder uvar) expr) - = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) +mkNote removes redundant coercions, and SCCs where possible -coreExprType (App expr (TyArg ty)) - = applyTy (coreExprType expr) ty +\begin{code} +mkNote :: Note -> CoreExpr -> CoreExpr +mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr +mkNote (SCC cc) expr = mkSCC cc expr +mkNote InlineMe expr = mkInlineMe expr +mkNote note expr = Note note expr + +-- Slide InlineCall in around the function +-- No longer necessary I think (SLPJ Apr 99) +-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a +-- mkNote InlineCall (Var v) = Note InlineCall (Var v) +-- mkNote InlineCall expr = expr +\end{code} -coreExprType (App expr (UsageArg use)) - = applyUsage (coreExprType expr) use +Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding +that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may +not be *applied* to anything. -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 +\begin{code} +mkInlineMe e | exprIsTrivial e = e + | otherwise = Note InlineMe e \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 +\begin{code} +mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr + +mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) + = ASSERT( from_ty == to_ty2 ) + mkCoerce to_ty from_ty2 expr -default_ty NoDefault = panic "coreExprType:Case:default_ty" -default_ty (BindDefault _ rhs) = coreExprType rhs +mkCoerce to_ty from_ty expr + | to_ty == from_ty = expr + | otherwise = ASSERT( from_ty == exprType expr ) + Note (Coerce to_ty from_ty) expr \end{code} \begin{code} -applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args +mkSCC :: CostCentre -> Expr b -> Expr b + -- Note: Nested SCC's *are* preserved for the benefit of + -- cost centre stack profiling (Durham) -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 +mkSCC cc (Lit lit) = Lit lit +mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda +mkSCC cc expr = Note (SCC cc) expr \end{code} + %************************************************************************ %* * -\subsection{Routines to manufacture bits of @CoreExpr@} +\subsection{Other expression construction} %* * %************************************************************************ \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 ) +bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- (bindNonRec x r b) produces either +-- let x = r in b +-- or +-- case r of x { _DEFAULT_ -> b } +-- +-- depending on whether x is unlifted or not +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack. Actually the simplifier +-- deals with them perfectly well. +bindNonRec bndr rhs body + | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] + | otherwise = Let (NonRec bndr rhs) body \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 - -mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr -mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr -mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr - -mkCoApps fun args = co_thing (mkGenApp fun) args -mkCoCon con args = co_thing (Con con) args -mkCoPrim op args = co_thing (Prim op) args - -co_thing :: ([CoreArg] -> CoreExpr) - -> [CoreArgOrExpr] - -> UniqSM CoreExpr - -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)) +mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr + -- This guy constructs the value that the scrutinee must have + -- when you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ map varToCoreExpr args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr + = Case guard (mkWildId boolTy) + [ (DataAlt trueDataCon, [], then_expr), + (DataAlt falseDataCon, [], else_expr) ] \end{code} -\begin{code} -argToExpr :: - GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar +%************************************************************************ +%* * +\subsection{Figuring out things about expressions} +%* * +%************************************************************************ -argToExpr (VarArg v) = Var v -argToExpr (LitArg lit) = Lit lit -\end{code} +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless -\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? +@exprIsBottom@ is true of expressions that are guaranteed to diverge -@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 - } +exprIsTrivial (Var v) + | Just op <- isPrimOpId_maybe v = primOpIsDupable op + | otherwise = True +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = True +exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body +exprIsTrivial other = 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} +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. -\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} + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. -@isWrapperFor@: we want to see exactly: -\begin{verbatim} -/\ ... \ args -> case of ... -> case of ... -> wrkr -\end{verbatim} + 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 - -expr `isWrapperFor` var - = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front - unravel_casing args body - --NO, THANKS: && not (null args) - } +exprIsDupable (Type _) = True +exprIsDupable (Var v) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable expr + = go expr 0 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 - } + go (Var v) n_args = True + go (App f a) n_args = n_args < dupAppSize + && exprIsDupable a + && go f (n_args+1) + go other n_args = False + +dupAppSize :: Int +dupAppSize = 4 -- Size of application we are prepared to duplicate +\end{code} - 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 - } +@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.] - -------------- - unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault) - = unravel_casing (params ++ case_ables) rhs - unravel_alts case_ables other = False +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +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: - ------------------------- - doesn't_mention var (ValArg (VarArg v)) = v /= var - doesn't_mention var other = True + * case e of + pi -> ei + (where e, and all the ei are cheap) - ------------------------- - only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables - only_from case_ables other = True --} -\end{code} + * let x = e in b + (where e and b are cheap) -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 + (where op is a cheap primitive operator) -\begin{code} -unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv -unTagBinders expr = bop_expr fst expr + * error "foo" + (because we are happy to substitute it inside a lambda) -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 (Lit lit) = True +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e +exprIsCheap (Case e _ alts) = exprIsCheap e && + and [exprIsCheap rhs | (_,_,rhs) <- alts] + -- Experimentally, treat (case x of ...) as cheap + -- (and case __coerce x etc.) + -- This improves arities of overloaded functions where + -- there is only dictionary selection (no construction) involved +exprIsCheap (Let (NonRec x _) e) + | isUnLiftedType (idType x) = exprIsCheap e + | otherwise = False + -- strict lets always have cheap right hand sides, and + -- do no allocation. + +exprIsCheap other_expr + = go other_expr 0 True + where + go (Var f) n_args args_cheap + = (idAppIsCheap f n_args && args_cheap) + -- A constructor, cheap primop, or partial application + + || idAppIsBottom f n_args + -- Application of a function which + -- always gives bottom; we treat this as cheap + -- because it certainly doesn't need to be shared! + + go (App f a) n_args args_cheap + | isTypeArg a = go f n_args args_cheap + | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) + + go other n_args args_cheap = False + +idAppIsCheap :: Id -> Int -> Bool +idAppIsCheap id n_val_args + | n_val_args == 0 = True -- Just a type application of + -- a variable (f t1 t2 t3) + -- counts as WHNF + | otherwise = case idFlavour id of + DataConId _ -> True + RecordSelId _ -> True -- I'm experimenting with making record selection + -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection + + PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + other -> n_val_args < idArity id \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. +exprOkForSpeculation returns True of an expression that it is -Example: -\begin{verbatim} - case (case of - True -> - False -> error "Foo") of - + * safe to evaluate even if normal order eval might not + evaluate the expression at all, or -===> + * safe *not* to evaluate even if normal order would do so - case of - True -> case of - - False -> case error "Foo" of - +It returns True iff -===> + the expression guarantees to terminate, + soon, + without raising an exception, + without causing a side effect (e.g. writing a mutable variable) - case of - True -> case of - - False -> error "Foo" -\end{verbatim} -Notice that the \tr{} don't get duplicated. +E.G. + let x = case y# +# 1# of { r# -> I# r# } + in E +==> + case y# +# 1# of { r# -> + let x = I# r# + in E + } -\begin{code} -nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar] +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. -nonErrorRHSs alts - = filter not_error_app (find_rhss alts) +\begin{code} +exprOkForSpeculation :: CoreExpr -> Bool +exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Var v) = isUnLiftedType (idType v) +exprOkForSpeculation (Note _ e) = exprOkForSpeculation e +exprOkForSpeculation other_expr + = go other_expr 0 True where - find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt - find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt + go (Var f) n_args args_ok + = case idFlavour f of + DataConId _ -> True -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op -> primOpOkForSpeculation op && args_ok + -- A bit conservative: we don't really need + -- to care about lazy arguments, but this is easy + + other -> False + + go (App f a) n_args args_ok + | isTypeArg a = go f n_args args_ok + | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) + + go other n_args args_ok = False +\end{code} - deflt_rhs NoDefault = [] - deflt_rhs (BindDefault _ rhs) = [rhs] - not_error_app rhs - = case (maybeErrorApp rhs Nothing) of - Just _ -> False - Nothing -> True +\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 (Lit _) = False + go n (Lam _ _) = False + +idAppIsBottom :: Id -> Int -> Bool +idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args \end{code} -maybeErrorApp checks whether an expression is of the form +@exprIsValue@ returns true for expressions that are certainly *already* +evaluated to WHNF. This is used to decide wether it's ok to change + case x of _ -> e ===> e - error ty args +and to decide whether it's safe to discard a `seq` + +So, it does *not* treat variables as evaluated, unless they say they are + +\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 (Lit l) = True +exprIsValue (Lam b e) = isId b || exprIsValue e +exprIsValue (Note _ e) = exprIsValue e +exprIsValue other_expr + = go other_expr 0 + where + go (Var f) n_args = idAppIsValue f n_args + + go (App f a) n_args + | isTypeArg a = go f n_args + | otherwise = go f (n_args + 1) + + go (Note _ f) n_args = go f n_args + + go other n_args = False + +idAppIsValue :: Id -> Int -> Bool +idAppIsValue id n_val_args + = case idFlavour id of + DataConId _ -> True + PrimOpId _ -> n_val_args < idArity id + other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) + | otherwise -> n_val_args < idArity id + -- A worry: what if an Id's unfolding is just itself: + -- then we could get an infinite loop... +\end{code} -If so, it returns +\begin{code} +exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) +exprIsConApp_maybe expr + = analyse (collectArgs expr) + where + analyse (Var fun, args) + | maybeToBool maybe_con_app = maybe_con_app + where + maybe_con_app = case isDataConId_maybe fun of + Just con | length args >= dataConRepArity con + -- Might be > because the arity excludes type args + -> Just (con, args) + other -> Nothing - Just (error ty' args) + analyse (Var fun, []) + = case maybeUnfoldingTemplate (idUnfolding fun) of + Nothing -> Nothing + Just unf -> exprIsConApp_maybe unf -where ty' is supplied as an argument to maybeErrorApp. + analyse other = Nothing +\end{code} -Here's where it is useful: - case (error ty "Foo" e1 e2) of - ===> - error ty' "Foo" +%************************************************************************ +%* * +\subsection{Eta reduction and expansion} +%* * +%************************************************************************ -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@. +@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr. -Note: we *avoid* the case where ty' might end up as a primitive type: -this is very uncool (totally wrong). +e.g. \ x y -> f x y ===> f -NOTICE: in the example above we threw away e1 and e2, but not the -string "Foo". How did we know to do that? +But we only do this if it gets rid of a whole lambda, not part. +The idea is that lambdas are often quite helpful: they indicate +head normal forms, so we don't want to chuck them away lightly. -Answer: for now anyway, we only handle the case of a function whose -type is of form +\begin{code} +etaReduceExpr :: CoreExpr -> CoreExpr + -- ToDo: we should really check that we don't turn a non-bottom + -- lambda into a bottom variable. Sigh - bottomingFn :: forall a. t1 -> ... -> tn -> a - ^---------------------^ NB! +etaReduceExpr expr@(Lam bndr body) + = check (reverse binders) body + where + (binders, body) = collectBinders expr -Furthermore, we only count a bottomingApp if the function is applied -to more than n args. If so, we transform: + check [] body + | not (any (`elemVarSet` body_fvs) binders) + = body -- Success! + where + body_fvs = exprFreeVars body - bottomingFn ty e1 ... en en+1 ... em -to - bottomingFn ty' e1 ... en + check (b : bs) (App fun arg) + | (varToCoreExpr b `cheapEqExpr` arg) + = check bs fun -That is, we discard en+1 .. em + check _ _ = expr -- Bale out -\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 +etaReduceExpr expr = expr -- The common case \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 +exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to + -- without doing much work +-- This is used when eta expanding +-- e ==> \xy -> e x y +-- +-- It returns 1 (or more) to: +-- case x of p -> \s -> ... +-- because for I/O ish things we really want to get that \s to the top. +-- We are prepared to evaluate x each time round the loop in order to get that +-- Hence "generous" arity + +exprEtaExpandArity e + = go e `max` 0 -- Never go -ve! 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 + go (Var v) = idArity v + go (App f (Type _)) = go f + go (App f a) | exprIsCheap a = go f - 1 + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Note n e) | ok_note n = go e + go (Case scrut _ alts) + | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts] + go (Let b e) + | all exprIsCheap (rhssOfBind b) = go e + + go other = 0 + + ok_note (Coerce _ _) = True + ok_note InlineCall = True + ok_note other = False + -- Notice that we do not look through __inline_me__ + -- This one is a bit more surprising, but consider + -- f = _inline_me (\x -> e) + -- We DO NOT want to eta expand this to + -- f = \x -> (_inline_me (\x -> e)) x + -- because the _inline_me gets dropped now it is applied, + -- giving just + -- f = \x -> e + -- A Bad Idea + +min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest +min_zero (x:xs) = go x xs + where + go 0 xs = 0 -- Nothing beats zero + go min [] = min + go min (x:xs) | x < min = go x xs + | otherwise = go min xs + \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 (Lit lit1) (Lit lit2) = lit1 == lit2 +cheapEqExpr (Type t1) (Type t2) = t1 == t2 -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 _ _ = False -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) +exprIsBig :: Expr b -> Bool +-- Returns True of expressions that are too big to be compared by cheapEqExpr +exprIsBig (Lit _) = False +exprIsBig (Var v) = False +exprIsBig (Type t) = False +exprIsBig (App f a) = exprIsBig f || exprIsBig a +exprIsBig other = True +\end{code} -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) +\begin{code} +eqExpr :: CoreExpr -> CoreExpr -> Bool + -- Works ok at more general type, but only needed at CoreExpr +eqExpr e1 e2 + = eq emptyVarEnv e1 e2 where - (binders, rhss) = unzip binds + -- 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 (Lit lit1) (Lit lit2) = lit1 == lit2 + 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 t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2 + eq_note env InlineCall InlineCall = True + eq_note env other1 other2 = False \end{code} + +%************************************************************************ +%* * +\subsection{The size of an expression} +%* * +%************************************************************************ + \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) +coreBindsSize :: [CoreBind] -> Int +coreBindsSize bs = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int + -- A measure of the size of the expressions + -- It also forces the expression pretty drastically as a side effect +exprSize (Var v) = varSize v +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as +exprSize (Note n e) = noteSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 + +noteSize (SCC cc) = cc `seq` 1 +noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 +noteSize InlineCall = 1 +noteSize InlineMe = 1 +noteSize (TermUsg usg) = usg `seq` 1 + +exprsSize = foldr ((+) . exprSize) 0 + +varSize :: Var -> Int +varSize b | isTyVar b = 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +varsSize = foldr ((+) . varSize) 0 + +bindSize (NonRec b e) = varSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize (b,e) = varSize b + exprSize e + +altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \end{code} + +%************************************************************************ +%* * +\subsection{Hashing} +%* * +%************************************************************************ + \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 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) - -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) - 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) +hashExpr :: CoreExpr -> Int +hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt + | otherwise = hash + where + hash = abs (hash_expr e) -- Negative numbers kill UniqFM + +hash_expr (Note _ e) = hash_expr e +hash_expr (Let (NonRec b r) e) = hashId b +hash_expr (Let (Rec ((b,r):_)) e) = hashId b +hash_expr (Case _ b _) = hashId b +hash_expr (App f e) = hash_expr f * fast_hash_expr e +hash_expr (Var v) = hashId v +hash_expr (Lit lit) = hashLiteral lit +hash_expr (Lam b _) = hashId b +hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen + +fast_hash_expr (Var v) = hashId v +fast_hash_expr (Lit lit) = hashLiteral lit +fast_hash_expr (App f (Type _)) = fast_hash_expr f +fast_hash_expr (App f a) = fast_hash_expr a +fast_hash_expr (Lam b _) = hashId b +fast_hash_expr other = 1 + +hashId :: Id -> Int +hashId id = hashName (idName id) \end{code}