-- 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,
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 $ 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
contArgs cont = (True, [], cont)
-pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
-pushArgs _env [] cont = cont
-pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args 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
(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 (all isTyCoVar bndrs) -- Don't eta expand type abstractions
- = 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
return (floats, mkLams bndrs body')
-}
-
-%************************************************************************
-%* *
- 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}
projects / ghc-hetmet.git / blobdiff