%
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\begin{code}
-module Simplify ( simplTopBinds, simplExpr, simplBind ) where
+module Simplify ( simplTopBinds, simplExpr ) where
#include "HsVersions.h"
-import BinderInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
-import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
- exprIsTrivial, whnfOrBottom, inlineUnconditionally,
- FormSummary(..)
+import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
+ opt_SimplNoPreInlining,
+ dopt, DynFlag(Opt_D_dump_inlinings),
+ SimplifierSwitch(..)
+ )
+import SimplMonad
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplIds,
+ SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
+ contResultType, discardInline, countArgs, contIsDupable,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
+ )
+import Var ( mkSysTyVar, tyVarKind )
+import VarEnv
+import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
+ idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
+ idDemandInfo, setIdInfo,
+ idOccInfo, setIdOccInfo,
+ zapLamIdInfo, setOneShotLambda,
+ )
+import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
+ setArityInfo,
+ setUnfoldingInfo, atLeastArity,
+ occInfo
+ )
+import Demand ( isStrict )
+import DataCon ( dataConNumInstArgs, dataConRepStrictness,
+ dataConSig, dataConArgTys
)
-import CostCentre ( isSccCountCostCentre, cmpCostCentre, costsAreSubsumed, useCurrentCostCentre )
import CoreSyn
-import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
- unTagBinders, squashableDictishCcExpr
+import PprCore ( pprParendExpr, pprCoreExpr )
+import CoreFVs ( mustHaveLocalBinding )
+import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
+ callSiteInline
)
-import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
- addIdArity, getIdArity,
- getIdDemandInfo, addIdDemandInfo,
- GenId{-instance NamedThing-}
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+ exprType, coreAltsType, exprIsValue,
+ exprOkForSpeculation, exprArity, exprIsCheap,
+ mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
-import Name ( isExported )
-import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
- atLeastArity, unknownArity )
-import Literal ( isNoRepLit )
-import Maybes ( maybeToBool )
-import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
-import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
-import SimplCase ( simplCase, bindLargeRhs )
-import SimplEnv
-import SimplMonad
-import SimplVar ( completeVar )
-import Unique ( Unique )
-import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, splitAlgTyConApp_maybe,
- splitFunTys, splitFunTy_maybe, isUnpointedType
+import Rules ( lookupRule )
+import CostCentre ( currentCCS )
+import Type ( mkTyVarTys, isUnLiftedType, seqType,
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
+ funResultTy
)
-import TysPrim ( realWorldStatePrimTy )
-import Util ( Eager, appEager, returnEager, runEager, mapEager,
- isSingleton, zipEqual, zipWithEqual, mapAndUnzip
+import Subst ( mkSubst, substTy,
+ isInScope, lookupIdSubst, substIdInfo
)
-import Outputable
+import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
+import TysPrim ( realWorldStatePrimTy )
+import PrelInfo ( realWorldPrimId )
+import OrdList
+import Maybes ( maybeToBool )
+import Util ( zipWithEqual )
+import Outputable
\end{code}
-The controlling flags, and what they do
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-passes:
-------
--fsimplify = run the simplifier
--ffloat-inwards = runs the float lets inwards pass
--ffloat = runs the full laziness pass
- (ToDo: rename to -ffull-laziness)
--fupdate-analysis = runs update analyser
--fstrictness = runs strictness analyser
--fsaturate-apps = saturates applications (eta expansion)
-
-options:
--------
--ffloat-past-lambda = OK to do full laziness.
- (ToDo: remove, as the full laziness pass is
- useless without this flag, therefore
- it is unnecessary. Just -ffull-laziness
- should be kept.)
-
--ffloat-lets-ok = OK to float lets out of lets if the enclosing
- let is strict or if the floating will expose
- a WHNF [simplifier].
-
--ffloat-primops-ok = OK to float out of lets cases whose scrutinee
- is a primop that cannot fail [simplifier].
-
--fcode-duplication-ok = allows the previous option to work on cases with
- multiple branches [simplifier].
-
--flet-to-case = does let-to-case transformation [simplifier].
-
--fcase-of-case = does case of case transformation [simplifier].
-
--fpedantic-bottoms = does not allow:
- case x of y -> e ===> e[x/y]
- (which may turn bottom into non-bottom)
-
-
- NOTES ON INLINING
- ~~~~~~~~~~~~~~~~~
-
-Inlining is one of the delicate aspects of the simplifier. By
-``inlining'' we mean replacing an occurrence of a variable ``x'' by
-the RHS of x's definition. Thus
-
- let x = e in ...x... ===> let x = e in ...e...
-
-We have two mechanisms for inlining:
-
-1. Unconditional. The occurrence analyser has pinned an (OneOcc
-FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's
-certainly safe to inline this variable, and to drop its binding''.
-(...Umm... if n <= 1; if n > 1, it is still safe, provided you are
-happy to be duplicating code...) When it encounters such a beast, the
-simplifer binds the variable to its RHS (in the id_env) and continues.
-It doesn't even look at the RHS at that stage. It also drops the
-binding altogether.
-
-2. Conditional. In all other situations, the simplifer simplifies
-the RHS anyway, and keeps the new binding. It also binds the new
-(cloned) variable to a ``suitable'' Unfolding in the UnfoldEnv.
-
-Here, ``suitable'' might mean NoUnfolding (if the occurrence
-info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if
-the variable has an INLINE pragma on it). The idea is that anything
-in the UnfoldEnv is safe to use, but also has an enclosing binding if
-you decide not to use it.
-
-Head normal forms
-~~~~~~~~~~~~~~~~~
-We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.
-
-At one time I thought it would be OK to put non-HNF unfoldings in for
-variables which occur only once [if they got inlined at that
-occurrence the RHS of the binding would become dead, so no duplication
-would occur]. But consider:
-@
- let x = <expensive>
- f = \y -> ...y...y...y...
- in f x
-@
-Now, it seems that @x@ appears only once, but even so it is NOT safe
-to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
-duplicate the references to @x@.
-
-Because of this, the "unconditional-inline" mechanism above is the
-only way in which non-HNFs can get inlined.
-
-INLINE pragmas
-~~~~~~~~~~~~~~
-
-When a variable has an INLINE pragma on it --- which includes wrappers
-produced by the strictness analyser --- we treat it rather carefully.
-
-For a start, we are careful not to substitute into its RHS, because
-that might make it BIG, and the user said "inline exactly this", not
-"inline whatever you get after inlining other stuff inside me". For
-example
-
- let f = BIG
- in {-# INLINE y #-} y = f 3
- in ...y...y...
-
-Here we don't want to substitute BIG for the (single) occurrence of f,
-because then we'd duplicate BIG when we inline'd y. (Exception:
-things in the UnfoldEnv with UnfoldAlways flags, which originated in
-other INLINE pragmas.)
-So, we clean out the UnfoldEnv of all SimpleUnfolding inlinings before
-going into such an RHS.
+The guts of the simplifier is in this module, but the driver
+loop for the simplifier is in SimplCore.lhs.
+
+
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more. (Actually, it never did!) The reason is
+documented with simplifyArgs.
-What about imports? They don't really matter much because we only
-inline relatively small things via imports.
-We augment the the UnfoldEnv with UnfoldAlways guidance if there's an
-INLINE pragma. We also do this for the RHSs of recursive decls,
-before looking at the recursive decls. That way we achieve the effect
-of inlining a wrapper in the body of its worker, in the case of a
-mutually-recursive worker/wrapper split.
%************************************************************************
%* *
-\subsection[Simplify-simplExpr]{The main function: simplExpr}
+\subsection{Bindings}
%* *
%************************************************************************
-At the top level things are a little different.
-
- * No cloning (not allowed for exported Ids, unnecessary for the others)
- * Floating is done a bit differently (no case floating; check for leaks; handle letrec)
-
\begin{code}
-simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding]
-
--- Dead code is now discarded by the occurrence analyser,
+simplTopBinds :: [InBind] -> SimplM [OutBind]
+
+simplTopBinds binds
+ = -- Put all the top-level binders into scope at the start
+ -- so that if a transformation rule has unexpectedly brought
+ -- anything into scope, then we don't get a complaint about that.
+ -- It's rather as if the top-level binders were imported.
+ simplIds (bindersOfBinds binds) $ \ bndrs' ->
+ simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
+ freeTick SimplifierDone `thenSmpl_`
+ returnSmpl (fromOL binds')
+ where
-simplTopBinds env binds
- = mapSmpl (floatBind env True) binds `thenSmpl` \ binds_s ->
- simpl_top_binds env (concat binds_s)
+ -- We need to track the zapped top-level binders, because
+ -- they should have their fragile IdInfo zapped (notably occurrence info)
+ simpl_binds [] bs = ASSERT( null bs ) returnSmpl (nilOL, panic "simplTopBinds corner")
+ simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs)
+ simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs))
+ where
+ n = length pairs
+
+simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]
+ -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+simplRecBind top_lvl pairs bndrs' thing_inside
+ = go pairs bndrs' `thenSmpl` \ (binds', (_, (binds'', res))) ->
+ returnSmpl (unitOL (Rec (flattenBinds (fromOL binds'))) `appOL` binds'', res)
where
- simpl_top_binds env [] = returnSmpl []
-
- simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
- = --- No cloning necessary at top level
- simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
- simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
- returnSmpl (binds1' ++ binds2')
-
- simpl_top_binds env (Rec pairs : binds)
- = -- No cloning necessary at top level, but we nevertheless
- -- add the Ids to the environment. This makes sure that
- -- info carried on the Id (such as arity info) gets propagated
- -- to occurrences.
- --
- -- This may seem optional, but I found an occasion when it Really matters.
- -- Consider foo{n} = ...foo...
- -- baz* = foo
- --
- -- where baz* is exported and foo isn't. Then when we do "indirection-shorting"
- -- in tidyCore, we need the {no-inline} pragma from foo to attached to the final
- -- thing: baz*{n} = ...baz...
- --
- -- Sure we could have made the indirection-shorting a bit cleverer, but
- -- propagating pragma info is a Good Idea anyway.
- let
- env1 = extendIdEnvWithClones env binders ids
- in
- simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) ->
- simpl_top_binds new_env binds `thenSmpl` \ binds' ->
- returnSmpl (Rec bind' : binds')
- where
- binders = map fst pairs
- ids = map fst binders
+ go [] _ = thing_inside `thenSmpl` \ stuff ->
+ returnOutStuff stuff
+
+ go ((bndr, rhs) : pairs) (bndr' : bndrs')
+ = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
+ -- Don't float unboxed bindings out,
+ -- because we can't "rec" them
\end{code}
+
%************************************************************************
%* *
\subsection[Simplify-simplExpr]{The main function: simplExpr}
%* *
%************************************************************************
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before. If we do so naively we get quadratic
+behaviour as things float out.
-\begin{code}
-simplExpr :: SimplEnv
- -> InExpr -> [OutArg]
- -> OutType -- Type of (e args); i.e. type of overall result
- -> SmplM OutExpr
-\end{code}
+To see why it's important to do it after, consider this (real) example:
-The expression returned has the same meaning as the input expression
-applied to the specified arguments.
+ let t = f x
+ in fst t
+==>
+ let t = let a = e1
+ b = e2
+ in (a,b)
+ in fst t
+==>
+ let a = e1
+ b = e2
+ t = (a,b)
+ in
+ a -- Can't inline a this round, cos it appears twice
+==>
+ e1
+Each of the ==> steps is a round of simplification. We'd save a
+whole round if we float first. This can cascade. Consider
-Variables
-~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise do
-the more sophisticated stuff.
+ let f = g d
+ in \x -> ...f...
+==>
+ let f = let d1 = ..d.. in \y -> e
+ in \x -> ...f...
+==>
+ let d1 = ..d..
+ in \x -> ...(\y ->e)...
-\begin{code}
-simplExpr env (Var v) args result_ty
- = case (runEager $ lookupId env v) of
- LitArg lit -- A boring old literal
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- VarArg var -- More interesting! An id!
- -> completeVar env var args result_ty
- -- Either Id is in the local envt, or it's a global.
- -- In either case we don't need to apply the type
- -- environment to it.
-\end{code}
+Only in this second round can the \y be applied, and it
+might do the same again.
-Literals
-~~~~~~~~
\begin{code}
-simplExpr env (Lit l) [] result_ty = returnSmpl (Lit l)
-#ifdef DEBUG
-simplExpr env (Lit l) _ _ = panic "simplExpr:Lit with argument"
-#endif
+simplExpr :: CoreExpr -> SimplM CoreExpr
+simplExpr expr = getSubst `thenSmpl` \ subst ->
+ simplExprC expr (mkStop (substTy subst (exprType expr)))
+ -- The type in the Stop continuation is usually not used
+ -- It's only needed when discarding continuations after finding
+ -- a function that returns bottom.
+ -- Hence the lazy substitution
+
+simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
+ -- Simplify an expression, given a continuation
+
+simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) ->
+ returnSmpl (wrapFloats floats body)
+
+simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
+ -- Simplify an expression, returning floated binds
+
+simplExprF (Var v) cont
+ = simplVar v cont
+
+simplExprF (Lit lit) (Select _ bndr alts se cont)
+ = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
+
+simplExprF (Lit lit) cont
+ = rebuild (Lit lit) cont
+
+simplExprF (App fun arg) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplExprF fun (ApplyTo NoDup arg se cont)
+
+simplExprF (Case scrut bndr alts) cont
+ = getSubstEnv `thenSmpl` \ subst_env ->
+ getSwitchChecker `thenSmpl` \ chkr ->
+ if not (switchIsOn chkr NoCaseOfCase) then
+ -- Simplify the scrutinee with a Select continuation
+ simplExprF scrut (Select NoDup bndr alts subst_env cont)
+
+ else
+ -- If case-of-case is off, simply simplify the case expression
+ -- in a vanilla Stop context, and rebuild the result around it
+ simplExprC scrut (Select NoDup bndr alts subst_env
+ (mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
+ rebuild case_expr' cont
+
+
+simplExprF (Let (Rec pairs) body) cont
+ = simplIds (map fst pairs) $ \ bndrs' ->
+ -- NB: bndrs' don't have unfoldings or spec-envs
+ -- We add them as we go down, using simplPrags
+
+ simplRecBind False pairs bndrs' (simplExprF body cont)
+
+simplExprF expr@(Lam _ _) cont = simplLam expr cont
+
+simplExprF (Type ty) cont
+ = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ rebuild (Type ty') cont
+
+-- Comments about the Coerce case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- It's worth checking for a coerce in the continuation,
+-- in case we can cancel them. For example, in the initial form of a worker
+-- we may find (coerce T (coerce S (\x.e))) y
+-- and we'd like it to simplify to e[y/x] in one round of simplification
+
+simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
+ = simplType from `thenSmpl` \ from' ->
+ if outer_to == from' then
+ -- The coerces cancel out
+ simplExprF e cont
+ else
+ -- They don't cancel, but the inner one is redundant
+ simplExprF e (CoerceIt outer_to cont)
+
+simplExprF (Note (Coerce to from) e) cont
+ = simplType to `thenSmpl` \ to' ->
+ simplExprF e (CoerceIt to' cont)
+
+-- hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplExprF (Note (SCC cc) e) cont
+ = setEnclosingCC currentCCS $
+ simplExpr e `thenSmpl` \ e ->
+ rebuild (mkSCC cc e) cont
+
+simplExprF (Note InlineCall e) cont
+ = simplExprF e (InlinePlease cont)
+
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Don't inline in the RHS of something that has an
+-- inline pragma. But be careful that the InScopeEnv that
+-- we return does still have inlinings on!
+--
+-- It really is important to switch off inlinings. This function
+-- may be inlinined in other modules, so we don't want to remove
+-- (by inlining) calls to functions that have specialisations, or
+-- that may have transformation rules in an importing scope.
+-- E.g. {-# INLINE f #-}
+-- f x = ...g...
+-- and suppose that g is strict *and* has specialisations.
+-- If we inline g's wrapper, we deny f the chance of getting
+-- the specialised version of g when f is inlined at some call site
+-- (perhaps in some other module).
+
+-- It's also important not to inline a worker back into a wrapper.
+-- A wrapper looks like
+-- wraper = inline_me (\x -> ...worker... )
+-- Normally, the inline_me prevents the worker getting inlined into
+-- the wrapper (initially, the worker's only call site!). But,
+-- if the wrapper is sure to be called, the strictness analyser will
+-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+-- continuation. That's why the keep_inline predicate returns True for
+-- ArgOf continuations. It shouldn't do any harm not to dissolve the
+-- inline-me note under these circumstances
+
+simplExprF (Note InlineMe e) cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF e cont
+ where
+ keep_inline (Stop _ _) = True -- See notes above
+ keep_inline (ArgOf _ _ _) = True -- about this predicate
+ keep_inline other = False
+
+-- A non-recursive let is dealt with by simplBeta
+simplExprF (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplBeta bndr rhs se (contResultType cont) $
+ simplExprF body cont
\end{code}
-Primitive applications are simple.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: Prim expects an empty argument list! (Because it should be
-saturated and not higher-order. ADR)
+---------------------------------
\begin{code}
-simplExpr env (Prim op prim_args) args result_ty
- = ASSERT (null args)
- mapEager (simplArg env) prim_args `appEager` \ prim_args' ->
- simpl_op op `appEager` \ op' ->
- completePrim env op' prim_args'
+simplLam fun cont
+ = go fun cont
where
- -- PrimOps just need any types in them renamed.
+ zap_it = mkLamBndrZapper fun cont
+ cont_ty = contResultType cont
+
+ -- Type-beta reduction
+ go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
+ = ASSERT( isTyVar bndr )
+ tick (BetaReduction bndr) `thenSmpl_`
+ simplTyArg ty_arg arg_se `thenSmpl` \ ty_arg' ->
+ extendSubst bndr (DoneTy ty_arg')
+ (go body body_cont)
+
+ -- Ordinary beta reduction
+ go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplBeta zapped_bndr arg arg_se cont_ty
+ (go body body_cont)
+ where
+ zapped_bndr = zap_it bndr
- simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
- = mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
- simplTy env result_ty `appEager` \ result_ty' ->
- returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
+ -- Not enough args
+ go lam@(Lam _ _) cont = completeLam [] lam cont
- simpl_op other_op = returnEager other_op
-\end{code}
+ -- Exactly enough args
+ go expr cont = simplExprF expr cont
-Constructor applications
-~~~~~~~~~~~~~~~~~~~~~~~~
-Nothing to try here. We only reuse constructors when they appear as the
-rhs of a let binding (see completeLetBinding).
+-- completeLam deals with the case where a lambda doesn't have an ApplyTo
+-- continuation, so there are real lambdas left to put in the result
-\begin{code}
-simplExpr env (Con con con_args) args result_ty
- = ASSERT( null args )
- mapEager (simplArg env) con_args `appEager` \ con_args' ->
- returnSmpl (Con con con_args')
-\end{code}
+-- We try for eta reduction here, but *only* if we get all the
+-- way to an exprIsTrivial expression.
+-- We don't want to remove extra lambdas unless we are going
+-- to avoid allocating this thing altogether
+completeLam rev_bndrs (Lam bndr body) cont
+ = simplBinder bndr $ \ bndr' ->
+ completeLam (bndr':rev_bndrs) body cont
-Applications are easy too:
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Just stuff 'em in the arg stack
+completeLam rev_bndrs body cont
+ = simplExpr body `thenSmpl` \ body' ->
+ case try_eta body' of
+ Just etad_lam -> tick (EtaReduction (head rev_bndrs)) `thenSmpl_`
+ rebuild etad_lam cont
-\begin{code}
-simplExpr env (App fun arg) args result_ty
- = simplArg env arg `appEager` \ arg' ->
- simplExpr env fun (arg' : args) result_ty
-\end{code}
-
-Type lambdas
-~~~~~~~~~~~~
-
-First the case when it's applied to an argument.
+ Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
+ where
+ -- We don't use CoreUtils.etaReduce, because we can be more
+ -- efficient here:
+ -- (a) we already have the binders,
+ -- (b) we can do the triviality test before computing the free vars
+ -- [in fact I take the simple path and look for just a variable]
+ -- (c) we don't want to eta-reduce a data con worker or primop
+ -- because we only have to eta-expand them later when we saturate
+ try_eta body | not opt_SimplDoEtaReduction = Nothing
+ | otherwise = go rev_bndrs body
+
+ go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
+ go [] body | ok_body body = Just body -- Success!
+ go _ _ = Nothing -- Failure!
+
+ ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
+ ok_body other = False
+ ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+
+mkLamBndrZapper :: CoreExpr -- Function
+ -> SimplCont -- The context
+ -> Id -> Id -- Use this to zap the binders
+mkLamBndrZapper fun cont
+ | n_args >= n_params fun = \b -> b -- Enough args
+ | otherwise = \b -> zapLamIdInfo b
+ where
+ -- NB: we count all the args incl type args
+ -- so we must count all the binders (incl type lambdas)
+ n_args = countArgs cont
-\begin{code}
-simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
- = tick TyBetaReduction `thenSmpl_`
- simplExpr (extendTyEnv env tyvar ty) body args result_ty
+ n_params (Note _ e) = n_params e
+ n_params (Lam b e) = 1 + n_params e
+ n_params other = 0::Int
\end{code}
+
+---------------------------------
\begin{code}
-simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty
- = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
+simplType :: InType -> SimplM OutType
+simplType ty
+ = getSubst `thenSmpl` \ subst ->
let
- new_ty = mkTyVarTy tyvar'
- new_env = extendTyEnv env tyvar new_ty
- new_result_ty = applyTy result_ty new_ty
+ new_ty = substTy subst ty
in
- simplExpr new_env body [] new_result_ty `thenSmpl` \ body' ->
- returnSmpl (Lam (TyBinder tyvar') body')
-
-#ifdef DEBUG
-simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
- = panic "simplExpr:TyLam with non-TyArg"
-#endif
+ seqType new_ty `seq`
+ returnSmpl new_ty
\end{code}
-Ordinary lambdas
-~~~~~~~~~~~~~~~~
-
-There's a complication with lambdas that aren't saturated.
-Suppose we have:
+%************************************************************************
+%* *
+\subsection{Binding}
+%* *
+%************************************************************************
- (\x. \y. ...x...)
+@simplBeta@ is used for non-recursive lets in expressions,
+as well as true beta reduction.
-If we did nothing, x is used inside the \y, so would be marked
-as dangerous to dup. But in the common case where the abstraction
-is applied to two arguments this is over-pessimistic.
-So instead we don't take account of the \y when dealing with x's usage;
-instead, the simplifier is careful when partially applying lambdas.
+Very similar to @simplLazyBind@, but not quite the same.
\begin{code}
-simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty
- = go 0 env expr orig_args
- where
- go n env (Lam (ValBinder binder) body) (val_arg : args)
- | isValArg val_arg -- The lambda has an argument
- = tick BetaReduction `thenSmpl_`
- go (n+1) (extendIdEnvWithAtom env binder val_arg) body args
-
- go n env expr@(Lam (ValBinder binder) body) args
- -- The lambda is un-saturated, so we must zap the occurrence info
- -- on the arguments we've already beta-reduced into the body of the lambda
- = ASSERT( null args ) -- Value lambda must match value argument!
- let
- new_env = markDangerousOccs env (take n orig_args)
- in
- simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
- `thenSmpl` \ (expr', arity) ->
- returnSmpl expr'
-
- go n env non_val_lam_expr args -- The lambda had enough arguments
- = simplExpr env non_val_lam_expr args result_ty
-\end{code}
+simplBeta :: InId -- Binder
+ -> InExpr -> SubstEnv -- Arg, with its subst-env
+ -> OutType -- Type of thing computed by the context
+ -> SimplM OutExprStuff -- The body
+ -> SimplM OutExprStuff
+#ifdef DEBUG
+simplBeta bndr rhs rhs_se cont_ty thing_inside
+ | isTyVar bndr
+ = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
+#endif
+simplBeta bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally False {- not black listed -} bndr
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ extendSubst bndr (ContEx rhs_se rhs) thing_inside
-Let expressions
-~~~~~~~~~~~~~~~
+ | otherwise
+ = -- Simplify the RHS
+ simplBinder bndr $ \ bndr' ->
+ let
+ bndr_ty' = idType bndr'
+ is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
+ in
+ simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-\begin{code}
-simplExpr env (Let bind body) args result_ty
- = simplBind env bind (\env -> simplExpr env body args result_ty) result_ty
+ -- Now complete the binding and simplify the body
+ if needsCaseBinding bndr_ty' rhs' then
+ addCaseBind bndr' rhs' thing_inside
+ else
+ completeBinding bndr bndr' False False rhs' thing_inside
\end{code}
-Case expressions
-~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
-\end{code}
-
+simplTyArg :: InType -> SubstEnv -> SimplM OutType
+simplTyArg ty_arg se
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ ty_arg' = substTy (mkSubst in_scope se) ty_arg
+ in
+ seqType ty_arg' `seq`
+ returnSmpl ty_arg'
+
+simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally
+ -> Bool -- True <=> evaluate eagerly
+ -> InExpr -> SubstEnv
+ -> OutType -- cont_ty: Type of thing computed by the context
+ -> (OutExpr -> SimplM OutExprStuff)
+ -- Takes an expression of type rhs_ty,
+ -- returns an expression of type cont_ty
+ -> SimplM OutExprStuff -- An expression of type cont_ty
+
+simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
+ | is_strict
+ = getEnv `thenSmpl` \ env ->
+ setSubstEnv arg_se $
+ simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' ->
+ setAllExceptInScope env $
+ thing_inside rhs')
-Coercions
-~~~~~~~~~
-\begin{code}
-simplExpr env (Coerce coercion ty body) args result_ty
- = simplCoerce env coercion ty body args result_ty
+ | otherwise
+ = simplRhs False {- Not top level -}
+ True {- OK to float unboxed -}
+ arg_ty arg arg_se
+ thing_inside
\end{code}
-Set-cost-centre
-~~~~~~~~~~~~~~~
+completeBinding
+ - deals only with Ids, not TyVars
+ - take an already-simplified RHS
-1) Eliminating nested sccs ...
-We must be careful to maintain the scc counts ...
+It does *not* attempt to do let-to-case. Why? Because they are used for
-\begin{code}
-simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
- -- eliminate inner scc if no call counts and same cc as outer
- = simplExpr env (SCC cc1 expr) args result_ty
-
- | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
- -- eliminate outer scc if no call counts associated with either ccs
- = simplExpr env (SCC cc2 expr) args result_ty
-\end{code}
-
-2) Moving sccs inside lambdas ...
-
-\begin{code}
-simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
- | not (isSccCountCostCentre cc)
- -- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
-
-simplExpr env (SCC cc (Lam binder body)) args result_ty
- -- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
-\end{code}
+ - top-level bindings
+ (when let-to-case is impossible)
-3) Eliminating dict sccs ...
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
\begin{code}
-simplExpr env (SCC cc expr) args result_ty
- | squashableDictishCcExpr cc expr
- -- eliminate dict cc if trivial dict expression
- = simplExpr env expr args result_ty
-\end{code}
+completeBinding :: InId -- Binder
+ -> OutId -- New binder
+ -> Bool -- True <=> top level
+ -> Bool -- True <=> black-listed; don't inline
+ -> OutExpr -- Simplified RHS
+ -> SimplM (OutStuff a) -- Thing inside
+ -> SimplM (OutStuff a)
+
+completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
+ | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ = thing_inside
+
+ | trivial_rhs && not must_keep_binding
+ -- We're looking at a binding with a trivial RHS, so
+ -- perhaps we can discard it altogether!
+ --
+ -- NB: a loop breaker has must_keep_binding = True
+ -- and non-loop-breakers only have *forward* references
+ -- Hence, it's safe to discard the binding
+ --
+ -- NOTE: This isn't our last opportunity to inline.
+ -- We're at the binding site right now, and
+ -- we'll get another opportunity when we get to the ocurrence(s)
+
+ -- Note that we do this unconditional inlining only for trival RHSs.
+ -- Don't inline even WHNFs inside lambdas; doing so may
+ -- simply increase allocation when the function is called
+ -- This isn't the last chance; see NOTE above.
+ --
+ -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
+ -- Why? Because we don't even want to inline them into the
+ -- RHS of constructor arguments. See NOTE above
+ --
+ -- NB: Even NOINLINEis ignored here: if the rhs is trivial
+ -- it's best to inline it anyway. We often get a=E; b=a
+ -- from desugaring, with both a and b marked NOINLINE.
+ = -- Drop the binding
+ extendSubst old_bndr (DoneEx new_rhs) $
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ thing_inside
+
+ | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs,
+ not trivial_rhs && not (isUnLiftedType inner_ty)
+ -- x = coerce t e ==> c = e; x = inline_me (coerce t c)
+ -- Now x can get inlined, which moves the coercion
+ -- to the usage site. This is a bit like worker/wrapper stuff,
+ -- but it's useful to do it very promptly, so that
+ -- x = coerce T (I# 3)
+ -- get's w/wd to
+ -- c = I# 3
+ -- x = coerce T c
+ -- This in turn means that
+ -- case (coerce Int x) of ...
+ -- will inline x.
+ -- Also the full-blown w/w thing isn't set up for non-functions
+ --
+ -- The (not (isUnLiftedType inner_ty)) avoids the nasty case of
+ -- x::Int = coerce Int Int# (foo y)
+ -- ==>
+ -- v::Int# = foo y
+ -- x::Int = coerce Int Int# v
+ -- which would be bogus because then v will be evaluated strictly.
+ -- How can this arise? Via
+ -- x::Int = case (foo y) of { ... }
+ -- followed by case elimination.
+ --
+ -- The inline_me note is so that the simplifier doesn't
+ -- just substitute c back inside x's rhs! (Typically, x will
+ -- get substituted away, but not if it's exported.)
+ = newId SLIT("c") inner_ty $ \ c_id ->
+ completeBinding c_id c_id top_lvl False inner_rhs $
+ completeBinding old_bndr new_bndr top_lvl black_listed
+ (Note InlineMe (Note coercion (Var c_id))) $
+ thing_inside
+
+ | otherwise
+ = getSubst `thenSmpl` \ subst ->
+ let
+ -- We make new IdInfo for the new binder by starting from the old binder,
+ -- doing appropriate substitutions.
+ -- Then we add arity and unfolding info to get the new binder
+ new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
+ `setArityInfo` arity_info
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ addLetBind (NonRec final_id new_rhs) $
+ modifyInScope new_bndr final_id thing_inside
+
+ where
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ loop_breaker = isLoopBreaker occ_info
+ trivial_rhs = exprIsTrivial new_rhs
+ must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
+ arity_info = atLeastArity (exprArity new_rhs)
+\end{code}
-4) Moving arguments inside the body of an scc ...
-This moves the cost of doing the application inside the scc
-(which may include the cost of extracting methods etc)
-\begin{code}
-simplExpr env (SCC cost_centre body) args result_ty
- = let
- new_env = setEnclosingCC env cost_centre
- in
- simplExpr new_env body args result_ty `thenSmpl` \ body' ->
- returnSmpl (SCC cost_centre body')
-\end{code}
%************************************************************************
%* *
-\subsection{Simplify RHS of a Let/Letrec}
+\subsection{simplLazyBind}
%* *
%************************************************************************
-simplRhsExpr does arity-expansion. That is, given:
-
- * a right hand side /\ tyvars -> \a1 ... an -> e
- * the information (stored in BinderInfo) that the function will always
- be applied to at least k arguments
-
-it transforms the rhs to
+simplLazyBind basically just simplifies the RHS of a let(rec).
+It does two important optimisations though:
- /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk)
+ * It floats let(rec)s out of the RHS, even if they
+ are hidden by big lambdas
-This is a Very Good Thing!
+ * It does eta expansion
\begin{code}
-simplRhsExpr
- :: SimplEnv
- -> InBinder
- -> InExpr
- -> OutId -- The new binder (used only for its type)
- -> SmplM (OutExpr, ArityInfo)
-\end{code}
-
-
-\begin{code}
-simplRhsExpr env binder@(id,occ_info) rhs new_id
- | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
- -- Deal with the data type case, in which case the elaborate
- -- eta-expansion nonsense is really quite a waste of time.
- = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
- returnSmpl (rhs', ArityExactly 0)
-
- | otherwise -- OK, use the big hammer
- = -- Deal with the big lambda part
- mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
+simplLazyBind :: Bool -- True <=> top level
+ -> InId -> OutId
+ -> InExpr -- The RHS
+ -> SimplM (OutStuff a) -- The body of the binding
+ -> SimplM (OutStuff a)
+-- When called, the subst env is correct for the entire let-binding
+-- and hence right for the RHS.
+-- Also the binder has already been simplified, and hence is in scope
+
+simplLazyBind top_lvl bndr bndr' rhs thing_inside
+ = getBlackList `thenSmpl` \ black_list_fn ->
let
- new_tys = mkTyVarTys tyvars'
- body_ty = foldl applyTy rhs_ty new_tys
- lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
+ black_listed = black_list_fn bndr
in
- -- Deal with the little lambda part
- -- Note that we call simplLam even if there are no binders,
- -- in case it can do arity expansion.
- simplValLam lam_env body (getBinderInfoArity occ_info) body_ty `thenSmpl` \ (lambda', arity) ->
- -- Put on the big lambdas, trying to float out any bindings caught inside
- mkRhsTyLam tyvars' lambda' `thenSmpl` \ rhs' ->
-
- returnSmpl (rhs', arity)
- where
- rhs_ty = idType new_id
- rhs_env | idWantsToBeINLINEd id -- Don't ever inline in a INLINE thing's rhs
- = switchOffInlining env1 -- See comments with switchOffInlining
- | otherwise
- = env1
-
- -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
- -- for the rhs of top level defs is "OST_CENTRE". Consider
- -- f = \x -> e
- -- g = \y -> let v = f y in scc "x" (v ...)
- -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
- -- want to inline "v" since its CC is dynamically determined.
-
- current_cc = getEnclosingCC env
- env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
- | otherwise = env
-
- (tyvars, body) = collectTyBinders rhs
+ if preInlineUnconditionally black_listed bndr then
+ -- Inline unconditionally
+ tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ getSubstEnv `thenSmpl` \ rhs_se ->
+ (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
+ else
+
+ -- Simplify the RHS
+ getSubstEnv `thenSmpl` \ rhs_se ->
+ simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
+ (idType bndr')
+ rhs rhs_se $ \ rhs' ->
+
+ -- Now compete the binding and simplify the body
+ completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
\end{code}
-----------------------------------------------------------------
- An old special case that is now nuked.
-
-First a special case for variable right-hand sides
- v = w
-It's OK to simplify the RHS, but it's often a waste of time. Often
-these v = w things persist because v is exported, and w is used
-elsewhere. So if we're not careful we'll eta expand the rhs, only
-to eta reduce it in competeNonRec.
-
-If we leave the binding unchanged, we will certainly replace v by w at
-every occurrence of v, which is good enough.
-
-In fact, it's *better* to replace v by w than to inline w in v's rhs,
-even if this is the only occurrence of w. Why? Because w might have
-IdInfo (such as strictness) that v doesn't.
-
-Furthermore, there might be other uses of w; if so, inlining w in
-v's rhs will duplicate w's rhs, whereas replacing v by w doesn't.
-
-HOWEVER, we have to be careful if w is something that *must* be
-inlined. In particular, its binding may have been dropped. Here's
-an example that actually happened:
- let x = let y = e in y
- in f x
-The "let y" was floated out, and then (since y occurs once in a
-definitely inlinable position) the binding was dropped, leaving
- {y=e} let x = y in f x
-But now using the reasoning of this little section,
-y wasn't inlined, because it was a let x=y form.
+\begin{code}
+simplRhs :: Bool -- True <=> Top level
+ -> Bool -- True <=> OK to float unboxed (speculative) bindings
+ -- False for (a) recursive and (b) top-level bindings
+ -> OutType -- Type of RHS; used only occasionally
+ -> InExpr -> SubstEnv
+ -> (OutExpr -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
+ = -- Simplify it
+ setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) ->
+ let
+ (floats2, rhs2) = splitFloats float_ubx floats1 rhs1
+ in
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) )
+
+ -- Transform the RHS
+ -- It's important that we do eta expansion on function *arguments* (which are
+ -- simplified with simplRhs), as well as let-bound right-hand sides.
+ -- Otherwise we find that things like
+ -- f (\x -> case x of I# x' -> coerce T (\ y -> ...))
+ -- get right through to the code generator as two separate lambdas,
+ -- which is a Bad Thing
+ tryRhsTyLam rhs2 `thenSmpl` \ (floats3, rhs3) ->
+ tryEtaExpansion rhs3 rhs_ty `thenSmpl` \ (floats4, rhs4) ->
+
+ -- Float lets if (a) we're at the top level
+ -- or (b) the resulting RHS is one we'd like to expose
+ if (top_lvl || exprIsCheap rhs4) then
+ (if (isNilOL floats2 && null floats3 && null floats4) then
+ returnSmpl ()
+ else
+ tick LetFloatFromLet) `thenSmpl_`
+
+ addFloats floats2 rhs_in_scope $
+ addAuxiliaryBinds floats3 $
+ addAuxiliaryBinds floats4 $
+ thing_inside rhs4
+ else
+ -- Don't do the float
+ thing_inside (wrapFloats floats1 rhs1)
+
+demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))
+ -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
+demanded_float (Rec _) = False
+
+-- If float_ubx is true we float all the bindings, otherwise
+-- we just float until we come across an unlifted one.
+-- Remember that the unlifted bindings in the floats are all for
+-- guaranteed-terminating non-exception-raising unlifted things,
+-- which we are happy to do speculatively. However, we may still
+-- not be able to float them out, because the context
+-- is either a Rec group, or the top level, neither of which
+-- can tolerate them.
+splitFloats float_ubx floats rhs
+ | float_ubx = (floats, rhs) -- Float them all
+ | otherwise = go (fromOL floats)
+ where
+ go [] = (nilOL, rhs)
+ go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs)
+ | otherwise = case go fs of
+ (out, rhs') -> (f `consOL` out, rhs')
- HOWEVER
+ must_stay (Rec prs) = False -- No unlifted bindings in here
+ must_stay (NonRec b r) = isUnLiftedType (idType b)
+\end{code}
-This "optimisation" turned out to be a bad idea. If there's are
-top-level exported bindings like
- y = I# 3#
- x = y
-then y wasn't getting inlined in x's rhs, and we were getting
-bad code. So I've removed the special case from here, and
-instead we only try eta reduction and constructor reuse
-in completeNonRec if the thing is *not* exported.
+%************************************************************************
+%* *
+\subsection{Variables}
+%* *
+%************************************************************************
+\begin{code}
+simplVar var cont
+ = getSubst `thenSmpl` \ subst ->
+ case lookupIdSubst subst var of
+ DoneEx e -> zapSubstEnv (simplExprF e cont)
+ ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
+ DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
+ text "simplVar:" <+> ppr var )
+ zapSubstEnv (completeCall var1 occ cont)
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
+
+---------------------------------------------------------
+-- Dealing with a call
+
+completeCall var occ_info cont
+ = getBlackList `thenSmpl` \ black_list_fn ->
+ getInScope `thenSmpl` \ in_scope ->
+ getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
+ getDOptsSmpl `thenSmpl` \ dflags ->
+ let
+ black_listed = black_list_fn var
+ arg_infos = [ interestingArg in_scope arg subst
+ | (arg, subst, _) <- args, isValArg arg]
-\begin{pseudocode}
-simplRhsExpr env binder@(id,occ_info) (Var v) new_id
- | maybeToBool maybe_stop_at_var
- = returnSmpl (Var the_var, getIdArity the_var)
- where
- maybe_stop_at_var
- = case (runEager $ lookupId env v) of
- VarArg v' | not (must_unfold v') -> Just v'
- other -> Nothing
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
- Just the_var = maybe_stop_at_var
+ inline_cont | inline_call = discardInline cont
+ | otherwise = cont
- must_unfold v' = idMustBeINLINEd v'
- || case lookupOutIdEnv env v' of
- Just (_, _, InUnfolding _ _) -> True
- other -> False
-\end{pseudocode}
-
- End of old, nuked, special case.
-------------------------------------------------------------------
+ maybe_inline = callSiteInline dflags black_listed inline_call occ_info
+ var arg_infos interesting_cont
+ in
+ -- First, look for an inlining
+ case maybe_inline of {
+ Just unfolding -- There is an inlining!
+ -> tick (UnfoldingDone var) `thenSmpl_`
+ simplExprF unfolding inline_cont
+ ;
+ Nothing -> -- No inlining!
-%************************************************************************
-%* *
-\subsection{Simplify a lambda abstraction}
-%* *
-%************************************************************************
-Simplify (\binders -> body) trying eta expansion and reduction, given that
-the abstraction will always be applied to at least min_no_of_args.
+ simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' ->
-\begin{code}
-simplValLam env expr min_no_of_args expr_ty
- | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
-
- exprIsTrivial expr || -- or it's a trivial RHS
- -- No eta expansion for trivial RHSs
- -- It's rather a Bad Thing to expand
- -- g = f alpha beta
- -- to
- -- g = \a b c -> f alpha beta a b c
+ -- Next, look for rules or specialisations that match
--
- -- The original RHS is "trivial" (exprIsTrivial), because it generates
- -- no code (renames f to g). But the new RHS isn't.
+ -- It's important to simplify the args first, because the rule-matcher
+ -- doesn't do substitution as it goes. We don't want to use subst_args
+ -- (defined in the 'where') because that throws away useful occurrence info,
+ -- and perhaps-very-important specialisations.
+ --
+ -- Some functions have specialisations *and* are strict; in this case,
+ -- we don't want to inline the wrapper of the non-specialised thing; better
+ -- to call the specialised thing instead.
+ -- But the black-listing mechanism means that inlining of the wrapper
+ -- won't occur for things that have specialisations till a later phase, so
+ -- it's ok to try for inlining first.
+ --
+ -- You might think that we shouldn't apply rules for a loop breaker:
+ -- doing so might give rise to an infinite loop, because a RULE is
+ -- rather like an extra equation for the function:
+ -- RULE: f (g x) y = x+y
+ -- Eqn: f a y = a-y
+ --
+ -- But it's too drastic to disable rules for loop breakers.
+ -- Even the foldr/build rule would be disabled, because foldr
+ -- is recursive, and hence a loop breaker:
+ -- foldr k z (build g) = g k z
+ -- So it's up to the programmer: rules can cause divergence
- null potential_extra_binder_tys || -- or ain't a function
- no_of_extra_binders <= 0 -- or no extra binders needed
- = cloneIds env binders `thenSmpl` \ binders' ->
- let
- new_env = extendIdEnvWithClones env binders binders'
- in
- simplExpr new_env body [] body_ty `thenSmpl` \ body' ->
- returnSmpl (mkValLam binders' body', final_arity)
-
- | otherwise -- Eta expansion possible
- = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
- (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
- pprTrace "simplValLam" (vcat [ppr expr,
- ppr expr_ty,
- ppr binders,
- int no_of_extra_binders,
- ppr potential_extra_binder_tys])
- else \x -> x) $
-
- tick EtaExpansion `thenSmpl_`
- cloneIds env binders `thenSmpl` \ binders' ->
+ getSwitchChecker `thenSmpl` \ chkr ->
let
- new_env = extendIdEnvWithClones env binders binders'
+ maybe_rule | switchIsOn chkr DontApplyRules = Nothing
+ | otherwise = lookupRule in_scope var args'
in
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' ->
- returnSmpl (
- mkValLam (binders' ++ extra_binders') body',
- final_arity
- )
+ case maybe_rule of {
+ Just (rule_name, rule_rhs) ->
+ tick (RuleFired rule_name) `thenSmpl_`
+#ifdef DEBUG
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ptext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
+ text "After: " <+> pprCoreExpr rule_rhs])
+ else
+ id) $
+#endif
+ simplExprF rule_rhs call_cont ;
+
+ Nothing -> -- No rules
+
+ -- Done
+ rebuild (mkApps (Var var) args') call_cont
+ }}
+
+
+---------------------------------------------------------
+-- Simplifying the arguments of a call
+
+simplifyArgs :: Bool -- It's a data constructor
+ -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments
+ -> OutType -- Type of the continuation
+ -> ([OutExpr] -> SimplM OutExprStuff)
+ -> SimplM OutExprStuff
+
+-- Simplify the arguments to a call.
+-- This part of the simplifier may break the no-shadowing invariant
+-- Consider
+-- f (...(\a -> e)...) (case y of (a,b) -> e')
+-- where f is strict in its second arg
+-- If we simplify the innermost one first we get (...(\a -> e)...)
+-- Simplifying the second arg makes us float the case out, so we end up with
+-- case y of (a,b) -> f (...(\a -> e)...) e'
+-- So the output does not have the no-shadowing invariant. However, there is
+-- no danger of getting name-capture, because when the first arg was simplified
+-- we used an in-scope set that at least mentioned all the variables free in its
+-- static environment, and that is enough.
+--
+-- We can't just do innermost first, or we'd end up with a dual problem:
+-- case x of (a,b) -> f e (...(\a -> e')...)
+--
+-- I spent hours trying to recover the no-shadowing invariant, but I just could
+-- not think of an elegant way to do it. The simplifier is already knee-deep in
+-- continuations. We have to keep the right in-scope set around; AND we have
+-- to get the effect that finding (error "foo") in a strict arg position will
+-- discard the entire application and replace it with (error "foo"). Getting
+-- all this at once is TOO HARD!
+
+simplifyArgs is_data_con args cont_ty thing_inside
+ | not is_data_con
+ = go args thing_inside
+
+ | otherwise -- It's a data constructor, so we want
+ -- to switch off inlining in the arguments
+ -- If we don't do this, consider:
+ -- let x = +# p q in C {x}
+ -- Even though x get's an occurrence of 'many', its RHS looks cheap,
+ -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
+ = getBlackList `thenSmpl` \ old_bl ->
+ setBlackList noInlineBlackList $
+ go args $ \ args' ->
+ setBlackList old_bl $
+ thing_inside args'
where
- (binders,body) = collectValBinders expr
- no_of_binders = length binders
- (arg_tys, res_ty) = splitFunTys expr_ty
- potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
- pprTrace "simplValLam" (vcat [ppr expr,
- ppr expr_ty,
- ppr binders])
- else \x->x) $
- drop no_of_binders arg_tys
- body_ty = mkFunTys potential_extra_binder_tys res_ty
-
- -- Note: it's possible that simplValLam will be applied to something
- -- with a forall type. Eg when being applied to the rhs of
- -- let x = wurble
- -- where wurble has a forall-type, but no big lambdas at the top.
- -- We could be clever an insert new big lambdas, but we don't bother.
-
- etad_body_ty = mkFunTys (drop no_of_extra_binders potential_extra_binder_tys) res_ty
- extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
- final_arity = atLeastArity (no_of_binders + no_of_extra_binders)
-
- no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope; but ignore this
- -- info for thunks. To see why we ignore it for thunks,
- -- consider let f = lookup env key in (f 1, f 2)
- -- We'd better not eta expand f just because it is
- -- always applied!
- (min_no_of_args - no_of_binders)
-
- -- Next, try seeing if there's a lambda hidden inside
- -- something cheap.
- -- etaExpandCount can reuturn a huge number (like 10000!) if
- -- it finds that the body is a call to "error"; hence
- -- the use of "min" here.
- `max`
- (etaExpandCount body `min` length potential_extra_binder_tys)
-
- -- Finally, see if it's a state transformer, in which
- -- case we eta-expand on principle! This can waste work,
- -- but usually doesn't
- `max`
- case potential_extra_binder_tys of
- [ty] | ty == realWorldStatePrimTy -> 1
- other -> 0
-\end{code}
+ go [] thing_inside = thing_inside []
+ go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' ->
+ go args $ \ args' ->
+ thing_inside (arg':args')
+simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside
+ = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
+ thing_inside (Type new_ty_arg)
+
+simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ arg_ty = substTy (mkSubst in_scope se) (exprType val_arg)
+ in
+ if not is_data_con then
+ -- An ordinary function
+ simplValArg arg_ty is_strict val_arg se cont_ty thing_inside
+ else
+ -- A data constructor
+ -- simplifyArgs has already switched off inlining, so
+ -- all we have to do here is to let-bind any non-trivial argument
+
+ -- It's not always the case that new_arg will be trivial
+ -- Consider f x
+ -- where, in one pass, f gets substituted by a constructor,
+ -- but x gets substituted by an expression (assume this is the
+ -- unique occurrence of x). It doesn't really matter -- it'll get
+ -- fixed up next pass. And it happens for dictionary construction,
+ -- which mentions the wrapper constructor to start with.
+ simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' ->
+
+ if exprIsTrivial arg' then
+ thing_inside arg'
+ else
+ newId SLIT("a") (exprType arg') $ \ arg_id ->
+ addNonRecBind arg_id arg' $
+ thing_inside (Var arg_id)
+\end{code}
%************************************************************************
%* *
-\subsection[Simplify-coerce]{Coerce expressions}
+\subsection{Decisions about inlining}
%* *
%************************************************************************
-\begin{code}
--- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
-simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
-
--- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
-simplCoerce env coercion ty (Let bind body) args result_ty
- = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
-
--- Default case
-simplCoerce env coercion ty expr args result_ty
- = simplTy env ty `appEager` \ ty' ->
- simplTy env expr_ty `appEager` \ expr_ty' ->
- simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
- where
- expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
+NB: At one time I tried not pre/post-inlining top-level things,
+even if they occur exactly once. Reason:
+ (a) some might appear as a function argument, so we simply
+ replace static allocation with dynamic allocation:
+ l = <...>
+ x = f l
+ becomes
+ x = f <...>
- -- Try cancellation; we do this "on the way up" because
- -- I think that's where it'll bite best
- mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
- mkCoerce coercion ty body = Coerce coercion ty body
-\end{code}
+ (b) some top level things might be black listed
+HOWEVER, I found that some useful foldr/build fusion was lost (most
+notably in spectral/hartel/parstof) because the foldr didn't see the build.
-%************************************************************************
-%* *
-\subsection[Simplify-bind]{Binding groups}
-%* *
-%************************************************************************
+Doing the dynamic allocation isn't a big deal, in fact, but losing the
+fusion can be.
\begin{code}
-simplBind :: SimplEnv
- -> InBinding
- -> (SimplEnv -> SmplM OutExpr)
- -> OutType
- -> SmplM OutExpr
-
-simplBind env (NonRec binder rhs) body_c body_ty = simplNonRec env binder rhs body_c body_ty
-simplBind env (Rec pairs) body_c body_ty = simplRec env pairs body_c body_ty
+preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool
+ -- Examines a bndr to see if it is used just once in a
+ -- completely safe way, so that it is safe to discard the binding
+ -- inline its RHS at the (unique) usage site, REGARDLESS of how
+ -- big the RHS might be. If this is the case we don't simplify
+ -- the RHS first, but just inline it un-simplified.
+ --
+ -- This is much better than first simplifying a perhaps-huge RHS
+ -- and then inlining and re-simplifying it.
+ --
+ -- NB: we don't even look at the RHS to see if it's trivial
+ -- We might have
+ -- x = y
+ -- where x is used many times, but this is the unique occurrence
+ -- of y. We should NOT inline x at all its uses, because then
+ -- we'd do the same for y -- aargh! So we must base this
+ -- pre-rhs-simplification decision solely on x's occurrences, not
+ -- on its rhs.
+ --
+ -- Evne RHSs labelled InlineMe aren't caught here, because
+ -- there might be no benefit from inlining at the call site.
+
+preInlineUnconditionally black_listed bndr
+ | black_listed || opt_SimplNoPreInlining = False
+ | otherwise = case idOccInfo bndr of
+ OneOcc in_lam once -> not in_lam && once
+ -- Not inside a lambda, one occurrence ==> safe!
+ other -> False
\end{code}
+
%************************************************************************
%* *
-\subsection[Simplify-let]{Let-expressions}
+\subsection{The main rebuilder}
%* *
%************************************************************************
-Float switches
-~~~~~~~~~~~~~~
-The booleans controlling floating have to be set with a little care.
-Here's one performance bug I found:
-
- let x = let y = let z = case a# +# 1 of {b# -> E1}
- in E2
- in E3
- in E4
-
-Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
-Before case_floating_ok included float_exposes_hnf, the case expression was floated
-*one level per simplifier iteration* outwards. So it made th s
-
-
-Floating case from let
-~~~~~~~~~~~~~~~~~~~~~~
-When floating cases out of lets, remember this:
-
- let x* = case e of alts
- in <small expr>
-
-where x* is sure to be demanded or e is a cheap operation that cannot
-fail, e.g. unboxed addition. Here we should be prepared to duplicate
-<small expr>. A good example:
+\begin{code}
+-------------------------------------------------------------------
+-- Finish rebuilding
+rebuild_done expr = returnOutStuff expr
- let x* = case y of
- p1 -> build e1
- p2 -> build e2
- in
- foldr c n x*
-==>
- case y of
- p1 -> foldr c n (build e1)
- p2 -> foldr c n (build e2)
+---------------------------------------------------------
+rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
-NEW: We use the same machinery that we use for case-of-case to
-*always* do case floating from let, that is we let bind and abstract
-the original let body, and let the occurrence analyser later decide
-whether the new let should be inlined or not. The example above
-becomes:
+-- Stop continuation
+rebuild expr (Stop _ _) = rebuild_done expr
-==>
- let join_body x' = foldr c n x'
- in case y of
- p1 -> let x* = build e1
- in join_body x*
- p2 -> let x* = build e2
- in join_body x*
+-- ArgOf continuation
+rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
-note that join_body is a let-no-escape.
-In this particular example join_body will later be inlined,
-achieving the same effect.
-ToDo: check this is OK with andy
+-- ApplyTo continuation
+rebuild expr cont@(ApplyTo _ arg se cont')
+ = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
+ rebuild (App expr arg') cont'
+-- Coerce continuation
+rebuild expr (CoerceIt to_ty cont)
+ = rebuild (mkCoerce to_ty (exprType expr) expr) cont
-Let to case: two points
-~~~~~~~~~~~
+-- Inline continuation
+rebuild expr (InlinePlease cont)
+ = rebuild (Note InlineCall expr) cont
-Point 1. We defer let-to-case for all data types except single-constructor
-ones. Suppose we change
+rebuild scrut (Select _ bndr alts se cont)
+ = rebuild_case scrut bndr alts se cont
+\end{code}
- let x* = e in b
-to
- case e of x -> b
+Case elimination [see the code above]
+~~~~~~~~~~~~~~~~
+Start with a simple situation:
+
+ case x# of ===> e[x#/y#]
+ y# -> e
+
+(when x#, y# are of primitive type, of course). We can't (in general)
+do this for algebraic cases, because we might turn bottom into
+non-bottom!
+
+Actually, we generalise this idea to look for a case where we're
+scrutinising a variable, and we know that only the default case can
+match. For example:
+\begin{verbatim}
+ case x of
+ 0# -> ...
+ other -> ...(case x of
+ 0# -> ...
+ other -> ...) ...
+\end{code}
+Here the inner case can be eliminated. This really only shows up in
+eliminating error-checking code.
-It can be the case that we find that b ultimately contains ...(case x of ..)....
-and this is the only occurrence of x. Then if we've done let-to-case
-we can't inline x, which is a real pain. On the other hand, we lose no
-transformations by not doing this transformation, because the relevant
-case-of-X transformations are also implemented by simpl_bind.
+We also make sure that we deal with this very common case:
-If x is a single-constructor type, then we go ahead anyway, giving
+ case e of
+ x -> ...x...
- case e of (y,z) -> let x = (y,z) in b
+Here we are using the case as a strict let; if x is used only once
+then we want to inline it. We have to be careful that this doesn't
+make the program terminate when it would have diverged before, so we
+check that
+ - x is used strictly, or
+ - e is already evaluated (it may so if e is a variable)
-because now we can squash case-on-x wherever they occur in b.
+Lastly, we generalise the transformation to handle this:
-We do let-to-case on multi-constructor types in the tidy-up phase
-(tidyCoreExpr) mainly so that the code generator doesn't need to
-spot the demand-flag.
+ case e of ===> r
+ True -> r
+ False -> r
+We only do this for very cheaply compared r's (constructors, literals
+and variables). If pedantic bottoms is on, we only do it when the
+scrutinee is a PrimOp which can't fail.
-Point 2. It's important to try let-to-case before doing the
-strict-let-of-case transformation, which happens in the next equation
-for simpl_bind.
+We do it *here*, looking at un-simplified alternatives, because we
+have to check that r doesn't mention the variables bound by the
+pattern in each alternative, so the binder-info is rather useful.
- let a*::Int = case v of {p1->e1; p2->e2}
- in b
+So the case-elimination algorithm is:
-(The * means that a is sure to be demanded.)
-If we do case-floating first we get this:
+ 1. Eliminate alternatives which can't match
- let k = \a* -> b
- in case v of
- p1-> let a*=e1 in k a
- p2-> let a*=e2 in k a
+ 2. Check whether all the remaining alternatives
+ (a) do not mention in their rhs any of the variables bound in their pattern
+ and (b) have equal rhss
-Now watch what happens if we do let-to-case first:
+ 3. Check we can safely ditch the case:
+ * PedanticBottoms is off,
+ or * the scrutinee is an already-evaluated variable
+ or * the scrutinee is a primop which is ok for speculation
+ -- ie we want to preserve divide-by-zero errors, and
+ -- calls to error itself!
- case (case v of {p1->e1; p2->e2}) of
- Int a# -> let a*=I# a# in b
-===>
- let k = \a# -> let a*=I# a# in b
- in case v of
- p1 -> case e1 of I# a# -> k a#
- p1 -> case e2 of I# a# -> k a#
+ or * [Prim cases] the scrutinee is a primitive variable
-The latter is clearly better. (Remember the reboxing let-decl for a
-is likely to go away, because after all b is strict in a.)
+ or * [Alg cases] the scrutinee is a variable and
+ either * the rhs is the same variable
+ (eg case x of C a b -> x ===> x)
+ or * there is only one alternative, the default alternative,
+ and the binder is used strictly in its scope.
+ [NB this is helped by the "use default binder where
+ possible" transformation; see below.]
-We do not do let to case for WHNFs, e.g.
- let x = a:b in ...
- =/=>
- case a:b of x in ...
+If so, then we can replace the case with one of the rhss.
-as this is less efficient. but we don't mind doing let-to-case for
-"bottom", as that will allow us to remove more dead code, if anything:
- let x = error in ...
- ===>
- case error of x -> ...
- ===>
- error
+Blob of helper functions for the "case-of-something-else" situation.
-Notice that let to case occurs only if x is used strictly in its body
-(obviously).
+\begin{code}
+---------------------------------------------------------
+-- Eliminate the case if possible
+rebuild_case scrut bndr alts se cont
+ | maybeToBool maybe_con_app
+ = knownCon scrut (DataAlt con) args bndr alts se cont
-\begin{code}
--- Dead code is now discarded by the occurrence analyser,
-
-simplNonRec env binder@(id,occ_info) rhs body_c body_ty
- | inlineUnconditionally ok_to_dup id occ_info
- = -- The binder is used in definitely-inline way in the body
- -- So add it to the environment, drop the binding, and continue
- body_c (extendEnvGivenInlining env id occ_info rhs)
-
- | idWantsToBeINLINEd id
- = complete_bind env rhs -- Don't mess about with floating or let-to-case on
- -- INLINE things
-
- -- Do let-to-case right away for unpointed types
- -- These shouldn't occur much, but do occur right after desugaring,
- -- because we havn't done dependency analysis at that point, so
- -- we can't trivially do let-to-case (because there may be some unboxed
- -- things bound in letrecs that aren't really recursive).
- | isUnpointedType rhs_ty && not rhs_is_whnf
- = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
- (\env rhs -> complete_bind env rhs) body_ty
-
- -- Try let-to-case; see notes below about let-to-case
- | try_let_to_case &&
- will_be_demanded &&
- ( rhs_is_bot
- || (not rhs_is_whnf && singleConstructorType rhs_ty)
- -- Don't do let-to-case if the RHS is a constructor application.
- -- Even then only do it for single constructor types.
- -- For other types we defer doing it until the tidy-up phase at
- -- the end of simplification.
- )
- = tick Let2Case `thenSmpl_`
- simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
- (\env rhs -> complete_bind env rhs) body_ty
- -- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
- -- NB: it's tidier to call complete_bind not simpl_bind, else
- -- we nearly end up in a loop. Consider:
- -- let x = rhs in b
- -- ==> case rhs of (p,q) -> let x=(p,q) in b
- -- This effectively what the above simplCase call does.
- -- Now, the inner let is a let-to-case target again! Actually, since
- -- the RHS is in WHNF it won't happen, but it's a close thing!
+ | canEliminateCase scrut bndr alts
+ = tick (CaseElim bndr) `thenSmpl_` (
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ -- Remember to bind the case binder!
+ completeBinding bndr bndr' False False scrut $
+ simplExprF (head (rhssOfAlts alts)) cont)
| otherwise
- = simpl_bind env rhs
+ = complete_case scrut bndr alts se cont
+
where
- -- Try let-from-let
- simpl_bind env (Let bind rhs) | let_floating_ok
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
- (\env -> simpl_bind env rhs) body_ty
-
- -- Try case-from-let; this deals with a strict let of error too
- simpl_bind env (Case scrut alts) | case_floating_ok scrut
- = tick CaseFloatFromLet `thenSmpl_`
-
- -- First, bind large let-body if necessary
- if ok_to_dup || isSingleton (nonErrorRHSs alts)
- then
- simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body [] body_ty
- case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
- in
- simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
- returnSmpl (Let extra_binding case_expr)
-
- -- None of the above; simplify rhs and tidy up
- simpl_bind env rhs = complete_bind env rhs
-
- complete_bind env rhs
- = cloneId env binder `thenSmpl` \ new_id ->
- simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env binder
- (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (mkCoLetsAny binds body')
-
-
- -- All this stuff is computed at the start of the simpl_bind loop
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- float_primops = switchIsSet env SimplOkToFloatPrimOps
- ok_to_dup = switchIsSet env SimplOkToDupCode
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
- try_let_to_case = switchIsSet env SimplLetToCase
- no_float = switchIsSet env SimplNoLetFromStrictLet
-
- demand_info = getIdDemandInfo id
- will_be_demanded = willBeDemanded demand_info
- rhs_ty = idType id
-
- form = mkFormSummary rhs
- rhs_is_bot = case form of
- BottomForm -> True
- other -> False
- rhs_is_whnf = case form of
- VarForm -> True
- ValueForm -> True
- other -> False
-
- float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
-
- let_floating_ok = (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- float_exposes_hnf
-
- case_floating_ok scrut = (will_be_demanded && not no_float) ||
- (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
- -- See note below
-\end{code}
+ maybe_con_app = exprIsConApp_maybe scrut
+ Just (con, args) = maybe_con_app
+
+ -- See if we can get rid of the case altogether
+ -- See the extensive notes on case-elimination above
+canEliminateCase scrut bndr alts
+ = -- Check that the RHSs are all the same, and
+ -- don't use the binders in the alternatives
+ -- This test succeeds rapidly in the common case of
+ -- a single DEFAULT alternative
+ all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
+
+ -- Check that the scrutinee can be let-bound instead of case-bound
+ && ( exprOkForSpeculation scrut
+ -- OK not to evaluate it
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
+ || exprIsValue scrut -- It's already evaluated
+ || var_demanded_later scrut -- It'll be demanded later
+
+-- || not opt_SimplPedanticBottoms) -- Or we don't care!
+-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- its argument: case x of { y -> dataToTag# y }
+-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
+-- the info pointer. So we'll be pedantic all the time, and see if that gives any
+-- other problems
+ )
+ where
+ (rhs1:other_rhss) = rhssOfAlts alts
+ binders_unused (_, bndrs, _) = all isDeadBinder bndrs
-@completeNonRec@ looks at the simplified post-floating RHS of the
-let-expression, with a view to turning
- x = e
-into
- x = y
-where y is just a variable. Now we can eliminate the binding
-altogether, and replace x by y throughout.
+ var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later other = False
-There are two cases when we can do this:
- * When e is a constructor application, and we have
- another variable in scope bound to the same
- constructor application. [This is just a special
- case of common-subexpression elimination.]
+---------------------------------------------------------
+-- Case of something else
- * When e can be eta-reduced to a variable. E.g.
- x = \a b -> y a b
+complete_case scrut case_bndr alts se cont
+ = -- Prepare case alternatives
+ prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
+ impossible_cons alts `thenSmpl` \ better_alts ->
+
+ -- Set the new subst-env in place (before dealing with the case binder)
+ setSubstEnv se $
+ -- Deal with the case binder, and prepare the continuation;
+ -- The new subst_env is in place
+ prepareCaseCont better_alts cont $ \ cont' ->
+
-HOWEVER, if x is exported, we don't attempt this at all. Why not?
-Because then we can't remove the x=y binding, in which case we
-have just made things worse, perhaps a lot worse.
+ -- Deal with variable scrutinee
+ (
+ getSwitchChecker `thenSmpl` \ chkr ->
+ simplCaseBinder (switchIsOn chkr NoCaseOfCase)
+ scrut case_bndr $ \ case_bndr' zap_occ_info ->
-\begin{code}
- -- Right hand sides that are constructors
- -- let v = C args
- -- in
- --- ...(let w = C same-args in ...)...
- -- Then use v instead of w. This may save
- -- re-constructing an existing constructor.
-completeNonRec env binder new_id new_rhs
- | not (isExported new_id) -- Don't bother for exported things
- -- because we won't be able to drop
- -- its binding.
- && maybeToBool maybe_atomic_rhs
- = tick tick_type `thenSmpl_`
- returnSmpl (extendIdEnvWithAtom env binder rhs_arg, [])
- where
- Just (rhs_arg, tick_type) = maybe_atomic_rhs
- maybe_atomic_rhs
- = -- Try first for an existing constructor application
- case maybe_con new_rhs of {
- Just con -> Just (VarArg con, ConReused);
-
- Nothing -> -- No good; try eta-reduction
- case etaCoreExpr new_rhs of {
- Var v -> Just (VarArg v, AtomicRhs);
- Lit l -> Just (LitArg l, AtomicRhs);
-
- other -> Nothing -- Neither worked, so return Nothing
- }}
-
+ -- Deal with the case alternatives
+ simplAlts zap_occ_info impossible_cons
+ case_bndr' better_alts cont' `thenSmpl` \ alts' ->
- maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
- = lookForConstructor env con con_args
- maybe_con other_rhs = Nothing
+ mkCase scrut case_bndr' alts'
+ ) `thenSmpl` \ case_expr ->
-completeNonRec env binder@(id,occ_info) new_id new_rhs
- = returnSmpl (new_env , [NonRec new_id new_rhs])
+ -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
+ -- over the rebuild_done; rebuild_done returns the in-scope set, and
+ -- that should not include these chaps!
+ rebuild_done case_expr
where
- new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id)
- occ_info new_id new_rhs
+ impossible_cons = case scrut of
+ Var v -> otherCons (idUnfolding v)
+ other -> []
+
+
+knownCon :: OutExpr -> AltCon -> [OutExpr]
+ -> InId -> [InAlt] -> SubstEnv -> SimplCont
+ -> SimplM OutExprStuff
+
+knownCon expr con args bndr alts se cont
+ = -- Arguments should be atomic;
+ -- yell if not
+ WARN( not (all exprIsTrivial args),
+ text "knownCon" <+> ppr expr )
+ tick (KnownBranch bndr) `thenSmpl_`
+ setSubstEnv se (
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' False False expr $
+ -- Don't use completeBeta here. The expr might be
+ -- an unboxed literal, like 3, or a variable
+ -- whose unfolding is an unboxed literal... and
+ -- completeBeta will just construct another case
+ -- expression!
+ case findAlt con alts of
+ (DEFAULT, bs, rhs) -> ASSERT( null bs )
+ simplExprF rhs cont
+
+ (LitAlt lit, bs, rhs) -> ASSERT( null bs )
+ simplExprF rhs cont
+
+ (DataAlt dc, bs, rhs) -> ASSERT( length bs == length real_args )
+ extendSubstList bs (map mk real_args) $
+ simplExprF rhs cont
+ where
+ real_args = drop (dataConNumInstArgs dc) args
+ mk (Type ty) = DoneTy ty
+ mk other = DoneEx other
+ )
\end{code}
-----------------------------------------------------------------------------
- A digression on constructor CSE
-
-Consider
-@
- f = \x -> case x of
- (y:ys) -> y:ys
- [] -> ...
-@
-Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a
-bit on the compiler technology, but in general I believe not. For
-example, here's some code from a real program:
-@
-const.Int.max.wrk{-s2516-} =
- \ upk.s3297# upk.s3298# ->
- let {
- a.s3299 :: Int
- _N_ {-# U(P) #-}
- a.s3299 = I#! upk.s3297#
- } in
- case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
- _LT -> I#! upk.s3298#
- _EQ -> a.s3299
- _GT -> a.s3299
- }
-@
-The a.s3299 really isn't doing much good. We'd be better off inlining
-it. (Actually, let-no-escapery means it isn't as bad as it looks.)
-
-So the current strategy is to inline all known-form constructors, and
-only do the reverse (turn a constructor application back into a
-variable) when we find a let-expression:
-@
- let x = C a1 .. an
- in
- ... (let y = C a1 .. an in ...) ...
-@
-where it is always good to ditch the binding for y, and replace y by
-x.
- End of digression
-----------------------------------------------------------------------------
-
-----------------------------------------------------------------------------
- A digression on "optimising" coercions
-
- The trouble is that we kept transforming
- let x = coerce e
- y = coerce x
- in ...
- to
- let x' = coerce e
- y' = coerce x'
- in ...
- and counting a couple of ticks for this non-transformation
-\begin{pseudocode}
- -- We want to ensure that all let-bound Coerces have
- -- atomic bodies, so they can freely be inlined.
-completeNonRec env binder new_id (Coerce coercion ty rhs)
- | not (is_atomic rhs)
- = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
- (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
- -- Dangerous occ because, like constructor args,
- -- it can be duplicated easily
- let
- atomic_rhs = case runEager $ lookupId env1 inner_id of
- LitArg l -> Lit l
- VarArg v -> Var v
- in
- completeNonRec env1 binder new_id
- (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) ->
-
- returnSmpl (env2, binds1 ++ binds2)
-\end{pseudocode}
-----------------------------------------------------------------------------
-
-
+\begin{code}
+prepareCaseCont :: [InAlt] -> SimplCont
+ -> (SimplCont -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+ -- Polymorphic recursion here!
+
+prepareCaseCont [alt] cont thing_inside = thing_inside cont
+prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSmpl` \ alts_ty ->
+ mkDupableCont alts_ty cont thing_inside
+ -- At one time I passed in the un-simplified type, and simplified
+ -- it only if we needed to construct a join binder, but that
+ -- didn't work because we have to decompse function types
+ -- (using funResultTy) in mkDupableCont.
+\end{code}
-%************************************************************************
-%* *
-\subsection[Simplify-letrec]{Letrec-expressions}
-%* *
-%************************************************************************
+simplCaseBinder checks whether the scrutinee is a variable, v. If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
-Letrec expressions
-~~~~~~~~~~~~~~~~~~
-Here's the game plan
+There is a time we *don't* want to do that, namely when
+-fno-case-of-case is on. This happens in the first simplifier pass,
+and enhances full laziness. Here's the bad case:
+ f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
+If we eliminate the inner case, we trap it inside the I# v -> arm,
+which might prevent some full laziness happening. I've seen this
+in action in spectral/cichelli/Prog.hs:
+ [(m,n) | m <- [1..max], n <- [1..max]]
+Hence the no_case_of_case argument
-1. Float any let(rec)s out of the RHSs
-2. Clone all the Ids and extend the envt with these clones
-3. Simplify one binding at a time, adding each binding to the
- environment once it's done.
-This relies on the occurrence analyser to
- a) break all cycles with an Id marked MustNotBeInlined
- b) sort the decls into topological order
-The former prevents infinite inlinings, and the latter means
-that we get maximum benefit from working top to bottom.
+If we do this, then we have to nuke any occurrence info (eg IAmDead)
+in the case binder, because the case-binder now effectively occurs
+whenever v does. AND we have to do the same for the pattern-bound
+variables! Example:
+ (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
-\begin{code}
-simplRec env pairs body_c body_ty
- = -- Do floating, if necessary
- floatBind env False (Rec pairs) `thenSmpl` \ [Rec pairs'] ->
- let
- binders = map fst pairs'
- in
- cloneIds env binders `thenSmpl` \ ids' ->
- let
- env_w_clones = extendIdEnvWithClones env binders ids'
- in
- simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) ->
+Here, b and p are dead. But when we move the argment inside the first
+case RHS, and eliminate the second case, we get
- body_c new_env `thenSmpl` \ body' ->
+ case x or { (a,b) -> a b }
- returnSmpl (Let (Rec pairs') body')
-\end{code}
+Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
+happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
--- The env passed to simplRecursiveGroup already has
--- bindings that clone the variables of the group.
-simplRecursiveGroup env new_ids []
- = returnSmpl ([], env)
-
-simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
- | inlineUnconditionally ok_to_dup id occ_info
- = -- Single occurrence, so drop binding and extend env with the inlining
- -- This is a little delicate, because what if the unique occurrence
- -- is *before* this binding? This'll never happen, because
- -- either it'll be marked "never inline" or else its occurrence will
- -- occur after its binding in the group.
- --
- -- If these claims aren't right Core Lint will spot an unbound
- -- variable. A quick fix is to delete this clause for simplRecursiveGroup
- let
- new_env = extendEnvGivenInlining env new_id occ_info rhs
- in
- simplRecursiveGroup new_env new_ids pairs
-
- | otherwise
- = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
- let
- new_id' = new_id `withArity` arity
-
- -- ToDo: this next bit could usefully share code with completeNonRec
-
- new_env
- | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
- = env
-
- | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
- = extendIdEnvWithAtom env binder the_arg
-
- | otherwise -- Non-atomic
- = extendEnvGivenBinding env occ_info new_id new_rhs
- -- Don't eta if it doesn't eliminate the binding
-
- eta'd_rhs = etaCoreExpr new_rhs
- the_arg = case eta'd_rhs of
- Var v -> VarArg v
- Lit l -> LitArg l
- in
- simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
- returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
+simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside
+ | not no_case_of_case
+ = simplBinder (zap case_bndr) $ \ case_bndr' ->
+ modifyInScope v case_bndr' $
+ -- We could extend the substitution instead, but it would be
+ -- a hack because then the substitution wouldn't be idempotent
+ -- any more (v is an OutId). And this just just as well.
+ thing_inside case_bndr' zap
where
- ok_to_dup = switchIsSet env SimplOkToDupCode
+ zap b = b `setIdOccInfo` NoOccInfo
+
+simplCaseBinder add_eval_info other_scrut case_bndr thing_inside
+ = simplBinder case_bndr $ \ case_bndr' ->
+ thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr
\end{code}
+prepareCaseAlts does two things:
+1. Remove impossible alternatives
-\begin{code}
-floatBind :: SimplEnv
- -> Bool -- True <=> Top level
- -> InBinding
- -> SmplM [InBinding]
-
-floatBind env top_level bind
- | not float_lets ||
- n_extras == 0
- = returnSmpl [bind]
-
- | otherwise
- = tickN LetFloatFromLet n_extras `thenSmpl_`
- -- It's important to increment the tick counts if we
- -- do any floating. A situation where this turns out
- -- to be important is this:
- -- Float in produces:
- -- letrec x = let y = Ey in Ex
- -- in B
- -- Now floating gives this:
- -- letrec x = Ex
- -- y = Ey
- -- in B
- --- We now want to iterate once more in case Ey doesn't
- -- mention x, in which case the y binding can be pulled
- -- out as an enclosing let(rec), which in turn gives
- -- the strictness analyser more chance.
- returnSmpl binds'
+2. If the DEFAULT alternative can match only one possible constructor,
+ then make that constructor explicit.
+ e.g.
+ case e of x { DEFAULT -> rhs }
+ ===>
+ case e of x { (a,b) -> rhs }
+ where the type is a single constructor type. This gives better code
+ when rhs also scrutinises x or e.
+\begin{code}
+prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
+ | isDataTyCon tycon
+ = case (findDefault filtered_alts, missing_cons) of
+
+ ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
+ -> tick (FillInCaseDefault bndr) `thenSmpl_`
+ let
+ (_,_,ex_tyvars,_,_,_) = dataConSig data_con
+ in
+ getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ let
+ ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_tys = dataConArgTys data_con
+ (inst_tys ++ mkTyVarTys ex_tyvars')
+ in
+ newIds SLIT("a") arg_tys $ \ bndrs ->
+ returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
+
+ other -> returnSmpl filtered_alts
where
- (binds', _, n_extras) = fltBind bind
+ -- Filter out alternatives that can't possibly match
+ filtered_alts = case scrut_cons of
+ [] -> alts
+ other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+ missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon,
+ not (data_con `elem` handled_data_cons)]
+ handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++
+ [data_con | (DataAlt data_con, _, _) <- filtered_alts]
- -- fltBind guarantees not to return leaky floats
- -- and all the binders of the floats have had their demand-info zapped
- fltBind (NonRec bndr rhs)
- = (binds ++ [NonRec (un_demandify bndr) rhs'],
- leakFree bndr rhs',
- length binds)
- where
- (binds, rhs') = fltRhs rhs
-
- fltBind (Rec pairs)
- = ([Rec (extras
- ++
- binders `zip` rhss')],
- and (zipWith leakFree binders rhss'),
- length extras
- )
-
- where
- (binders, rhss) = unzip pairs
- (binds_s, rhss') = mapAndUnzip fltRhs rhss
- extras = concat (map get_pairs (concat binds_s))
+-- The default case
+prepareCaseAlts _ _ scrut_cons alts
+ = returnSmpl alts -- Functions
- get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
- get_pairs (Rec pairs) = pairs
-
- -- fltRhs has same invariant as fltBind
- fltRhs rhs
- | (always_float_let_from_let ||
- floatExposesHNF True False False rhs)
- = fltExpr rhs
-
- | otherwise
- = ([], rhs)
-
-
- -- fltExpr has same invariant as fltBind
- fltExpr (Let bind body)
- | not top_level || binds_wont_leak
- -- fltExpr guarantees not to return leaky floats
- = (binds' ++ body_binds, body')
- where
- (body_binds, body') = fltExpr body
- (binds', binds_wont_leak, _) = fltBind bind
-
- fltExpr expr = ([], expr)
--- Crude but effective
-leakFree (id,_) rhs = case getIdArity id of
- ArityAtLeast n | n > 0 -> True
- ArityExactly n | n > 0 -> True
- other -> whnfOrBottom (mkFormSummary rhs)
+----------------------
+simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
+ = mapSmpl simpl_alt alts
+ where
+ inst_tys' = tyConAppArgs (idType case_bndr')
+
+ -- handled_cons is all the constructors that are dealt
+ -- with, either by being impossible, or by there being an alternative
+ handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+
+ simpl_alt (DEFAULT, _, rhs)
+ = -- In the default case we record the constructors that the
+ -- case-binder *can't* be.
+ -- We take advantage of any OtherCon info in the case scrutinee
+ modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkOtherCon handled_cons) $
+ simplExprC rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (DEFAULT, [], rhs')
+
+ simpl_alt (con, vs, rhs)
+ = -- Deal with the pattern-bound variables
+ -- Mark the ones that are in ! positions in the data constructor
+ -- as certainly-evaluated.
+ -- NB: it happens that simplBinders does *not* erase the OtherCon
+ -- form of unfolding, so it's ok to add this info before
+ -- doing simplBinders
+ simplBinders (add_evals con vs) $ \ vs' ->
+
+ -- Bind the case-binder to (con args)
+ let
+ unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
+ in
+ modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $
+ simplExprC rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (con, vs', rhs')
+
+
+ -- add_evals records the evaluated-ness of the bound variables of
+ -- a case pattern. This is *important*. Consider
+ -- data T = T !Int !Int
+ --
+ -- case x of { T a b -> T (a+1) b }
+ --
+ -- We really must record that b is already evaluated so that we don't
+ -- go and re-evaluate it when constructing the result.
+
+ add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
+ add_evals other_con vs = vs
+
+ cat_evals [] [] = []
+ cat_evals (v:vs) (str:strs)
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
+ where
+ v' = zap_occ_info v
\end{code}
%************************************************************************
%* *
-\subsection[Simplify-atoms]{Simplifying atoms}
+\subsection{Duplicating continuations}
%* *
%************************************************************************
\begin{code}
-simplArg :: SimplEnv -> InArg -> Eager ans OutArg
-
-simplArg env (LitArg lit) = returnEager (LitArg lit)
-simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
- returnEager (TyArg ty')
-simplArg env (VarArg id) = lookupId env id
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Simplify-quickies]{Some local help functions}
-%* *
-%************************************************************************
-
-
-\begin{code}
--- fix_up_demandedness switches off the willBeDemanded Info field
--- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind
- = bind -- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
- = NonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (Rec pairs)
- = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
-
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
-
-is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
-is_cheap_prim_app other = False
-
-computeResultType :: SimplEnv -> InType -> [OutArg] -> OutType
-computeResultType env expr_ty orig_args
- = simplTy env expr_ty `appEager` \ expr_ty' ->
+mkDupableCont :: OutType -- Type of the thing to be given to the continuation
+ -> SimplCont
+ -> (SimplCont -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+mkDupableCont ty cont thing_inside
+ | contIsDupable cont
+ = thing_inside cont
+
+mkDupableCont _ (CoerceIt ty cont) thing_inside
+ = mkDupableCont ty cont $ \ cont' ->
+ thing_inside (CoerceIt ty cont')
+
+mkDupableCont ty (InlinePlease cont) thing_inside
+ = mkDupableCont ty cont $ \ cont' ->
+ thing_inside (InlinePlease cont')
+
+mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
+ = -- Build the RHS of the join point
+ newId SLIT("a") join_arg_ty ( \ arg_id ->
+ cont_fn (Var arg_id) `thenSmpl` \ (floats, (_, rhs)) ->
+ returnSmpl (Lam (setOneShotLambda arg_id) (wrapFloats floats rhs))
+ ) `thenSmpl` \ join_rhs ->
+
+ -- Build the join Id and continuation
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) $ \ join_id ->
let
- go ty [] = ty
- go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
- go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
- Just (_, res_ty) -> go res_ty args
- Nothing ->
- pprPanic "computeResultType" (vcat [
- ppr (a:args),
- ppr orig_args,
- ppr expr_ty',
- ppr ty])
+ new_cont = ArgOf OkToDup cont_ty
+ (\arg' -> rebuild_done (App (Var join_id) arg'))
in
- go expr_ty' orig_args
-
-var `withArity` UnknownArity = var
-var `withArity` arity = var `addIdArity` arity
-
-is_atomic (Var v) = True
-is_atomic (Lit l) = not (isNoRepLit l)
-is_atomic other = False
+ tick (CaseOfCase join_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+ addLetBind (NonRec join_id join_rhs) $
+ thing_inside new_cont
+
+mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
+ = mkDupableCont (funResultTy ty) cont $ \ cont' ->
+ setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
+ if exprIsDupable arg' then
+ thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
+ else
+ newId SLIT("a") (exprType arg') $ \ bndr ->
+
+ tick (CaseOfCase bndr) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+
+ addLetBind (NonRec bndr arg') $
+ -- But what if the arg should be case-bound? We can't use
+ -- addNonRecBind here because its type is too specific.
+ -- This has been this way for a long time, so I'll leave it,
+ -- but I can't convince myself that it's right.
+
+ thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')
+
+
+mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
+ = tick (CaseOfCase case_bndr) `thenSmpl_`
+ setSubstEnv se (
+ simplBinder case_bndr $ \ case_bndr' ->
+ prepareCaseCont alts cont $ \ cont' ->
+ mkDupableAlts case_bndr case_bndr' cont' alts $ \ alts' ->
+ returnOutStuff alts'
+ ) `thenSmpl` \ (alt_binds, (in_scope, alts')) ->
+
+ addFloats alt_binds in_scope $
+
+ -- NB that the new alternatives, alts', are still InAlts, using the original
+ -- binders. That means we can keep the case_bndr intact. This is important
+ -- because another case-of-case might strike, and so we want to keep the
+ -- info that the case_bndr is dead (if it is, which is often the case).
+ -- This is VITAL when the type of case_bndr is an unboxed pair (often the
+ -- case in I/O rich code. We aren't allowed a lambda bound
+ -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
+ thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont)))
+
+mkDupableAlts :: InId -> OutId -> SimplCont -> [InAlt]
+ -> ([InAlt] -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+mkDupableAlts case_bndr case_bndr' cont [] thing_inside
+ = thing_inside []
+mkDupableAlts case_bndr case_bndr' cont (alt:alts) thing_inside
+ = mkDupableAlt case_bndr case_bndr' cont alt $ \ alt' ->
+ mkDupableAlts case_bndr case_bndr' cont alts $ \ alts' ->
+ thing_inside (alt' : alts')
+
+mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside
+ = simplBinders bndrs $ \ bndrs' ->
+ simplExprC rhs cont `thenSmpl` \ rhs' ->
+
+ if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then
+ -- It is worth checking for a small RHS because otherwise we
+ -- get extra let bindings that may cause an extra iteration of the simplifier to
+ -- inline back in place. Quite often the rhs is just a variable or constructor.
+ -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
+ -- iterations because the version with the let bindings looked big, and so wasn't
+ -- inlined, but after the join points had been inlined it looked smaller, and so
+ -- was inlined.
+ --
+ -- But since the continuation is absorbed into the rhs, we only do this
+ -- for a Stop continuation.
+ --
+ -- NB: we have to check the size of rhs', not rhs.
+ -- Duplicating a small InAlt might invalidate occurrence information
+ -- However, if it *is* dupable, we return the *un* simplified alternative,
+ -- because otherwise we'd need to pair it up with an empty subst-env.
+ -- (Remember we must zap the subst-env before re-simplifying something).
+ -- Rather than do this we simply agree to re-simplify the original (small) thing later.
+ thing_inside alt
+
+ else
+ let
+ rhs_ty' = exprType rhs'
+ (used_bndrs, used_bndrs')
+ = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs)
+ (case_bndr' : bndrs'),
+ not (isDeadBinder bndr)]
+ -- The new binders have lost their occurrence info,
+ -- so we have to extract it from the old ones
+ in
+ ( if null used_bndrs'
+ -- If we try to lift a primitive-typed something out
+ -- for let-binding-purposes, we will *caseify* it (!),
+ -- with potentially-disastrous strictness results. So
+ -- instead we turn it into a function: \v -> e
+ -- where v::State# RealWorld#. The value passed to this function
+ -- is realworld#, which generates (almost) no code.
+
+ -- There's a slight infelicity here: we pass the overall
+ -- case_bndr to all the join points if it's used in *any* RHS,
+ -- because we don't know its usage in each RHS separately
+
+ -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
+ -- we make the join point into a function whenever used_bndrs'
+ -- is empty. This makes the join-point more CPR friendly.
+ -- Consider: let j = if .. then I# 3 else I# 4
+ -- in case .. of { A -> j; B -> j; C -> ... }
+ --
+ -- Now CPR should not w/w j because it's a thunk, so
+ -- that means that the enclosing function can't w/w either,
+ -- which is a lose. Here's the example that happened in practice:
+ -- kgmod :: Int -> Int -> Int
+ -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+ -- then 78
+ -- else 5
+
+ then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
+ returnSmpl ([rw_id], [Var realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
+ )
+ `thenSmpl` \ (final_bndrs', final_args) ->
+
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ in
+ addLetBind (NonRec join_bndr (mkLams really_final_bndrs rhs')) $
+ thing_inside (con, bndrs, mkApps (Var join_bndr) final_args)
\end{code}
-
projects / ghc-hetmet.git / blobdiff