-- The continuation type
SimplCont(..), DupFlag(..), ArgInfo(..),
+ isSimplified,
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
- pushArgs, countValArgs, countArgs, addArgTo,
+ pushSimplifiedArgs, countValArgs, countArgs, addArgTo,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext,
#include "HsVersions.h"
import SimplEnv
+import CoreMonad ( SimplifierMode(..), Tick(..) )
import DynFlags
import StaticFlags
import CoreSyn
import PprCore
import CoreFVs
import CoreUtils
-import CoreArity ( etaExpand, exprEtaExpandArity )
+import CoreArity
import CoreUnfold
import Name
import Id
-import Var ( isCoVar )
+import Var ( Var, isCoVar )
import Demand
import SimplMonad
import Type hiding( substTy )
SimplCont
| ApplyTo -- C arg
- DupFlag
- InExpr StaticEnv -- The argument and its static env
+ DupFlag -- See Note [DupFlag invariants]
+ InExpr StaticEnv -- The argument and its static env
SimplCont
| Select -- case C of alts
- DupFlag
+ DupFlag -- See Note [DupFlag invariants]
InId [InAlt] StaticEnv -- The case binder, alts, and subst-env
SimplCont
{- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
- ppr (Select dup bndr alts _ cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts)) $$ ppr cont
+ ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
+ (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
-data DupFlag = OkToDup | NoDup
+data DupFlag = NoDup -- Unsimplified, might be big
+ | Simplified -- Simplified
+ | OkToDup -- Simplified and small
+
+isSimplified :: DupFlag -> Bool
+isSimplified NoDup = False
+isSimplified _ = True -- Invariant: the subst-env is empty
instance Outputable DupFlag where
- ppr OkToDup = ptext (sLit "ok")
- ppr NoDup = ptext (sLit "nodup")
+ ppr OkToDup = ptext (sLit "ok")
+ ppr NoDup = ptext (sLit "nodup")
+ ppr Simplified = ptext (sLit "simpl")
+\end{code}
+Note [DupFlag invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In both (ApplyTo dup _ env k)
+ and (Select dup _ _ env k)
+the following invariants hold
+ (a) if dup = OkToDup, then continuation k is also ok-to-dup
+ (b) if dup = OkToDup or Simplified, the subst-env is empty
+ (and and hence no need to re-simplify)
+\begin{code}
-------------------
mkBoringStop :: SimplCont
mkBoringStop = Stop BoringCtxt
-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = True
-contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants]
+contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto...
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable _ = False
countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
countArgs _ = 0
-contArgs :: SimplCont -> ([OutExpr], SimplCont)
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Uses substitution to turn each arg into an OutExpr
-contArgs cont = go [] cont
+contArgs cont@(ApplyTo {})
+ = case go [] cont of { (args, cont') -> (False, args, cont') }
where
- go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
- go args cont = (reverse args, cont)
+ go args (ApplyTo _ arg se cont)
+ | isTypeArg arg = go args cont
+ | otherwise = go (is_interesting arg se : args) cont
+ go args cont = (reverse args, cont)
-pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
-pushArgs _env [] cont = cont
-pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args cont)
+ is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
+ -- Do *not* use short-cutting substitution here
+ -- because we want to get as much IdInfo as possible
+
+contArgs cont = (True, [], cont)
+
+pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
+pushSimplifiedArgs _env [] cont = cont
+pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont)
+ -- The env has an empty SubstEnv
dropArgs :: Int -> SimplCont -> SimplCont
dropArgs 0 cont = cont
InlineRule, because then recursive knots in instance declarations
don't get unravelled.
-However, *sometimes* SimplGently must do no call-site inlining at all.
-Before full laziness we must be careful not to inline wrappers,
-because doing so inhibits floating
+However, *sometimes* SimplGently must do no call-site inlining at all
+(hence sm_inline = False). Before full laziness we must be careful
+not to inline wrappers, because doing so inhibits floating
e.g. ...(case f x of ...)...
==> ...(case (case x of I# x# -> fw x#) of ...)...
==> ...(case x of I# x# -> case fw x# of ...)...
to work in Template Haskell when simplifying
splices, so we get simpler code for literal strings
+But watch out: list fusion can prevent floating. So use phase control
+to switch off those rules until after floating.
+
Note [Simplifying inside InlineRules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside InlineRules (which come from
ActiveBefore {} -> mk_gentle current_mode
ActiveAfter n -> mk_phase n current_mode
where
- no_op = SimplGently { sm_rules = False, sm_inline = False }
+ no_op = SimplGently { sm_rules = False, sm_inline = False }
mk_gentle (SimplGently {}) = current_mode
- mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
+ mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
- mk_phase n (SimplPhase cp ss)
- | cp > n = no_op -- Current phase earlier than n
- | otherwise = SimplPhase n ss
- mk_phase _ (SimplGently {}) = no_op
+ mk_phase n (SimplPhase _ ss) = SimplPhase n ss
+ mk_phase n (SimplGently {}) = SimplPhase n ["gentle-rules"]
\end{code}
However, as usual for Gentle mode, do not inline things that are
inactive in the intial stages. See Note [Gentle mode].
+Note [InlineRule and preInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
+Example
+
+ {-# INLINE f #-}
+ f :: Eq a => a -> a
+ f x = ...
+
+ fInt :: Int -> Int
+ fInt = f Int dEqInt
+
+ ...fInt...fInt...fInt...
+
+Here f occurs just once, in the RHS of f1. But if we inline it there
+we'll lose the opportunity to inline at each of fInt's call sites.
+The INLINE pragma will only inline when the application is saturated
+for exactly this reason; and we don't want PreInlineUnconditionally
+to second-guess it. A live example is Trac #3736.
+ c.f. Note [InlineRule and postInlineUnconditionally]
+
Note [Top-level botomming Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Don't inline top-level Ids that are bottoming, even if they are used just
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally env top_lvl bndr rhs
| not active = False
+ | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally]
| isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
| opt_SimplNoPreInlining = False
| otherwise = case idOccInfo bndr of
and now postInlineUnconditionally, losing the InlineRule on f. Now f'
won't inline because 'e' is too big.
+ c.f. Note [InlineRule and preInlineUnconditionally]
+
%************************************************************************
%* *
mkLam _b [] body
= return body
-mkLam env bndrs body
+mkLam _env bndrs body
= do { dflags <- getDOptsSmpl
; mkLam' dflags bndrs body }
where
co_vars = tyVarsOfType co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
+ mkLam' dflags bndrs body@(Lam {})
+ = mkLam' dflags (bndrs ++ bndrs1) body1
+ where
+ (bndrs1, body1) = collectBinders body
+
mkLam' dflags bndrs body
- | dopt Opt_DoEtaReduction dflags,
- Just etad_lam <- tryEtaReduce bndrs body
+ | dopt Opt_DoEtaReduction dflags
+ , Just etad_lam <- tryEtaReduce bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | dopt Opt_DoLambdaEtaExpansion dflags,
- not (inGentleMode env), -- In gentle mode don't eta-expansion
- any isRuntimeVar bndrs -- because it can clutter up the code
- -- with casts etc that may not be removed
- = do { let body' = tryEtaExpansion dflags body
+ | dopt Opt_DoLambdaEtaExpansion dflags
+ , any ok_to_expand bndrs
+ = do { let body' = etaExpand fun_arity body
+ fun_arity = exprEtaExpandArity dflags body
; return (mkLams bndrs body') }
| otherwise
= return (mkLams bndrs body)
+
+ ok_to_expand :: Var -> Bool -- Note [When to eta expand]
+ ok_to_expand bndr = isId bndr && not (isDictId bndr)
\end{code}
+Note [When to eta expand]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We only eta expand if there is at least one non-tyvar, non-dict
+binder. The proximate cause for not eta-expanding dictionary lambdas
+was this example:
+ genMap :: C a => ...
+ {-# INLINE genMap #-}
+ genMap f xs = ...
+
+ myMap :: D a => ...
+ {-# INLINE myMap #-}
+ myMap = genMap
+
+Notice that 'genMap' should only inline if applied to two arguments.
+In the InlineRule for myMap we'll have the unfolding
+ (\d -> genMap Int (..d..))
+We do not want to eta-expand to
+ (\d f xs -> genMap Int (..d..) f xs)
+because then 'genMap' will inline, and it really shouldn't: at least
+as far as the programmer is concerned, it's not applied to two
+arguments!
+
Note [Casts and lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
{- Sept 01: I'm experimenting with getting the
full laziness pass to float out past big lambdsa
- | all isTyVar bndrs, -- Only for big lambdas
+ | all isTyCoVar bndrs, -- Only for big lambdas
contIsRhs cont -- Only try the rhs type-lambda floating
-- if this is indeed a right-hand side; otherwise
-- we end up floating the thing out, only for float-in
return (floats, mkLams bndrs body')
-}
-
-%************************************************************************
-%* *
- Eta reduction
-%* *
-%************************************************************************
-
-Note [Eta reduction conditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We try for eta reduction here, but *only* if we get all the way to an
-trivial expression. We don't want to remove extra lambdas unless we
-are going to avoid allocating this thing altogether.
-
-There are some particularly delicate points here:
-
-* Eta reduction is not valid in general:
- \x. bot /= bot
- This matters, partly for old-fashioned correctness reasons but,
- worse, getting it wrong can yield a seg fault. Consider
- f = \x.f x
- h y = case (case y of { True -> f `seq` True; False -> False }) of
- True -> ...; False -> ...
-
- If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
- says f=bottom, and replaces the (f `seq` True) with just
- (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it
- *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands
- the definition again, so that it does not termninate after all.
- Result: seg-fault because the boolean case actually gets a function value.
- See Trac #1947.
-
- So it's important to to the right thing.
-
-* Note [Arity care]: we need to be careful if we just look at f's
- arity. Currently (Dec07), f's arity is visible in its own RHS (see
- Note [Arity robustness] in SimplEnv) so we must *not* trust the
- arity when checking that 'f' is a value. Otherwise we will
- eta-reduce
- f = \x. f x
- to
- f = f
- Which might change a terminiating program (think (f `seq` e)) to a
- non-terminating one. So we check for being a loop breaker first.
-
- However for GlobalIds we can look at the arity; and for primops we
- must, since they have no unfolding.
-
-* Regardless of whether 'f' is a value, we always want to
- reduce (/\a -> f a) to f
- This came up in a RULE: foldr (build (/\a -> g a))
- did not match foldr (build (/\b -> ...something complex...))
- The type checker can insert these eta-expanded versions,
- with both type and dictionary lambdas; hence the slightly
- ad-hoc isDictId
-
-* Never *reduce* arity. For example
- f = \xy. g x y
- Then if h has arity 1 we don't want to eta-reduce because then
- f's arity would decrease, and that is bad
-
-These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
-Alas.
-
-\begin{code}
-tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
-tryEtaReduce bndrs body
- = go (reverse bndrs) body
- where
- incoming_arity = count isId bndrs
-
- go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
- go [] fun | ok_fun fun = Just fun -- Success!
- go _ _ = Nothing -- Failure!
-
- -- Note [Eta reduction conditions]
- ok_fun (App fun (Type ty))
- | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
- = ok_fun fun
- ok_fun (Var fun_id)
- = not (fun_id `elem` bndrs)
- && (ok_fun_id fun_id || all ok_lam bndrs)
- ok_fun _fun = False
-
- ok_fun_id fun = fun_arity fun >= incoming_arity
-
- fun_arity fun -- See Note [Arity care]
- | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
- | otherwise = idArity fun
-
- ok_lam v = isTyVar v || isDictId v
-
- ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
-\end{code}
-
-
-%************************************************************************
-%* *
- Eta expansion
-%* *
-%************************************************************************
-
-
-We go for:
- f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
- (n >= 0)
-
-where (in both cases)
-
- * The xi can include type variables
-
- * The yi are all value variables
-
- * N is a NORMAL FORM (i.e. no redexes anywhere)
- wanting a suitable number of extra args.
-
-The biggest reason for doing this is for cases like
-
- f = \x -> case x of
- True -> \y -> e1
- False -> \y -> e2
-
-Here we want to get the lambdas together. A good exmaple is the nofib
-program fibheaps, which gets 25% more allocation if you don't do this
-eta-expansion.
-
-We may have to sandwich some coerces between the lambdas
-to make the types work. exprEtaExpandArity looks through coerces
-when computing arity; and etaExpand adds the coerces as necessary when
-actually computing the expansion.
-
-\begin{code}
-tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr
--- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body
- = etaExpand fun_arity body
- where
- fun_arity = exprEtaExpandArity dflags body
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Floating lets out of big lambdas}
abstractFloats main_tvs body_env body
= ASSERT( notNull body_floats )
do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
- ; return (float_binds, CoreSubst.substExpr subst body) }
+ ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
where
main_tv_set = mkVarSet main_tvs
body_floats = getFloats body_env
subst' = CoreSubst.extendIdSubst subst id poly_app
; return (subst', (NonRec poly_id poly_rhs)) }
where
- rhs' = CoreSubst.substExpr subst rhs
+ rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
| otherwise
- = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+ = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
-- Abstract only over the type variables free in the rhs
-- wrt which the new binding is abstracted. But the naive
abstract subst (Rec prs)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
- poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
+ poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)
+ | rhs <- rhss]
; return (subst', Rec (poly_ids `zip` poly_rhss)) }
where
(ids,rhss) = unzip prs
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
, Just all_cons <- tyConDataCons_maybe tycon
- , not (null all_cons) -- This is a tricky corner case. If the data type has no constructors,
- -- which GHC allows, then the case expression will have at most a default
- -- alternative. We don't want to eliminate that alternative, because the
- -- invariant is that there's always one alternative. It's more convenient
- -- to leave
- -- case x of { DEFAULT -> e }
- -- as it is, rather than transform it to
- -- error "case cant match"
- -- which would be quite legitmate. But it's a really obscure corner, and
- -- not worth wasting code on.
+ , not (null all_cons)
+ -- This is a tricky corner case. If the data type has no constructors,
+ -- which GHC allows, then the case expression will have at most a default
+ -- alternative. We don't want to eliminate that alternative, because the
+ -- invariant is that there's always one alternative. It's more convenient
+ -- to leave
+ -- case x of { DEFAULT -> e }
+ -- as it is, rather than transform it to
+ -- error "case cant match"
+ -- which would be quite legitmate. But it's a really obscure corner, and
+ -- not worth wasting code on.
, let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type
impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
= case filterOut impossible all_cons of
_ -> return [(DEFAULT, [], deflt_rhs)]
- | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+ | debugIsOn, isAlgTyCon tycon
+ , null (tyConDataCons tycon)
+ , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
-- Check for no data constructors
- -- This can legitimately happen for type families, so don't report that
+ -- This can legitimately happen for abstract types and type families,
+ -- so don't report that
= pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
$ return [(DEFAULT, [], deflt_rhs)]
projects / ghc-hetmet.git / blobdiff