%
-% (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, exprArity,
+ 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,
-IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
+ -- Hashing
+ hashExpr,
-import CoreSyn
+ -- Equality
+ cheapEqExpr, eqExpr, applyTypeToArgs
+ ) where
-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 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"
+import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon )
+import CostCentre ( CostCentre )
+import Unique ( buildIdKey, augmentIdKey )
+import Util ( zipWithEqual, mapAccumL )
+import Maybes ( maybeToBool )
+import Outputable
+import TysPrim ( alphaTy ) -- Debugging only
\end{code}
+
%************************************************************************
%* *
\subsection{Find the type of a Core atom/expression}
%************************************************************************
\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 <ditto> 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
+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}
-mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
+%************************************************************************
+%* *
+\subsection{Figuring out things about expressions}
+%* *
+%************************************************************************
-mkCoApps fun args = co_thing (mkGenApp fun) args
-mkCoCon con args = co_thing (Con con) args
-mkCoPrim op args = co_thing (Prim op) args
+@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
-co_thing :: ([CoreArg] -> CoreExpr)
- -> [CoreArgOrExpr]
- -> UniqSM CoreExpr
+@exprIsBottom@ is true of expressions that are guaranteed to diverge
-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}
\begin{code}
-argToExpr ::
- GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
-
-argToExpr (VarArg v) = Var v
-argToExpr (LitArg lit) = Lit lit
+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}
-\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: <var> applied to <args>
- = 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]
+@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}
-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}
+ That is, exprIsDupable returns True of (f x) even if
+ f is very very expensive to call.
+
+ Its only purpose is to avoid fruitless let-binding
+ and then inlining of case join points
-@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
- )
+exprIsDupable (Type _) = True
+exprIsDupable (Var v) = True
+exprIsDupable (Lit lit) = litIsDupable lit
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable expr
+ = go expr 0
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
- }
+ 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}
-\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}
+@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.]
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
+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:
-Probably a little too HACKY [WDP].
+ * case e of
+ pi -> ei
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
+ where e, and all the ei are cheap; and
-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
- }
+ * let x = e
+ in b
- 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
- }
+ where e and b are cheap; and
- --------------
- unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
+ * op x1 ... xn
- -------------------------
- doesn't_mention var (ValArg (VarArg v)) = v /= var
- doesn't_mention var other = True
+ where op is a cheap primitive operator
- -------------------------
- only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
- only_from case_ables other = True
--}
-\end{code}
+ * error "foo"
-All the following functions operate on binders, perform a uniform
-transformation on them; ie. the function @(\ x -> (x,False))@
-annotates all binders with False.
+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}
-unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
-unTagBinders expr = bop_expr fst expr
-
-unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
-unTagBindersAlts alts = bop_alts fst alts
+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 (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
+ -- Experimentally, treat (case x of ...) as cheap
+ -- This improves arities of overloaded functions where
+ -- there is only dictionary selection (no construction) involved
+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
+ -- a WHNF, 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}
-\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)
-\end{code}
+exprOkForSpeculation returns True of an expression that it is
-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.
+ * safe to evaluate even if normal order eval might not
+ evaluate the expression at all, or
-Example:
-\begin{verbatim}
- case (case <something> of
- True -> <rhs>
- False -> error "Foo") of
- <alts>
+ * safe *not* to evaluate even if normal order would do so
-===>
+It returns True iff
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> case error "Foo" of
- <alts>
+ the expression guarantees to terminate,
+ soon,
+ without raising an exception,
+ without causing a side effect (e.g. writing a mutable variable)
-===>
+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 <something> of
- True -> case <rhs> of
- <alts>
- False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} 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 (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
-
- deflt_rhs NoDefault = []
- deflt_rhs (BindDefault _ rhs) = [rhs]
-
- not_error_app rhs
- = case (maybeErrorApp rhs Nothing) of
- Just _ -> False
- Nothing -> True
+ 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}
-maybeErrorApp checks whether an expression is of the form
- error ty args
+\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}
-If so, it returns
+@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
- Just (error ty' args)
+and to decide whether it's safe to discard a `seq`
-where ty' is supplied as an argument to maybeErrorApp.
+So, it does *not* treat variables as evaluated, unless they say they are
-Here's where it is useful:
+\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}
- case (error ty "Foo" e1 e2) of <alts>
- ===>
- error ty' "Foo"
+\begin{code}
+exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
+exprArity (Lam b e) | isTyVar b = exprArity e
+ | otherwise = 1 + exprArity e
+
+exprArity (Note note e) | ok_note note = exprArity e
+ where
+ ok_note (Coerce _ _) = True
+ -- We *do* look through coerces when getting arities.
+ -- Reason: arities are to do with *representation* and
+ -- work duplication.
+ ok_note InlineMe = True
+ ok_note InlineCall = True
+ ok_note other = False
+ -- SCC and TermUsg might be over-conservative?
+
+exprArity other = 0
+\end{code}
-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@.
+\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
-Note: we *avoid* the case where ty' might end up as a primitive type:
-this is very uncool (totally wrong).
+ analyse (Var fun, [])
+ = case maybeUnfoldingTemplate (idUnfolding fun) of
+ Nothing -> Nothing
+ Just unf -> exprIsConApp_maybe unf
-NOTICE: in the example above we threw away e1 and e2, but not the
-string "Foo". How did we know to do that?
+ analyse other = Nothing
+\end{code}
-Answer: for now anyway, we only handle the case of a function whose
-type is of form
- bottomingFn :: forall a. t1 -> ... -> tn -> a
- ^---------------------^ NB!
+%************************************************************************
+%* *
+\subsection{Eta reduction and expansion}
+%* *
+%************************************************************************
-Furthermore, we only count a bottomingApp if the function is applied
-to more than n args. If so, we transform:
+@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
- bottomingFn ty e1 ... en en+1 ... em
-to
- bottomingFn ty' e1 ... en
+e.g. \ x y -> f x y ===> f
-That is, we discard en+1 .. em
+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.
\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
+etaReduceExpr :: CoreExpr -> CoreExpr
+ -- ToDo: we should really check that we don't turn a non-bottom
+ -- lambda into a bottom variable. Sigh
+
+etaReduceExpr expr@(Lam bndr body)
+ = check (reverse binders) body
where
- Just result_ty = result_ty_maybe
+ (binders, body) = collectBinders expr
+
+ check [] body
+ | not (any (`elemVarSet` body_fvs) binders)
+ = body -- Success!
+ where
+ body_fvs = exprFreeVars body
+
+ check (b : bs) (App fun arg)
+ | (varToCoreExpr b `cheapEqExpr` arg)
+ = check bs fun
+
+ check _ _ = expr -- Bale out
+
+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}
-\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}
+
+%************************************************************************
+%* *
+\subsection{The size of an expression}
+%* *
+%************************************************************************
\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)
- 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)
+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}
-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))
+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}