-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
+-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
- -- Construction
- mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
+ -- * Constructing expressions
+ mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
- mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
+ mkAltExpr, mkPiType, mkPiTypes,
- -- Taking expressions apart
+ -- * Taking expressions apart
findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
- -- Properties of expressions
+ -- * Properties of expressions
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsHNF,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe, exprIsBottom,
+ exprIsConApp_maybe,
+ exprBotStrictness_maybe,
rhsIsStatic,
- -- Arity and eta expansion
+ -- * Arity and eta expansion
+ -- exprIsBottom, Not used
manifestArity, exprArity,
exprEtaExpandArity, etaExpand,
- -- Size
+ -- * Expression and bindings size
coreBindsSize, exprSize,
- -- Hashing
+ -- * Hashing
hashExpr,
- -- Equality
- cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
+ -- * Equality
+ cheapEqExpr, tcEqExpr, tcEqExprX,
+ -- * Manipulating data constructors and types
+ applyTypeToArgs, applyTypeToArg,
dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
) where
#include "HsVersions.h"
+import StaticFlags ( opt_NoStateHack )
import CoreSyn
import CoreFVs
import PprCore
import Type
import Coercion
import TyCon
-import TysWiredIn
import CostCentre
import BasicTypes
import Unique
\begin{code}
exprType :: CoreExpr -> Type
-
+-- ^ Recover the type of a well-typed Core expression. Fails when
+-- applied to the actual 'CoreSyn.Type' expression as it cannot
+-- really be said to have a type
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
coreAltType :: CoreAlt -> Type
+-- ^ Returns the type of the alternatives right hand side
coreAltType (_,_,rhs) = exprType rhs
coreAltsType :: [CoreAlt] -> Type
+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
coreAltsType (alt:_) = coreAltType alt
coreAltsType [] = panic "corAltsType"
\end{code}
-@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.
-
\begin{code}
-mkPiType :: Var -> Type -> Type -- The more polymorphic version
-mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
-
-mkPiTypes vs ty = foldr mkPiType ty vs
+mkPiType :: Var -> Type -> Type
+-- ^ Makes a @(->)@ type or a forall type, depending
+-- on whether it is given a type variable or a term variable.
+mkPiTypes :: [Var] -> Type -> Type
+-- ^ 'mkPiType' for multiple type or value arguments
mkPiType v ty
| isId v = mkFunTy (idType v) ty
| otherwise = mkForAllTy v ty
+
+mkPiTypes vs ty = foldr mkPiType ty vs
\end{code}
\begin{code}
applyTypeToArg :: Type -> CoreExpr -> Type
+-- ^ Determines the type resulting from applying an expression to a function with the given type
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
applyTypeToArg fun_ty _ = funResultTy fun_ty
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
--- A more efficient version of applyTypeToArg
--- when we have several args
--- The first argument is just for debugging
+-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
+-- The first argument is just for debugging, and gives some context
applyTypeToArgs _ op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
go rev_tys (Type ty : args) = go (ty:rev_tys) args
go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
where
- op_ty' = applyTys op_ty (reverse rev_tys)
+ op_ty' = applyTysD msg op_ty (reverse rev_tys)
+ msg = ptext (sLit "applyTypeToArgs") <+>
+ panic_msg e op_ty
applyTypeToArgs e op_ty (_ : args)
= case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> applyTypeToArgs e res_ty args
- Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
-\end{code}
-
+ Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
+panic_msg :: CoreExpr -> Type -> SDoc
+panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-mkNote removes redundant coercions, and SCCs where possible
-
-\begin{code}
-#ifdef UNUSED
-mkNote :: Note -> CoreExpr -> CoreExpr
-mkNote (SCC cc) expr = mkSCC cc expr
-mkNote InlineMe expr = mkInlineMe expr
-mkNote note expr = Note note expr
-#endif
-\end{code}
-
-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.
-
-We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
-bindings like
- fw = ...
- f = inline_me (coerce t fw)
-As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
-We want the split, so that the coerces can cancel at the call site.
-
-However, we can get left with tiresome type applications. Notably, consider
- f = /\ a -> let t = e in (t, w)
-Then lifting the let out of the big lambda gives
- t' = /\a -> e
- f = /\ a -> let t = inline_me (t' a) in (t, w)
-The inline_me is to stop the simplifier inlining t' right back
-into t's RHS. In the next phase we'll substitute for t (since
-its rhs is trivial) and *then* we could get rid of the inline_me.
-But it hardly seems worth it, so I don't bother.
-
-\begin{code}
-mkInlineMe :: CoreExpr -> CoreExpr
-mkInlineMe (Var v) = Var v
-mkInlineMe e = Note InlineMe e
-\end{code}
-
-
-
\begin{code}
+-- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
mkCoerceI IdCo e = e
mkCoerceI (ACo co) e = mkCoerce co e
+-- | Wrap the given expression in the coercion safely, coalescing nested coercions
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2)
= ASSERT(let { (from_ty, _to_ty) = coercionKind co;
\end{code}
\begin{code}
+-- | Wraps the given expression in the cost centre unless
+-- in a way that maximises their utility to the user
mkSCC :: CostCentre -> Expr b -> Expr b
-- Note: Nested SCC's *are* preserved for the benefit of
-- cost centre stack profiling
\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- (bindNonRec x r b) produces either
--- let x = r in b
--- or
--- case r of x { _DEFAULT_ -> b }
+-- ^ @bindNonRec x r b@ produces either:
--
--- depending on whether x is unlifted or not
+-- > let x = r in b
+--
+-- or:
+--
+-- > case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether we have to use a @case@ or @let@
+-- binding for the expression (see 'needsCaseBinding').
-- 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.
-
+-- that give Core Lint a heart attack, although actually
+-- the simplifier deals with them perfectly well. See
+-- also 'MkCore.mkCoreLet'
bindNonRec bndr rhs body
- | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
+ | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
| otherwise = Let (NonRec bndr rhs) body
+-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
+-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
\end{code}
\begin{code}
-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 :: AltCon -- ^ Case alternative constructor
+ -> [CoreBndr] -- ^ Things bound by the pattern match
+ -> [Type] -- ^ The type arguments to the case alternative
+ -> CoreExpr
+-- ^ This guy constructs the value that the scrutinee must have
+-- given that you are in one particular branch of a case
mkAltExpr (DataAlt con) args inst_tys
= mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
mkAltExpr (LitAlt lit) [] []
= Lit lit
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
-
-mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
-mkIfThenElse guard then_expr else_expr
--- Not going to be refining, so okay to take the type of the "then" clause
- = Case guard (mkWildId boolTy) (exprType then_expr)
- [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
- (DataAlt trueDataCon, [], then_expr) ]
\end{code}
This makes it easy to find, though it makes matching marginally harder.
\begin{code}
+-- | Extract the default case alternative
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
+-- | Find the case alternative corresponding to a particular
+-- constructor: panics if no such constructor exists
findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
= case alts of
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
--- Merge preserving order; alternatives in the first arg
--- shadow ones in the second
+-- ^ Merge alternatives preserving order; alternatives in
+-- the first argument shadow ones in the second
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
--- Given case (C a b x y) of
--- C b x y -> ...
--- we want to drop the leading type argument of the scrutinee
+-- ^ Given:
+--
+-- > case (C a b x y) of
+-- > C b x y -> ...
+--
+-- We want to drop the leading type argument of the scrutinee
-- leaving the arguments to match agains the pattern
trimConArgs DEFAULT args = ASSERT( null args ) []
applications. Note that primop Ids aren't considered
trivial unless
-@exprIsBottom@ is true of expressions that are guaranteed to diverge
-
-
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
-The idea here is that a constructor worker, like $wJust, is
-really short for (\x -> $wJust x), becuase $wJust has no binding.
+The idea here is that a constructor worker, like \$wJust, is
+really short for (\x -> \$wJust x), becuase \$wJust has no binding.
So it should be treated like a lambda. Ditto unsaturated primops.
But now constructor workers are not "have-no-binding" Ids. And
completely un-applied primops and foreign-call Ids are sufficiently
\begin{code}
exprIsDupable :: CoreExpr -> Bool
-exprIsDupable (Type _) = True
-exprIsDupable (Var _) = True
-exprIsDupable (Lit lit) = litIsDupable lit
-exprIsDupable (Note InlineMe _) = True
-exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable (Cast e _) = exprIsDupable e
+exprIsDupable (Type _) = True
+exprIsDupable (Var _) = True
+exprIsDupable (Lit lit) = litIsDupable lit
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable (Cast e _) = exprIsDupable e
exprIsDupable expr
= go expr 0
where
exprIsCheap (Lit _) = True
exprIsCheap (Type _) = True
exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe _) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Cast e _) = exprIsCheap e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
\end{code}
-exprOkForSpeculation returns True of an expression that it is
-
- * 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
-
-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)
-
-NB: if exprIsHNF e, then exprOkForSpecuation e
-
-E.G.
- let x = case y# +# 1# of { r# -> I# r# }
- in E
-==>
- case y# +# 1# of { r# ->
- let x = I# r#
- in E
- }
-
-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}
+-- | 'exprOkForSpeculation' returns True of an expression that is:
+--
+-- * 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
+--
+-- Precisely, 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)
+--
+-- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
+-- As an example of the considerations in this test, consider:
+--
+-- > let x = case y# +# 1# of { r# -> I# r# }
+-- > in E
+--
+-- being translated to:
+--
+-- > case y# +# 1# of { r# ->
+-- > let x = I# r#
+-- > in E
+-- > }
+--
+-- 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.
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
spec_ok _ _ = False
+-- | True of dyadic operators that can fail only if the second arg is zero!
isDivOp :: PrimOp -> Bool
--- True of dyadic operators that can fail
--- only if the second arg is zero
-- This function probably belongs in PrimOp, or even in
-- an automagically generated file.. but it's such a
-- special case I thought I'd leave it here for now.
isDivOp _ = False
\end{code}
-
\begin{code}
+{- Never used -- omitting
+-- | True of expressions that are guaranteed to diverge upon execution
exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
exprIsBottom e = go 0 e
where
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
+-}
\end{code}
-@exprIsHNF@ returns true for expressions that are certainly *already*
-evaluated to *head* normal form. This is used to decide whether it's ok
-to change
-
- case x of _ -> e ===> e
-
-and to decide whether it's safe to discard a `seq`
-
-So, it does *not* treat variables as evaluated, unless they say they are.
-
-But it *does* treat partial applications and constructor applications
-as values, even if their arguments are non-trivial, provided the argument
-type is lifted;
- e.g. (:) (f x) (map f xs) is a value
- map (...redex...) is a value
-Because `seq` on such things completes immediately
-
-For unlifted argument types, we have to be careful:
- C (f x :: Int#)
-Suppose (f x) diverges; then C (f x) is not a value. However this can't
-happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed
-type must be ok-for-speculation (or trivial).
-
\begin{code}
+
+-- | This returns true for expressions that are certainly /already/
+-- evaluated to /head/ normal form. This is used to decide whether it's ok
+-- to change:
+--
+-- > case x of _ -> e
+--
+-- into:
+--
+-- > e
+--
+-- and to decide whether it's safe to discard a 'seq'.
+-- So, it does /not/ treat variables as evaluated, unless they say they are.
+-- However, it /does/ treat partial applications and constructor applications
+-- as values, even if their arguments are non-trivial, provided the argument
+-- type is lifted. For example, both of these are values:
+--
+-- > (:) (f x) (map f xs)
+-- > map (...redex...)
+--
+-- Because 'seq' on such things completes immediately.
+--
+-- For unlifted argument types, we have to be careful:
+--
+-- > C (f x :: Int#)
+--
+-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
+-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
+-- unboxed type must be ok-for-speculation (or trivial).
exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
exprIsHNF (Var v) -- NB: There are no value args at this point
= isDataConWorkId v -- Catches nullary constructors,
app_is_value _ _ = False
\end{code}
+These InstPat functions go here to avoid circularity between DataCon and Id
+
\begin{code}
dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
--- These InstPat functions go here to avoid circularity between DataCon and Id
-dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
+
+dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
dataConRepFSInstPat = dataConInstPat dataConRepArgTys
-dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv")))
+dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv")))
where
dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
-- Remember to include the existential dictionaries
-- ...
--
-- has representation type
--- forall a. forall a1. forall b. (a :=: (a1,b)) =>
+-- forall a. forall a1. forall b. (a ~ (a1,b)) =>
-- Int -> b -> T a
--
-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
+-- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
--
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+-- | Returns @Just (dc, [x1..xn])@ if the argument expression is
+-- a constructor application of the form @dc x1 .. xn@
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
--- Returns (Just (dc, [x1..xn])) if the argument expression is
--- a constructor application of the form (dc x1 .. xn)
exprIsConApp_maybe (Cast expr co)
= -- Here we do the KPush reduction rule as described in the FC paper
case exprIsConApp_maybe expr of {
-- The transformation applies iff we have
-- (C e1 ... en) `cast` co
- -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
+ -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
-- That is, with a T at the top of both sides
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
- -- We ignore InlineMe notes in case we have
- -- x = __inline_me__ (a,b)
- -- All part of making sure that INLINE pragmas never hurt
- -- Marcin tripped on this one when making dictionaries more inlinable
- --
- -- In fact, we ignore all notes. For example,
+ -- We ignore all notes. For example,
-- case _scc_ "foo" (C a b) of
-- C a b -> e
-- should be optimised away, but it will be only if we look
%************************************************************************
\begin{code}
+-- ^ The Arity returned is the number of value args the
+-- expression can be applied to without doing much work
exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
-{- The Arity returned is the number of value args the
- thing can be applied to without doing much work
+-- exprEtaExpandArity is used when eta expanding
+-- e ==> \xy -> e x y
+exprEtaExpandArity dflags e
+ = applyStateHack (exprType e) (arityDepth (arityType dicts_cheap e))
+ where
+ dicts_cheap = dopt Opt_DictsCheap dflags
-exprEtaExpandArity is used when eta expanding
- e ==> \xy -> e x y
+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
+-- A cheap and cheerful function that identifies bottoming functions
+-- and gives them a suitable strictness signatures. It's used during
+-- float-out
+exprBotStrictness_maybe e
+ = case arityType False e of
+ AT _ ATop -> Nothing
+ AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
+\end{code}
-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
-It's all a bit more subtle than it looks:
+Note [Definition of arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The "arity" of an expression 'e' is n if
+ applying 'e' to *fewer* than n *value* arguments
+ converges rapidly
-1. One-shot lambdas
+Or, to put it another way
-Consider one-shot lambdas
- let x = expensive in \y z -> E
-We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
-Hence the ArityType returned by arityType
+ there is no work lost in duplicating the partial
+ application (e x1 .. x(n-1))
-2. The state-transformer hack
+In the divegent case, no work is lost by duplicating because if the thing
+is evaluated once, that's the end of the program.
-The one-shot lambda special cause is particularly important/useful for
-IO state transformers, where we often get
- let x = E in \ s -> ...
+Or, to put it another way, in any context C
-and the \s is a real-world state token abstraction. Such abstractions
-are almost invariably 1-shot, so we want to pull the \s out, past the
-let x=E, even if E is expensive. So we treat state-token lambdas as
-one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
+ C[ (\x1 .. xn. e x1 .. xn) ]
+ is as efficient as
+ C[ e ]
-3. Dealing with bottom
-Consider also
- f = \x -> error "foo"
-Here, arity 1 is fine. But if it is
- f = \x -> case x of
- True -> error "foo"
- False -> \y -> x+y
-then we want to get arity 2. Tecnically, this isn't quite right, because
- (f True) `seq` 1
-should diverge, but it'll converge if we eta-expand f. Nevertheless, we
-do so; it improves some programs significantly, and increasing convergence
-isn't a bad thing. Hence the ABot/ATop in ArityType.
+It's all a bit more subtle than it looks:
+
+Note [Arity of case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat the arity of
+ case x of p -> \s -> ...
+as 1 (or more) 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.
-Actually, the situation is worse. Consider
+This isn't really right in the presence of seq. Consider
f = \x -> case x of
True -> \y -> x+y
False -> \y -> x-y
many programs.
-4. Newtypes
+1. Note [One-shot lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider one-shot lambdas
+ let x = expensive in \y z -> E
+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.
+3. Note [Dealing with bottom]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f = \x -> error "foo"
+Here, arity 1 is fine. But if it is
+ f = \x -> case x of
+ True -> error "foo"
+ False -> \y -> x+y
+then we want to get arity 2. Technically, this isn't quite right, because
+ (f True) `seq` 1
+should diverge, but it'll converge if we eta-expand f. Nevertheless, we
+do so; it improves some programs significantly, and increasing convergence
+isn't a bad thing. Hence the ABot/ATop in ArityType.
+
+
+4. Note [Newtype arity]
+~~~~~~~~~~~~~~~~~~~~~~~~
Non-recursive newtypes are transparent, and should not get in the way.
We do (currently) eta-expand recursive newtypes too. So if we have, say
coerce Int negate
And since negate has arity 2, you might try to eta expand. But you can't
decopose Int to a function type. Hence the final case in eta_expand.
--}
-
-
-exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
--- A limited sort of function type
-data ArityType = AFun Bool ArityType -- True <=> one-shot
- | ATop -- Know nothing
- | ABot -- Diverges
-arityDepth :: ArityType -> Arity
-arityDepth (AFun _ ty) = 1 + arityDepth ty
-arityDepth _ = 0
+Note [The state-transformer hack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ f = e
+where e has arity n. Then, if we know from the context that f has
+a usage type like
+ t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
+then we can expand the arity to m. This usage type says that
+any application (x e1 .. en) will be applied to uniquely to (m-n) more args
+Consider f = \x. let y = <expensive>
+ in case x of
+ True -> foo
+ False -> \(s:RealWorld) -> e
+where foo has arity 1. Then we want the state hack to
+apply to foo too, so we can eta expand the case.
+
+Then we expect that if f is applied to one arg, it'll be applied to two
+(that's the hack -- we don't really know, and sometimes it's false)
+See also Id.isOneShotBndr.
-andArityType :: ArityType -> ArityType -> ArityType
-andArityType ABot at2 = at2
-andArityType ATop _ = ATop
-andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
-andArityType at1 at2 = andArityType at2 at1
+\begin{code}
+applyStateHack :: Type -> Arity -> Arity
+applyStateHack ty arity -- Note [The state-transformer hack]
+ | opt_NoStateHack = arity
+ | otherwise = go ty arity
+ where
+ go :: Type -> Arity -> Arity
+ go ty arity -- This case analysis should match that in eta_expand
+ | Just (_, ty') <- splitForAllTy_maybe ty = go ty' arity
+
+ | Just (tc,tys) <- splitTyConApp_maybe ty
+ , Just (ty', _) <- instNewTyCon_maybe tc tys
+ , not (isRecursiveTyCon tc) = go ty' arity
+ -- Important to look through non-recursive newtypes, so that, eg
+ -- (f x) where f has arity 2, f :: Int -> IO ()
+ -- Here we want to get arity 1 for the result!
+
+ | Just (arg,res) <- splitFunTy_maybe ty
+ , arity > 0 || isStateHackType arg = 1 + go res (arity-1)
+
+ | otherwise = WARN( arity > 0, ppr arity ) 0
+\end{code}
-arityType :: DynFlags -> CoreExpr -> ArityType
- -- (go1 e) = [b1,..,bn]
- -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
- -- where bi is True <=> the lambda is one-shot
-arityType dflags (Note _ e) = arityType dflags e
--- Not needed any more: etaExpand is cleverer
--- | ok_note n = arityType dflags e
--- | otherwise = ATop
+-------------------- Main arity code ----------------------------
+\begin{code}
+-- If e has ArityType (AT as r), then the term 'e'
+-- * Must be applied to at least (length as) *value* args
+-- before doing any significant work
+-- * It will not diverge before being applied to (length as)
+-- value arguments
+-- * If 'r' is ABot, then it guarantees to eventually diverge if
+-- applied to enough arguments (perhaps more than (length as)
+
+data ArityType = AT Arity ArityRes
+data ArityRes = ATop -- Know nothing
+ | ABot -- Diverges
-arityType dflags (Cast e _) = arityType dflags e
+vanillaArityType :: ArityType
+vanillaArityType = AT 0 ATop -- Totally uninformative
+arityDepth :: ArityType -> Arity
+arityDepth (AT a _) = a
+
+incArity :: ArityType -> ArityType
+incArity (AT a r) = AT (a+1) r
+
+decArity :: ArityType -> ArityType
+decArity (AT 0 r) = AT 0 r
+decArity (AT a r) = AT (a-1) r
+
+andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
+andArityType (AT a1 ATop) (AT a2 ATop) = AT (a1 `min` a2) ATop
+andArityType (AT _ ABot) (AT a2 ATop) = AT a2 ATop
+andArityType (AT a1 ATop) (AT _ ABot) = AT a1 ATop
+andArityType (AT a1 ABot) (AT a2 ABot) = AT (a1 `max` a2) ABot
+
+trimArity :: Bool -> ArityType -> ArityType
+-- We have something like (let x = E in b), where b has the given
+-- arity type. Then
+-- * If E is cheap we can push it inside as far as we like
+-- * If b eventually diverges, we allow ourselves to push inside
+-- arbitrarily, even though that is not quite right
+trimArity _cheap (AT a ABot) = AT a ABot
+trimArity True (AT a ATop) = AT a ATop
+trimArity False (AT _ ATop) = AT 0 ATop -- Bale out
+
+---------------------------
+arityType :: Bool -> CoreExpr -> ArityType
arityType _ (Var v)
- = mk (idArity v) (arg_tys (idType v))
- where
- mk :: Arity -> [Type] -> ArityType
- -- The argument types are only to steer the "state hack"
- -- Consider case x of
- -- True -> foo
- -- False -> \(s:RealWorld) -> e
- -- where foo has arity 1. Then we want the state hack to
- -- apply to foo too, so we can eta expand the case.
- mk 0 tys | isBottomingId v = ABot
- | (ty:_) <- tys, isStateHackType ty = AFun True ATop
- | otherwise = ATop
- mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
- mk n [] = AFun False (mk (n-1) [])
-
- arg_tys :: Type -> [Type] -- Ignore for-alls
- arg_tys ty
- | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
- | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
- | otherwise = []
+ | Just strict_sig <- idNewStrictness_maybe v
+ , (ds, res) <- splitStrictSig strict_sig
+ , isBotRes res
+ = AT (length ds) ABot -- Function diverges
+ | otherwise
+ = AT (idArity v) ATop
-- Lambdas; increase arity
-arityType dflags (Lam x e)
- | isId x = AFun (isOneShotBndr x) (arityType dflags e)
- | otherwise = arityType dflags e
+arityType dicts_cheap (Lam x e)
+ | isId x = incArity (arityType dicts_cheap e)
+ | otherwise = arityType dicts_cheap e
-- Applications; decrease arity
-arityType dflags (App f (Type _)) = arityType dflags f
-arityType dflags (App f a)
- = case arityType dflags f of
- ABot -> ABot -- If function diverges, ignore argument
- ATop -> ATop -- No no info about function
- AFun _ xs
- | exprIsCheap a -> xs
- | otherwise -> ATop
-
+arityType dicts_cheap (App fun (Type _))
+ = arityType dicts_cheap fun
+arityType dicts_cheap (App fun arg )
+ = trimArity (exprIsCheap arg) (decArity (arityType dicts_cheap fun))
+
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
-- The former is not really right for Haskell
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
-arityType dflags (Case scrut _ _ alts)
- = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
- xs | exprIsCheap scrut -> xs
- AFun one_shot _ | one_shot -> AFun True ATop
- _ -> ATop
-
-arityType dflags (Let b e)
- = case arityType dflags e of
- xs | cheap_bind b -> xs
- AFun one_shot _ | one_shot -> AFun True ATop
- _ -> ATop
+arityType dicts_cheap (Case scrut _ _ alts)
+ = trimArity (exprIsCheap scrut)
+ (foldr1 andArityType [arityType dicts_cheap rhs | (_,_,rhs) <- alts])
+
+arityType dicts_cheap (Let b e)
+ = trimArity (cheap_bind b) (arityType dicts_cheap e)
where
cheap_bind (NonRec b e) = is_cheap (b,e)
cheap_bind (Rec prs) = all is_cheap prs
- is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
- || exprIsCheap e
+ is_cheap (b,e) = (dicts_cheap && isDictId b) || exprIsCheap e
-- If the experimental -fdicts-cheap flag is on, we eta-expand through
-- dictionary bindings. This improves arities. Thereby, it also
-- means that full laziness is less prone to floating out the
-- One could go further and make exprIsCheap reply True to any
-- dictionary-typed expression, but that's more work.
-arityType _ _ = ATop
-
-{- NOT NEEDED ANY MORE: etaExpand is cleverer
-ok_note InlineMe = False
-ok_note other = True
- -- Notice that we do not look through __inline_me__
- -- This may seem 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
--}
+arityType dicts_cheap (Note _ e) = arityType dicts_cheap e
+arityType dicts_cheap (Cast e _) = arityType dicts_cheap e
+arityType _ _ = vanillaArityType
\end{code}
\begin{code}
-etaExpand :: Arity -- Result should have this number of value args
- -> [Unique]
- -> CoreExpr -> Type -- Expression and its type
- -> CoreExpr
--- (etaExpand n us e ty) returns an expression with
--- the same meaning as 'e', but with arity 'n'.
+-- | @etaExpand n us e ty@ returns an expression with
+-- the same meaning as @e@, but with arity @n@.
+--
+-- Given:
+--
+-- > e' = etaExpand n us e ty
--
--- Given e' = etaExpand n us e ty
--- We should have
--- ty = exprType e = exprType e'
+-- We should have that:
--
+-- > ty = exprType e = exprType e'
+etaExpand :: Arity -- ^ Result should have this number of value args
+ -> [Unique] -- ^ Uniques to assign to the new binders
+ -> CoreExpr -- ^ Expression to expand
+ -> Type -- ^ Type of expression to expand
+ -> CoreExpr
-- Note that SCCs are not treated specially. If we have
-- etaExpand 2 (\x -> scc "foo" e)
-- = (\xy -> (scc "foo" e) y)
etaExpand n us expr ty
| manifestArity expr >= n = expr -- The no-op case
- | otherwise
- = eta_expand n us expr ty
- where
+ | otherwise = eta_expand n us expr ty
-- manifestArity sees how many leading value lambdas there are
manifestArity :: CoreExpr -> Arity
-- so perhaps the extra code isn't worth it
eta_expand :: Int -> [Unique] -> CoreExpr -> Type -> CoreExpr
-eta_expand n _ expr ty
- | n == 0 &&
- -- The ILX code generator requires eta expansion for type arguments
- -- too, but alas the 'n' doesn't tell us how many of them there
- -- may be. So we eagerly eta expand any big lambdas, and just
- -- cross our fingers about possible loss of sharing in the ILX case.
- -- The Right Thing is probably to make 'arity' include
- -- type variables throughout the compiler. (ToDo.)
- not (isForAllTy ty)
- -- Saturated, so nothing to do
+eta_expand n _ expr _
+ | n == 0 -- Saturated, so nothing to do
= expr
-- Short cut for the case where there already
Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
where
- lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
+ lam_tv = setVarName tv (mkSysTvName uniq (fsLit "etaT"))
-- Using tv as a base retains its tyvar/covar-ness
(uniq:us2) = us
; Nothing ->
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
- arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
+ arg1 = mkSysLocal (fsLit "eta") uniq arg_ty
(uniq:us2) = us
; Nothing ->
\begin{code}
+-- | An approximate, fast, version of 'exprEtaExpandArity'
exprArity :: CoreExpr -> Arity
exprArity e = go e
where
%* *
%************************************************************************
-@cheapEqExpr@ is a cheap equality test which bales out fast!
- True => definitely equal
- False => may or may not be equal
-
\begin{code}
+-- | A cheap equality test which bales out fast!
+-- If it returns @True@ the arguments are definitely equal,
+-- otherwise, they may or may not be equal.
+--
+-- See also 'exprIsBig'
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr _ _ = False
exprIsBig :: Expr b -> Bool
--- Returns True of expressions that are too big to be compared by cheapEqExpr
+-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
exprIsBig (Lit _) = False
exprIsBig (Var _) = False
exprIsBig (Type _) = False
+exprIsBig (Lam _ e) = exprIsBig e
exprIsBig (App f a) = exprIsBig f || exprIsBig a
exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
exprIsBig _ = True
\begin{code}
tcEqExpr :: CoreExpr -> CoreExpr -> Bool
--- Used in rule matching, so does *not* look through
--- newtypes, predicate types; hence tcEqExpr
+-- ^ A kind of shallow equality used in rule matching, so does
+-- /not/ look through newtypes or predicate types
tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
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
+-- ^ A measure of the size of the expressions, strictly greater than 0
+-- It also forces the expression pretty drastically as a side effect
exprSize (Var v) = v `seq` 1
exprSize (Lit lit) = lit `seq` 1
exprSize (App f a) = exprSize f + exprSize a
noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
-noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
\begin{code}
hashExpr :: CoreExpr -> Int
--- Two expressions that hash to the same Int may be equal (but may not be)
--- Two expressions that hash to the different Ints are definitely unequal
---
--- But "unequal" here means "not identical"; two alpha-equivalent
--- expressions may hash to the different Ints
+-- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
+-- Two expressions that hash to the different Ints are definitely unequal.
--
--- The emphasis is on a crude, fast hash, rather than on high precision
+-- The emphasis is on a crude, fast hash, rather than on high precision.
+--
+-- But unequal here means \"not identical\"; two alpha-equivalent
+-- expressions may hash to the different Ints.
--
--- We must be careful that \x.x and \y.y map to the same hash code,
--- (at least if we want the above invariant to be true)
+-- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
+-- (at least if we want the above invariant to be true).
hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
-- UniqFM doesn't like negative Ints
-type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
+type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
hash_expr :: HashEnv -> CoreExpr -> Word32
-- Word32, because we're expecting overflows here, and overflowing
labels in other DLLs).
If this happens we simply make the RHS into an updatable thunk,
-and 'exectute' it rather than allocating it statically.
+and 'execute' it rather than allocating it statically.
\begin{code}
+-- | This function is called only on *top-level* right-hand sides.
+-- Returns @True@ if the RHS can be allocated statically in the output,
+-- with no thunks involved at all.
rhsIsStatic :: PackageId -> CoreExpr -> Bool
--- This function is called only on *top-level* right-hand sides
--- Returns True if the RHS can be allocated statically, with
--- no thunks involved at all.
---
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
-- This is a bit like CoreUtils.exprIsHNF, with the following differences:
-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
--
--- b) (C x xs), where C is a contructors is updatable if the application is
+-- b) (C x xs), where C is a contructor is updatable if the application is
-- dynamic
--
-- c) don't look through unfolding of f in (f x).
projects / ghc-hetmet.git / blobdiff