%
-% (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,
+ IdSubst, SubstCoreExpr(..),
- substCoreExpr, substCoreBindings
+ coreExprType, exprFreeVars, exprSomeFreeVars,
- , mkCoreIfThenElse
- , argToExpr
- , unTagBinders, unTagBindersAlts
- , manifestlyWHNF, manifestlyBottom
- , maybeErrorApp
- , nonErrorRHSs
- , squashableDictishCcExpr
- , exprSmallEnoughToDup
-{-
- coreExprArity,
- isWrapperFor,
+ exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
+ FormSummary(..), mkFormSummary, whnfOrBottom,
+ cheapEqExpr,
--} ) where
+ substExpr, substId, substIds,
+ idSpecVars, idFreeVars,
-IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
+ squashableDictishCcExpr
+ ) where
-import CoreSyn
+#include "HsVersions.h"
-import CostCentre ( isDictCC )
-import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
- toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
- addOneToIdEnv, growIdEnvList, lookupIdEnv,
- isNullIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}
- )
-import IdInfo ( arityMaybe )
-import Literal ( literalType, isNoRepLit, Literal(..) )
-import Maybes ( catMaybes, maybeToBool )
-import PprCore
-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, SYN_IE(TyVarEnv)
- )
-import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
- getFunTy_maybe, applyTy, isPrimType,
- splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
- )
-import TysWiredIn ( trueDataCon, falseDataCon )
-import UniqSupply ( initUs, returnUs, thenUs,
- mapUs, mapAndUnzipUs, getUnique,
- SYN_IE(UniqSM), UniqSupply
- )
-import Usage ( SYN_IE(UVar) )
-import Util ( zipEqual, panic, pprPanic, assertPanic )
+import {-# SOURCE #-} CoreUnfold ( noUnfolding, hasUnfolding )
-type TypeEnv = TyVarEnv Type
-applyUsage = panic "CoreUtils.applyUsage:ToDo"
+import CoreSyn
+import PprCore () -- Instances only
+import Var ( IdOrTyVar, isId, isTyVar )
+import VarSet
+import VarEnv
+import Name ( isLocallyDefined )
+import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
+import Id ( Id, idType, setIdType, idUnique, isBottomingId,
+ getIdArity, idFreeTyVars,
+ getIdSpecialisation, setIdSpecialisation,
+ getInlinePragma, setInlinePragma,
+ getIdUnfolding, setIdUnfolding
+ )
+import IdInfo ( arityLowerBound, InlinePragInfo(..) )
+import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
+import CostCentre ( isDictCC, CostCentre )
+import Const ( Con, conType )
+import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
+ splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
+ fullSubstTy, substTyVar )
+import Unique ( buildIdKey, augmentIdKey )
+import Util ( zipWithEqual, mapAccumL )
+import Outputable
+import TysPrim ( alphaTy ) -- Debgging only
\end{code}
+
%************************************************************************
%* *
-\subsection{Find the type of a Core atom/expression}
+\subsection{Substitutions}
%* *
%************************************************************************
\begin{code}
-coreExprType :: CoreExpr -> Type
-
-coreExprType (Var var) = idType var
-coreExprType (Lit lit) = literalType lit
+type IdSubst = IdEnv SubstCoreExpr -- Maps Ids to SubstCoreExpr
-coreExprType (Let _ body) = coreExprType body
-coreExprType (SCC _ expr) = coreExprType expr
-coreExprType (Case _ alts) = coreAltsType alts
-
-coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+data SubstCoreExpr
+ = Done CoreExpr -- No more substitution needed
+ | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution
+\end{code}
--- a Con is a fully-saturated application of a data constructor
--- a Prim is <ditto> of a PrimOp
+%************************************************************************
+%* *
+\subsection{Find the type of a Core atom/expression}
+%* *
+%************************************************************************
-coreExprType (Con con args) = applyTypeToArgs (idType con) args
-coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
+\begin{code}
+coreExprType :: CoreExpr -> Type
-coreExprType (Lam (ValBinder binder) expr)
- = mkFunTys [idType binder] (coreExprType expr)
+coreExprType (Var var) = idType var
+coreExprType (Let _ body) = coreExprType body
+coreExprType (Case _ _ ((_,_,rhs):_)) = coreExprType rhs
-coreExprType (Lam (TyBinder tyvar) expr)
- = mkForAllTy tyvar (coreExprType expr)
+coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note other_note e) = coreExprType e
-coreExprType (Lam (UsageBinder uvar) expr)
- = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
+coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
-coreExprType (App expr (TyArg ty))
- = applyTy (coreExprType expr) ty
+coreExprType (Lam binder expr)
+ | isId binder = idType binder `mkFunTy` coreExprType expr
+ | isTyVar binder = mkForAllTy binder (coreExprType expr)
-coreExprType (App expr (UsageArg use))
- = applyUsage (coreExprType expr) use
+coreExprType e@(App _ _)
+ = case collectArgs e of
+ (fun, args) -> applyTypeToArgs e (coreExprType fun) args
-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 other = pprTrace "coreExprType" (ppr other) alphaTy
\end{code}
\begin{code}
-coreAltsType :: CoreCaseAlts -> Type
+-- The "e" argument is just for debugging
-coreAltsType (AlgAlts [] deflt) = default_ty deflt
-coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
+applyTypeToArgs e op_ty [] = op_ty
-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
+applyTypeToArgs e op_ty (Type ty : args)
+ = -- Accumulate type arguments so we can instantiate all at once
+ 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" (ppr 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
+ | 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
+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) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
+ -- should be treated as a value
+ go n (Let _ e) = OtherForm
+ go n (Case _ _ _) = OtherForm
-co_thing :: ([CoreArg] -> CoreExpr)
- -> [CoreArgOrExpr]
- -> UniqSM CoreExpr
+ 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
-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))
+ go n (App fun (Type _)) = go n fun -- Ignore type args
+ go n (App fun arg) = go (n+1) fun
+
+ go n (Var f) | isBottomingId f = BottomForm
+ go 0 (Var f) = VarForm
+ go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
+ | otherwise = OtherForm
\end{code}
-\begin{code}
-argToExpr ::
- GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
+@exprIsTrivial@ is true of expressions we are unconditionally
+ happy to duplicate; simple variables and constants,
+ and type applications.
+
+@exprIsDupable@ is true of expressions that can be duplicated at a modest
+ cost in space, but without duplicating any work.
+
+
+@exprIsBottom@ is true of expressions that are guaranteed to diverge
-argToExpr (VarArg v) = Var v
-argToExpr (LitArg lit) = Lit lit
-\end{code}
\begin{code}
-exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-exprSmallEnoughToDup expr
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v | length vargs == 0 -> True
- _ -> False
- }
-
-{- LATER:
-WAS: MORE CLEVER:
-exprSmallEnoughToDup expr -- for now, just: <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
- }
--}
+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}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form. It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
\begin{code}
-manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _) = True
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Coerce _ _ e) = 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
- }
+exprIsDupable (Type _) = True
+exprIsDupable (Con con args) = conIsCheap con &&
+ all exprIsDupable args &&
+ valArgCount args <= dupAppSize
+
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable expr = case collectArgs expr of
+ (Var v, args) -> n_val_args == 0 ||
+ (n_val_args < fun_arity &&
+ all exprIsDupable args &&
+ n_val_args <= dupAppSize)
+ where
+ n_val_args = valArgCount args
+ fun_arity = arityLowerBound (getIdArity v)
+
+ _ -> False
+
+dupAppSize :: Int
+dupAppSize = 4 -- Size of application we are prepared to duplicate
\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}).
+@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:
-\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) = 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'
+ * case e of
+ pi -> ei
+
+ where e, and all the ei are cheap; and
+
+ * let x = e
+ in b
- mbprim (_,e') = manifestlyBottom e'
+ where e and b are cheap; and
- mbdef NoDefault = True
- mbdef (BindDefault _ e') = manifestlyBottom e'
+ * op x1 ... xn
+
+ where op is a cheap primitive operator
+
+\begin{code}
+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
+
+ (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!
+
+ (Var f, args) ->
+ let
+ num_val_args = valArgCount args
+ in
+ num_val_args == 0 || -- Just a type application of
+ -- a variable (f t1 t2 t3)
+ -- counts as WHNF
+ num_val_args < arityLowerBound (getIdArity f)
-manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, _, _, _) ->
- case fun of
- Var f | isBottomingId f -> True
- -- Application of a function which always gives
- -- bottom; we treat this as a WHNF, because it
- -- certainly doesn't need to be shared!
_ -> False
- }
\end{code}
+
\begin{code}
-{-LATER:
-coreExprArity
- :: (Id -> Maybe (GenCoreExpr bndr Id))
- -> GenCoreExpr bndr Id
- -> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
- where
- further
- = case f v of
- Nothing -> 0
- Just expr -> coreExprArity f expr
- info = case (arityMaybe (getIdArity v)) of
- Nothing -> 0
- Just arity -> arity
-coreExprArity f _ = 0
+exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
+exprIsBottom (Note _ e) = exprIsBottom e
+exprIsBottom (Let _ e) = exprIsBottom e
+exprIsBottom (Case e _ _) = exprIsBottom e -- Just chek the scrut
+exprIsBottom (Con _ _) = False
+exprIsBottom (App e _) = exprIsBottom e
+exprIsBottom (Var v) = isBottomingId v
+exprIsBottom (Lam _ _) = False
\end{code}
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
+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.
-Probably a little too HACKY [WDP].
+We treat applications of buildId and augmentId as honorary WHNFs, because we
+want them to get exposed
\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
+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 ||
+ v_uniq == buildIdKey ||
+ v_uniq == augmentIdKey
+ where
+ n_val_args = valArgCount args
+ fun_arity = arityLowerBound (getIdArity v)
+ v_uniq = idUnique v
+
+ _ -> False
+\end{code}
+
+I don't like this function but I'n not confidnt enough to change it.
-expr `isWrapperFor` var
- = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
- unravel_casing args body
- --NO, THANKS: && not (null args)
- }
+\begin{code}
+squashableDictishCcExpr :: CostCentre -> Expr b f -> Bool
+squashableDictishCcExpr cc expr
+ | isDictCC cc = False -- that was easy...
+ | otherwise = squashable expr
where
- var's_worker = getWorkerId (getIdStrictness var)
-
- is_elem = isIn "isWrapperFor"
-
- --------------
- unravel_casing case_ables (Case scrut alts)
- = case (collectArgs scrut) of { (fun, _, _, vargs) ->
- case fun of
- Var scrut_var -> let
- answer =
- scrut_var /= var && all (doesn't_mention var) vargs
- && scrut_var `is_elem` case_ables
- && unravel_alts case_ables alts
- in
- answer
-
- _ -> False
- }
-
- unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
- case fun of
- Var wrkr -> let
- answer =
- -- DOESN'T WORK: wrkr == var's_worker
- wrkr /= var
- && isWorkerId wrkr
- && all (doesn't_mention var) vargs
- && all (only_from case_ables) vargs
- in
- answer
-
- _ -> False
- }
-
- --------------
- unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
-
- -------------------------
- doesn't_mention var (ValArg (VarArg v)) = v /= var
- doesn't_mention var other = True
-
- -------------------------
- only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
- only_from case_ables other = True
--}
+ squashable (Var _) = True
+ squashable (Con _ _) = True -- I think so... WDP 94/09
+ squashable (App f a)
+ | isTypeArg a = squashable f
+ squashable other = False
\end{code}
-All the following functions operate on binders, perform a uniform
-transformation on them; ie. the function @(\ x -> (x,False))@
-annotates all binders with False.
+
+@cheapEqExpr@ is a cheap equality test which bales out fast!
+ True => definitely equal
+ False => may or may not be equal
\begin{code}
-unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
-unTagBinders expr = bop_expr fst expr
+cheapEqExpr :: Expr b f -> Expr b f -> Bool
-unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
-unTagBindersAlts alts = bop_alts fst alts
-\end{code}
+cheapEqExpr (Var v1) (Var v2) = v1==v2
+cheapEqExpr (Con con1 args1) (Con con2 args2)
+ = con1 == con2 &&
+ and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
-\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}
+cheapEqExpr (App f1 a1) (App f2 a2)
+ = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
-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.
+cheapEqExpr (Type t1) (Type t2) = t1 == t2
-Example:
-\begin{verbatim}
- case (case <something> of
- True -> <rhs>
- False -> error "Foo") of
- <alts>
+cheapEqExpr _ _ = False
+\end{code}
-===>
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> case error "Foo" of
- <alts>
+%************************************************************************
+%* *
+\section{Finding the free variables of an expression}
+%* *
+%************************************************************************
-===>
+This function simply finds the free variables of an expression.
+So far as type variables are concerned, it only finds tyvars that are
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} don't get duplicated.
+ * free in type arguments,
+ * free in the type of a binder,
-\begin{code}
-nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
+but not those that are free in the type of variable occurrence.
-nonErrorRHSs alts
- = filter not_error_app (find_rhss alts)
- where
- find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
- find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
+\begin{code}
+exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
+exprFreeVars = exprSomeFreeVars isLocallyDefined
- deflt_rhs NoDefault = []
- deflt_rhs (BindDefault _ rhs) = [rhs]
+exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+ -> CoreExpr
+ -> IdOrTyVarSet
+exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
- not_error_app rhs
- = case (maybeErrorApp rhs Nothing) of
- Just _ -> False
- Nothing -> True
+type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
\end{code}
-maybeErrorApp checks whether an expression is of the form
- error ty args
+\begin{code}
+type FV = InterestingVarFun
+ -> IdOrTyVarSet -- In scope
+ -> IdOrTyVarSet -- Free vars
-If so, it returns
+union :: FV -> FV -> FV
+union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
- Just (error ty' args)
+noVars :: FV
+noVars fv_cand in_scope = emptyVarSet
-where ty' is supplied as an argument to maybeErrorApp.
+oneVar :: IdOrTyVar -> FV
+oneVar var fv_cand in_scope
+ | keep_it fv_cand in_scope var = unitVarSet var
+ | otherwise = emptyVarSet
-Here's where it is useful:
+someVars :: IdOrTyVarSet -> FV
+someVars vars fv_cand in_scope
+ = filterVarSet (keep_it fv_cand in_scope) vars
- case (error ty "Foo" e1 e2) of <alts>
- ===>
- error ty' "Foo"
+keep_it fv_cand in_scope var
+ | var `elemVarSet` in_scope = False
+ | fv_cand var = True
+ | otherwise = False
-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).
+addBndr :: CoreBndr -> FV -> FV
+addBndr bndr fv fv_cand in_scope
+ | isId bndr = inside_fvs `unionVarSet` someVars (idFreeVars bndr) fv_cand in_scope
+ | otherwise = inside_fvs
+ where
+ inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
-NOTICE: in the example above we threw away e1 and e2, but not the
-string "Foo". How did we know to do that?
+addBndrs :: [CoreBndr] -> FV -> FV
+addBndrs bndrs fv = foldr addBndr fv bndrs
+\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!
+\begin{code}
+expr_fvs :: CoreExpr -> FV
-Furthermore, we only count a bottomingApp if the function is applied
-to more than n args. If so, we transform:
+expr_fvs (Type ty) = someVars (tyVarsOfType ty)
+expr_fvs (Var var) = oneVar var
+expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
+expr_fvs (Note _ expr) = expr_fvs expr
+expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
+expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
- bottomingFn ty e1 ... en en+1 ... em
-to
- bottomingFn ty' e1 ... en
+expr_fvs (Case scrut bndr alts)
+ = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts)
+ where
+ alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
-That is, we discard en+1 .. em
+expr_fvs (Let (NonRec bndr rhs) body)
+ = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
-\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
+expr_fvs (Let (Rec pairs) body)
+ = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
- Just result_ty = result_ty_maybe
+ (bndrs,rhss) = unzip pairs
\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
+Given an Id, idSpecVars returns all its specialisations.
+We extract these from its SpecEnv.
+This is used by the occurrence analyser and free-var finder;
+we regard an Id's specialisations as free in the Id's definition.
+
+\begin{code}
+idSpecVars :: Id -> IdOrTyVarSet
+idSpecVars id
+ = foldr (unionVarSet . spec_item_fvs)
+ emptyVarSet
+ (specEnvToList (getIdSpecialisation id))
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
+ spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet
+ (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs)
+ tyvars
+
+idFreeVars :: Id -> IdOrTyVarSet
+idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id
\end{code}
+
%************************************************************************
%* *
-\subsection{Core-renaming utils}
+\section{Substitution}
%* *
%************************************************************************
-\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@).
+This expression substituter deals correctly with name capture, much
+like Type.substTy.
-@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.
+BUT NOTE that substExpr silently discards the
+ unfolding, and
+ spec env
+IdInfo attached to any binders in the expression. It's quite
+tricky to do them 'right' in the case of mutually recursive bindings,
+and so far has proved unnecessary.
\begin{code}
-type ValEnv = IdEnv CoreExpr
-
-do_CoreBindings :: ValEnv
- -> TypeEnv
- -> [CoreBinding]
- -> UniqSM [CoreBinding]
-
-do_CoreBinding :: ValEnv
- -> TypeEnv
- -> CoreBinding
- -> UniqSM (CoreBinding, ValEnv)
-
-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)
+substExpr :: TyVarSubst -> IdSubst -- Substitution
+ -> IdOrTyVarSet -- Superset of in-scope
+ -> CoreExpr
+ -> CoreExpr
-do_CoreBinding venv tenv (NonRec binder rhs)
- = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
+substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
- 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)
+subst_expr env@(te, ve, in_scope) expr
+ = go expr
where
- (binders, rhss) = unzip binds
+ go (Var v) = case lookupVarEnv ve v of
+ Just (Done e')
+ -> e'
+
+ Just (SubstMe e' te' ve')
+ -> subst_expr (te', ve', in_scope) e'
+
+ Nothing -> case lookupVarSet in_scope v of
+ Just v' -> Var v'
+ Nothing -> Var v
+ -- NB: we look up in the in_scope set because the variable
+ -- there may have more info. In particular, when substExpr
+ -- is called from the simplifier, the type inside the *occurrences*
+ -- of a variable may not be right; we should replace it with the
+ -- binder, from the in_scope set.
+
+ go (Type ty) = Type (go_ty ty)
+ go (Con con args) = Con con (map go args)
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note (go_note note) (go e)
+
+ go (Lam bndr body) = Lam bndr' (subst_expr env' body)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
+ where
+ (ve', in_scope', _, bndrs')
+ = substIds clone_fn te ve in_scope undefined (map fst pairs)
+ env' = (te, ve', in_scope')
+ pairs' = bndrs' `zip` rhss'
+ rhss' = map (subst_expr env' . snd) pairs
+
+ go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
+ where
+ (env', bndr') = go_bndr env bndr
+
+ go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
+ where
+ (env', bndrs') = mapAccumL go_bndr env bndrs
+
+ go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
+ go_note note = note
+
+ go_ty ty = fullSubstTy te in_scope ty
+
+ go_bndr (te, ve, in_scope) bndr
+ | isTyVar bndr
+ = case substTyVar te in_scope bndr of
+ (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
+
+ | otherwise
+ = case substId clone_fn te ve in_scope undefined bndr of
+ (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
+
+
+ clone_fn in_scope _ bndr
+ | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
+ | otherwise = Nothing
+
\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}
+Substituting in binders is a rather tricky part of the whole compiler.
\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)
+substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
+ -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
+ -> us -- Unique supply
+ -> [Id]
+ -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
+ us, -- New unique supply
+ [Id])
+
+substIds clone_fn ty_subst id_subst in_scope us []
+ = (id_subst, in_scope, us, [])
+
+substIds clone_fn ty_subst id_subst in_scope us (id:ids)
+ = case (substId clone_fn ty_subst id_subst in_scope us id) of {
+ (id_subst', in_scope', us', id') ->
+
+ case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
+ (id_subst'', in_scope'', us'', ids') ->
+
+ (id_subst'', in_scope'', us'', id':ids')
+ }}
+
+
+substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
+ -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
+ -> us -- Unique supply
+ -> Id
+ -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
+ us, -- New unique supply
+ Id)
+
+-- Returns an Id with empty unfolding and spec-env.
+-- It's up to the caller to sort these out.
+
+substId clone_fn
+ ty_subst id_subst in_scope
+ us id
+ | old_id_will_do
+ -- No need to clone, but we *must* zap any current substitution
+ -- for the variable. For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+ = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
+
+ | otherwise
+ = (extendVarEnv id_subst id (Done (Var new_id)),
+ extendVarSet in_scope new_id,
+ new_us,
+ new_id)
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)
+ id_ty = idType id
+ old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
+
+ -- id1 has its type zapped
+ (id1,old1) | isEmptyVarEnv ty_subst
+ || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
+ | otherwise = (setIdType id ty', False)
+
+ ty' = fullSubstTy ty_subst in_scope id_ty
+
+ -- id2 has its SpecEnv zapped
+ -- It's filled in later by
+ (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
+ | otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
+ spec_env = getIdSpecialisation id
+
+ -- id3 has its Unfolding zapped
+ -- This is very important; occasionally a let-bound binder is used
+ -- as a binder in some lambda, in which case its unfolding is utterly
+ -- bogus. Also the unfolding uses old binders so if we left it we'd
+ -- have to substitute it. Much better simply to give the Id a new
+ -- unfolding each time, which is what the simplifier does.
+ (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
+ | otherwise = (id2, True)
+
+ -- new_id is cloned if necessary
+ (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
+ Nothing -> (us, id3, False)
+ Just (us', id') -> (us', id', True)
+
+ -- new_id_bndr has its Inline info neutered. We must forget about whether it
+ -- was marked safe-to-inline, because that isn't necessarily true in
+ -- the simplified expression. We do this for the *binder* which will
+ -- be used at the binding site, but we *dont* do it for new_id, which
+ -- is put into the in_scope env. Why not? Because the in_scope env
+ -- carries down the occurrence information to usage sites!
+ --
+ -- Net result: post-simplification, occurrences may have over-optimistic
+ -- occurrence info, but binders won't.
+{- (new_id_bndr, old4)
+ = case getInlinePragma id of
+ ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
+ other -> (new_id, True)
+-}
\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}
+
+
+
+