%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[Simplify]{The main module of the simplifier}
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-import Pretty -- these are for debugging only
-import Outputable
+import Ubiq{-uitous-}
+import SmplLoop -- paranoia checking
-import SimplMonad
-import SimplEnv
-import TaggedCore
-import PlainCore
-
-import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..),
- primOpOkForSpeculation, PrimOp(..), PrimKind,
- realWorldStateTy
- IF_ATTACK_PRAGMAS(COMMA realWorldTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( getUniDataTyCon_maybe, mkTyVarTy, applyTy,
- splitTyArgs, splitTypeWithDictsAsArgs,
- maybeUnpackFunTy, isPrimType
- )
-import BasicLit ( isNoRepLit, BasicLit(..) )
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import Id
-import IdInfo
-import Maybes ( Maybe(..), catMaybes, maybeToBool )
-import SimplCase
-import SimplUtils
+import CoreSyn
+import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
+ unTagBinders, squashableDictishCcExpr,
+ manifestlyWHNF
+ )
+import Id ( idType, idWantsToBeINLINEd,
+ getIdDemandInfo, addIdDemandInfo,
+ GenId{-instance NamedThing-}
+ )
+import IdInfo ( willBeDemanded, DemandInfo )
+import Literal ( isNoRepLit )
+import Maybes ( maybeToBool )
+import Name ( isLocallyDefined )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppAbove )
+import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
+import SimplCase ( simplCase, bindLargeRhs )
+import SimplEnv
+import SimplMonad
import SimplVar ( completeVar )
-import Util
+import SimplUtils
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
+ splitFunTy, getFunTy_maybe, eqTy
+ )
+import TysWiredIn ( realWorldStateTy )
+import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
\end{code}
The controlling flags, and what they do
-fsimplify = run the simplifier
-ffloat-inwards = runs the float lets inwards pass
-ffloat = runs the full laziness pass
- (ToDo: rename to -ffull-laziness)
+ (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.)
+ (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].
+ 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].
+-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].
+ multiple branches [simplifier].
-flet-to-case = does let-to-case transformation [simplifier].
Head normal forms
~~~~~~~~~~~~~~~~~
We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.
+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
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@.
+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@.
-Becuase of this, the "unconditional-inline" mechanism above is the only way
-in which non-HNFs can get inlined.
+Because of this, the "unconditional-inline" mechanism above is the
+only way in which non-HNFs can get inlined.
INLINE pragmas
~~~~~~~~~~~~~~
things in the UnfoldEnv with UnfoldAlways flags, which originated in
other INLINE pragmas.)
-So, we clean out the UnfoldEnv of all GeneralForm inlinings before
+So, we clean out the UnfoldEnv of all GenForm inlinings before
going into such an RHS.
What about imports? They don't really matter much because we only
-- Dead code is now discarded by the occurrence analyser,
-simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
| inlineUnconditionally ok_to_dup_code occ_info
- = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
- let
+ = let
new_env = extendIdEnvWithInlining env env binder rhs
in
simplTopBinds new_env binds
- --)
where
ok_to_dup_code = switchIsSet env SimplOkToDupCode
-simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
let
new_env = case rhs' of
- CoVar var -> extendIdEnvWithAtom env binder (CoVarAtom var)
- CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit)
- other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
+ Var v -> extendIdEnvWithAtom env binder (VarArg v)
+ Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
+ other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
in
- --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
-
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds' ->
-- Glue together and return ...
- -- We leave it to susequent occurrence analysis to throw away
+ -- We leave it to susequent occurrence analysis to throw away
-- an unused atom binding. This localises the decision about
-- discarding top-level bindings.
- returnSmpl (CoNonRec in_id rhs' : binds')
- --)
+ returnSmpl (NonRec in_id rhs' : binds')
-simplTopBinds env (CoRec pairs : binds)
+simplTopBinds env (Rec pairs : binds)
= simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
- --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
-
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds' ->
-- Glue together and return
returnSmpl (bind' : binds')
- --)
where
triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
-- No cloning necessary at top level
%* *
%************************************************************************
-
-\begin{code}
+
+\begin{code}
simplExpr :: SimplEnv
-> InExpr -> [OutArg]
- -> SmplM OutExpr
+ -> SmplM OutExpr
\end{code}
The expression returned has the same meaning as the input expression
Variables
~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise
-do the more sophisticated stuff.
+Check if there's a macro-expansion, and if so rattle on. Otherwise do
+the more sophisticated stuff.
\begin{code}
-simplExpr env (CoVar v) args
- = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
- case lookupId env v of
+simplExpr env (Var v) args
+ = case (lookupId env v) of
Nothing -> let
- new_v = simplTyInId env v
+ new_v = simplTyInId env v
in
completeVar env new_v args
Just info ->
case info of
- ItsAnAtom (CoLitAtom lit) -- A boring old literal
+ ItsAnAtom (LitArg lit) -- A boring old literal
-- Paranoia check for args empty
-> case args of
- [] -> returnSmpl (CoLit lit)
+ [] -> returnSmpl (Lit lit)
other -> panic "simplExpr:coVar"
- ItsAnAtom (CoVarAtom var) -- More interesting! An id!
+ ItsAnAtom (VarArg var) -- More interesting! An id!
-- No need to substitute the type env here,
-- because we already have!
- -> completeVar env var args
-
+ -> completeVar env var args
+
InlineIt id_env ty_env in_expr -- A macro-expansion
-> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
- --)
\end{code}
Literals
-~~~~~~~~~
+~~~~~~~~
\begin{code}
-simplExpr env (CoLit l) [] = returnSmpl (CoLit l)
-simplExpr env (CoLit l) _ = panic "simplExpr:CoLit with argument"
+simplExpr env (Lit l) [] = returnSmpl (Lit l)
+#ifdef DEBUG
+simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
+#endif
\end{code}
-Primitive applications are simple.
+Primitive applications are simple.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: CoPrim expects an empty argument list! (Because it should be
+NB: Prim expects an empty argument list! (Because it should be
saturated and not higher-order. ADR)
-\begin{code}
-simplExpr env (CoPrim op tys prim_args) args
+\begin{code}
+simplExpr env (Prim op prim_args) args
= ASSERT (null args)
let
- tys' = [simplTy env ty | ty <- tys]
- prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
+ prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
op' = simpl_op op
in
- completePrim env op' tys' prim_args'
+ completePrim env op' prim_args'
where
-- PrimOps just need any types in them renamed.
- simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
+ simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
= let
arg_tys' = map (simplTy env) arg_tys
result_ty' = simplTy env result_ty
simpl_op other_op = other_op
\end{code}
-Constructor applications
-~~~~~~~~~~~~~~~~~~~~~~~~
+Constructor applications
+~~~~~~~~~~~~~~~~~~~~~~~~
Nothing to try here. We only reuse constructors when they appear as the
rhs of a let binding (see completeLetBinding).
\begin{code}
-simplExpr env (CoCon con tys con_args) args
+simplExpr env (Con con con_args) args
= ASSERT( null args )
- returnSmpl (CoCon con tys' con_args')
- where
- con_args' = [simplAtom env con_arg | con_arg <- con_args]
- tys' = [simplTy env ty | ty <- tys]
+ returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
\end{code}
-Applications are easy too:
-~~~~~~~~~~~~~~~~~~~~~~~~~~
+Applications are easy too:
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Just stuff 'em in the arg stack
-\begin{code}
-simplExpr env (CoApp fun arg) args
- = simplExpr env fun (ValArg (simplAtom env arg) : args)
-
-simplExpr env (CoTyApp fun ty) args
- = simplExpr env fun (TypeArg (simplTy env ty) : args)
+\begin{code}
+simplExpr env (App fun arg) args
+ = simplExpr env fun (simplArg env arg : args)
\end{code}
Type lambdas
We only eta-reduce a type lambda if all type arguments in the body can
be eta-reduced. This requires us to collect up all tyvar parameters so
-we can pass them all to @mkCoTyLamTryingEta@.
+we can pass them all to @mkTyLamTryingEta@.
-\begin{code}
-simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
- = ASSERT(not (isPrimType ty))
+\begin{code}
+simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
+ = -- ASSERT(not (isPrimType ty))
let
new_env = extendTyEnv env tyvar ty
in
tick TyBetaReduction `thenSmpl_`
simplExpr new_env body args
-simplExpr env tylam@(CoTyLam tyvar body) []
- = do_tylambdas env [] tylam
+simplExpr env tylam@(Lam (TyBinder tyvar) body) []
+ = do_tylambdas env [] tylam
where
- do_tylambdas env tyvars' (CoTyLam tyvar body)
+ do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
= -- Clone the type variable
cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
let
= simplExpr env body [] `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
- then mkCoTyLamTryingEta
- else mkCoTyLam) (reverse tyvars') body'
+ then mkTyLamTryingEta
+ else mkTyLam) (reverse tyvars') body'
)
-simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
- = panic "simplExpr:CoTyLam ValArg"
+#ifdef DEBUG
+simplExpr env (Lam (TyBinder _) _) (_ : _)
+ = panic "simplExpr:TyLam with non-TyArg"
+#endif
\end{code}
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (CoLam binders body) args
+simplExpr env (Lam (ValBinder binder) body) args
| null leftover_binders
= -- The lambda is saturated (or over-saturated)
tick BetaReduction `thenSmpl_`
else returnSmpl (panic "BetaReduction")
) `thenSmpl_`
- simplLam env_for_too_few_args leftover_binders body
+ simplLam env_for_too_few_args leftover_binders body
0 {- Guaranteed applied to at least 0 args! -}
where
- (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args
+ (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
-- (\ x y z -> e) p q r
-- ==> e[p/x, q/y, r/z]
--
- zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
+ zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
| ((id, occ_info), arg) <- binder_args_pairs ]
- collect_val_args :: [InBinder] -- Binders
- -> [OutArg] -- Arguments
- -> ([(InBinder,OutAtom)], -- Binder,arg pairs
- [InBinder], -- Leftover binders
- [OutArg]) -- Leftover args
-
+ collect_val_args :: InBinder -- Binder
+ -> [OutArg] -- Arguments
+ -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
+ [InBinder], -- Leftover binders (ToDo: a maybe)
+ [OutArg]) -- Leftover args
+
-- collect_val_args strips off the leading ValArgs from
-- the current arg list, returning them along with the
-- depleted list
- collect_val_args [] args = ([], [], args)
- collect_val_args binders [] = ([], binders, [])
- collect_val_args (binder:binders) (ValArg val_arg : args)
- = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
- where
- (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
-
- collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
- -- TypeArg should never meet a CoLam
+ collect_val_args binder [] = ([], [binder], [])
+ collect_val_args binder (arg : args) | isValArg arg
+ = ([(binder,arg)], [], args)
+
+#ifdef DEBUG
+ collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
+ -- TyArg should never meet a Lam
+#endif
\end{code}
-Let expressions
+Let expressions
~~~~~~~~~~~~~~~
-\begin{code}
-simplExpr env (CoLet bind body) args
- = simplBind env bind (\env -> simplExpr env body args) (computeResultType env body args)
+\begin{code}
+simplExpr env (Let bind body) args
+
+{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
+ and it doesn't seem worth retaining the ability to not float applications
+ into let/case
+
+ | switchIsSet env SimplNoLetFromApp
+ = simplBind env bind (\env -> simplExpr env body [])
+ (computeResultType env body []) `thenSmpl` \ let_expr' ->
+ returnSmpl (mkGenApp let_expr' args)
+
+ | otherwise -- No float from application
+-}
+
+ = simplBind env bind (\env -> simplExpr env body args)
+ (computeResultType env body args)
\end{code}
-Case expressions
+Case expressions
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env expr@(CoCase scrut alts) args
+simplExpr env expr@(Case scrut alts) args
= simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
(computeResultType env expr args)
\end{code}
-Set-cost-centre
+Coercions
+~~~~~~~~~
+\begin{code}
+simplExpr env (Coerce coercion ty body) args
+ = simplCoerce env coercion ty body args
+\end{code}
+
+
+Set-cost-centre
~~~~~~~~~~~~~~~
A special case we do:
interfaces change less (arities).
\begin{code}
-simplExpr env (CoSCC cc (CoLam binders body)) args
- = simplExpr env (CoLam binders (CoSCC cc body)) args
-
-simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
- = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
+simplExpr env (SCC cc (Lam binder body)) args
+ = simplExpr env (Lam binder (SCC cc body)) args
\end{code}
Some other slightly turgid SCC tidying-up cases:
\begin{code}
-simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
+simplExpr env (SCC cc1 expr@(SCC _ _)) args
= simplExpr env expr args
- -- the outer _scc_ serves no purpose
+ -- the outer _scc_ serves no purpose
-simplExpr env (CoSCC cc expr) args
+simplExpr env (SCC cc expr) args
| squashableDictishCcExpr cc expr
= simplExpr env expr args
-- the DICT-ish CC is no longer serving any purpose
ToDo: check with Patrick that this is ok.
\begin{code}
-simplExpr env (CoSCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args
= let
new_env = setEnclosingCC env (EnclosingCC cost_centre)
in
simplExpr new_env body args `thenSmpl` \ body' ->
- returnSmpl (CoSCC cost_centre body')
+ returnSmpl (SCC cost_centre body')
\end{code}
%************************************************************************
This is a Very Good Thing!
\begin{code}
-simplRhsExpr
+simplRhsExpr
:: SimplEnv
-> InBinder
-> InExpr
- -> SmplM OutExpr
+ -> SmplM OutExpr
-simplRhsExpr env binder@(id,occ_info) rhs
+simplRhsExpr env binder@(id,occ_info) rhs
| dont_eta_expand rhs
= simplExpr rhs_env rhs []
= -- Deal with the big lambda part
mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
let
- lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
+ lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))
in
-- Deal with the little lambda part
-- Note that we call simplLam even if there are no binders, in case
-- Put it back together
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
- then mkCoTyLamTryingEta
- else mkCoTyLam) tyvars' lambda'
+ then mkTyLamTryingEta
+ else mkTyLam) tyvars' lambda'
)
where
-- Note from ANDY:
-- we might want a {-# INLINE UNSIMPLIFIED #-} option.
rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
| otherwise = env
-
- (tyvars, binders, body) = digForLambdas rhs
+
+ (uvars, tyvars, binders, body) = collectBinders rhs
min_no_of_args | not (null binders) && -- It's not a thunk
switchIsSet env SimplDoArityExpand -- Arity expansion on
-- get eta-reduced back to y. Furthermore, if this was a top level defn,
-- and x was exported, then the defn won't be eliminated, so this
-- silly expand/reduce cycle will happen every time, which makes the
- -- simplifier loop!.
+ -- simplifier loop!.
-- The solution is to not even try eta expansion unless the rhs looks
- -- non-trivial.
- dont_eta_expand (CoLit _) = True
- dont_eta_expand (CoVar _) = True
- dont_eta_expand (CoTyApp f _) = dont_eta_expand f
- dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
- dont_eta_expand (CoCon _ _ _) = True
- dont_eta_expand _ = False
+ -- non-trivial.
+ dont_eta_expand (Lit _) = True
+ dont_eta_expand (Var _) = True
+ dont_eta_expand (Con _ _) = True
+ dont_eta_expand (App f a)
+ | notValArg a = dont_eta_expand f
+ dont_eta_expand (Lam x b)
+ | notValBinder x = dont_eta_expand b
+ dont_eta_expand _ = False
\end{code}
-
+
%************************************************************************
%* *
\subsection{Simplify a lambda abstraction}
simplExpr new_env body [] `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
- else mkCoLam) binders' body'
+ then mkValLamTryingEta
+ else mkValLam) binders' body'
)
| otherwise -- Eta expansion possible
let
new_env = extendIdEnvWithClones env binders binders'
in
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders') `thenSmpl` \ body' ->
+ newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
+ simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
- else mkCoLam) (binders' ++ extra_binders') body'
+ then mkValLamTryingEta
+ else mkValLam) (binders' ++ extra_binders') body'
)
where
- (potential_extra_binder_tys, res_ty)
- = splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
+ (potential_extra_binder_tys, res_ty)
+ = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
-- Note: it's possible that simplLam will be applied to something
-- with a forall type. Eg when being applied to the rhs of
-- let x = wurble
-- but usually doesn't
`max`
case potential_extra_binder_tys of
- [ty] | ty == realWorldStateTy -> 1
- other -> 0
+ [ty] | ty `eqTy` realWorldStateTy -> 1
+ other -> 0
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Simplify-coerce]{Coerce expressions}
+%* *
+%************************************************************************
+
+\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
+ = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
+ (computeResultType env expr args)
+
+-- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
+simplCoerce env coercion ty (Let bind body) args
+ = simplBind env bind (\env -> simplCoerce env coercion ty body args)
+ (computeResultType env body args)
+
+-- Default case
+simplCoerce env coercion ty expr args
+ = simplExpr env expr [] `thenSmpl` \ expr' ->
+ returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
+ where
+
+ -- Try cancellation; we do this "on the way up" because
+ -- I think that's where it'll bite best
+ mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
+ mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
+ mkCoerce coercion ty body = Coerce coercion ty body
\end{code}
simplBind :: SimplEnv
-> InBinding
-> (SimplEnv -> SmplM OutExpr)
- -> OutUniType
+ -> OutType
-> SmplM OutExpr
\end{code}
==>
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*
+ in case y of
+ p1 -> let x* = build e1
+ in join_body x*
+ p2 -> let x* = build e2
+ in join_body x*
note that join_body is a let-no-escape.
In this particular example join_body will later be inlined,
\begin{code}
-- Dead code is now discarded by the occurrence analyser,
-simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
+simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
| inlineUnconditionally ok_to_dup occ_info
= body_c (extendIdEnvWithInlining env env binder rhs)
-- If we do case-floating first we get this:
--
-- let k = \a* -> b
--- in case v of
+-- in case v of
-- p1-> let a*=e1 in k a
-- p2-> let a*=e2 in k a
--
-- 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.)
- | will_be_demanded &&
+ | will_be_demanded &&
try_let_to_case &&
type_ok_for_let_to_case rhs_ty &&
not (manifestlyWHNF rhs)
its body (obviously).
-}
- | will_be_demanded ||
- always_float_let_from_let ||
+ | (will_be_demanded && not no_float) ||
+ always_float_let_from_let ||
floatExposesHNF float_lets float_primops ok_to_dup rhs
= try_float env rhs body_c
where
will_be_demanded = willBeDemanded (getIdDemandInfo id)
- rhs_ty = getIdUniType id
+ rhs_ty = idType id
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
-------------------------------------------
done_float env rhs body_c
= simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeLet env binder rhs rhs' body_c body_ty
+ completeLet env binder rhs' body_c body_ty
---------------------------------------
- try_float env (CoLet bind rhs) body_c
+ try_float env (Let bind rhs) body_c
= tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
+ simplBind env (fix_up_demandedness will_be_demanded bind)
(\env -> try_float env rhs body_c) body_ty
- try_float env (CoCase scrut alts) body_c
+ try_float env (Case scrut alts) body_c
| will_be_demanded || (float_primops && is_cheap_prim_app scrut)
= tick CaseFloatFromLet `thenSmpl_`
-- First, bind large let-body if necessary
if no_need_to_bind_large_body then
simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
- else
+ else
bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
let
body_c' = \env -> simplExpr env new_body []
in
- simplCase env scrut alts
+ simplCase env scrut alts
(\env rhs -> try_float env rhs body_c')
body_ty `thenSmpl` \ case_expr ->
- returnSmpl (CoLet extra_binding case_expr)
+ returnSmpl (Let extra_binding case_expr)
where
no_need_to_bind_large_body
= ok_to_dup || isSingleton (nonErrorRHSs alts)
try_float env other_rhs body_c = done_float env other_rhs body_c
\end{code}
-Letrec expressions
+Letrec expressions
~~~~~~~~~~~~~~~~~~
Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
letrec
f = ....g...
g = ....f...
- in
+ in
....f...
Here we would like the single call to g to be inlined.
/= a b = unpack tuple a, unpack tuple b, call f
in d.Eq
-here, by knowing about d.Eq in f's rhs, one could get rid of
+here, by knowing about d.Eq in f's rhs, one could get rid of
the case (and break out the recursion completely).
-[This occurred with more aggressive inlining threshold (4),
+[This occurred with more aggressive inlining threshold (4),
nofib/spectral/knights]
-How to do it?
+How to do it?
1: we simplify constructor rhss first.
2: we record the "known constructors" in the environment
3: we simplify the other rhss, with the knowledge about the constructors
\begin{code}
-simplBind env (CoRec pairs) body_c body_ty
+simplBind env (Rec pairs) body_c body_ty
= -- Do floating, if necessary
(if float_lets || always_float_let_from_let
- then
+ then
mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
returnSmpl (concat floated_pairs_s)
else
cloneIds env binders `thenSmpl` \ ids' ->
let
env_w_clones = extendIdEnvWithClones env binders ids'
- triples = ids' `zip` floated_pairs
+ triples = zipEqual "simplBind" ids' floated_pairs
in
simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) ->
body_c new_env `thenSmpl` \ body' ->
- returnSmpl (CoLet binding body')
+ returnSmpl (Let binding body')
where
------------ Floating stuff -------------------
float_pair (binder, rhs)
| always_float_let_from_let ||
floatExposesHNF True False False rhs
- = (binder,rhs') : pairs'
+ = (binder,rhs') : pairs'
| otherwise
= [(binder,rhs)]
- where
+ where
(pairs', rhs') = do_float rhs
-- Float just pulls out any top-level let(rec) bindings
do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
- do_float (CoLet (CoRec pairs) body) = (float_pairs pairs ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
- where
- (pairs', body') = do_float body
+ do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
+ where
+ (pairs', body') = do_float body
+ do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
+ where
+ (pairs', body') = do_float body
do_float other = ([], other)
simplRecursiveGroup env triples
(early_triples, late_triples)
= partition is_early_triple ordinary_triples
- is_early_triple (_, (_, CoCon _ _ _)) = True
- is_early_triple (i, _ ) = idWantsToBeINLINEd i
+ is_early_triple (_, (_, Con _ _)) = True
+ is_early_triple (i, _ ) = idWantsToBeINLINEd i
in
-- Process the early bindings first
mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
-- Now further extend the environment to record our knowledge
-- about the form of the binders bound in the constructor bindings
let
- env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
- add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
+ env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
+ add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
in
-- Now process the non-constructor bindings
mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
-- Phew! We're done
let
- binding = CoRec (map snd early_triples' ++ map snd late_triples')
+ binding = Rec (map snd early_triples' ++ map snd late_triples')
in
returnSmpl (binding, env_w_early_info)
where
- do_one_binding env (id', (binder,rhs))
+ do_one_binding env (id', (binder,rhs))
= simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
returnSmpl (binder, (id', rhs'))
\end{code}
@completeLet@ looks at the simplified post-floating RHS of the
let-expression, and decides what to do. There's one interesting
aspect to this, namely constructor reuse. Consider
-@
+@
f = \x -> case x of
(y:ys) -> y:ys
[] -> ...
a.s3299 :: Int
_N_ {-# U(P) #-}
a.s3299 = I#! upk.s3297#
- } in
+ } in
case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
_LT -> I#! upk.s3298#
_EQ -> a.s3299
variable) when we find a let-expression:
@
let x = C a1 .. an
- in
- ... (let y = C a1 .. an in ...) ...
+ in
+ ... (let y = C a1 .. an in ...) ...
@
where it is always good to ditch the binding for y, and replace y by
x. That's just what completeLetBinding does.
completeLet
:: SimplEnv
-> InBinder
- -> InExpr -- Original RHS
-> OutExpr -- The simplified RHS
-> (SimplEnv -> SmplM OutExpr) -- Body handler
- -> OutUniType -- Type of body
+ -> OutType -- Type of body
-> SmplM OutExpr
-completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
-
+completeLet env binder new_rhs body_c body_ty
-- See if RHS is an atom, or a reusable constructor
| maybeToBool maybe_atomic_rhs
= let
in
tick atom_tick_type `thenSmpl_`
body_c new_env
+ where
+ maybe_atomic_rhs :: Maybe (OutArg, TickType)
+ maybe_atomic_rhs = exprToAtom env new_rhs
+ -- If the RHS is atomic, we return Just (atom, tick type)
+ -- otherwise Nothing
+ Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
+completeLet env binder@(id,_) new_rhs body_c body_ty
-- Maybe the rhs is an application of error, and sure to be demanded
- | will_be_demanded &&
+ | will_be_demanded &&
maybeToBool maybe_error_app
= tick CaseOfError `thenSmpl_`
returnSmpl retyped_error_app
+ where
+ will_be_demanded = willBeDemanded (getIdDemandInfo id)
+ maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
+ Just retyped_error_app = maybe_error_app
+{-
+completeLet env binder (Coerce coercion ty rhs) body_c body_ty
+ -- Rhs is a coercion
+ | maybeToBool maybe_atomic_coerce_rhs
+ = tick tick_type `thenSmpl_`
+ complete_coerce env rhs_atom rhs
+ where
+ maybe_atomic_coerce_rhs = exprToAtom env rhs
+ Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
+
+ returnSmpl (CoerceForm coercion rhs_atom, env)
+ Nothing
+ newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+
+ complete_coerce env atom rhs
+ = cloneId env binder `thenSmpl` \ id' ->
+ let
+ env1 = extendIdEnvWithClone env binder id'
+ new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
+ in
+ body_c new_env `thenSmpl` \ body' ->
+ returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
+-}
+
+completeLet env binder new_rhs body_c body_ty
-- The general case
- | otherwise
= cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
- new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
+ new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
in
body_c new_env `thenSmpl` \ body' ->
- returnSmpl (CoLet (CoNonRec id' new_rhs) body')
-
- where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- try_to_reuse_constr = switchIsSet env SimplReuseCon
-
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
- maybe_atomic_rhs :: Maybe (OutAtom, TickType)
- -- If the RHS is atomic, we return Just (atom, tick type)
- -- otherwise Nothing
-
- maybe_atomic_rhs
- = case new_rhs of
- CoVar var -> Just (CoVarAtom var, AtomicRhs)
-
- CoLit lit | not (isNoRepLit lit)
- -> Just (CoLitAtom lit, AtomicRhs)
-
- CoCon con tys con_args
- | try_to_reuse_constr
- -- Look out for
- -- 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.
- -> case lookForConstructor env con tys con_args of
- Nothing -> Nothing
- Just var -> Just (CoVarAtom var, ConReused)
-
- other -> Nothing
-
- maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
- Just retyped_error_app = maybe_error_app
+ returnSmpl (Let (NonRec id' new_rhs) body')
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-simplAtom :: SimplEnv -> InAtom -> OutAtom
+simplArg :: SimplEnv -> InArg -> OutArg
-simplAtom env (CoLitAtom lit) = CoLitAtom lit
+simplArg env (LitArg lit) = LitArg lit
+simplArg env (TyArg ty) = TyArg (simplTy env ty)
-simplAtom env (CoVarAtom id)
+simplArg env (VarArg id)
| isLocallyDefined id
= case lookupId env id of
Just (ItsAnAtom atom) -> atom
- Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
- Nothing -> CoVarAtom id -- Must be an uncloned thing
+ Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
+ Nothing -> VarArg id -- Must be an uncloned thing
| otherwise
= -- Not locally defined, so no change
- CoVarAtom id
+ VarArg id
\end{code}
+\begin{code}
+exprToAtom env (Var var)
+ = Just (VarArg var, AtomicRhs)
+
+exprToAtom env (Lit lit)
+ | not (isNoRepLit lit)
+ = Just (LitArg lit, AtomicRhs)
+
+exprToAtom env (Con con con_args)
+ | switchIsSet env SimplReuseCon
+ -- Look out for
+ -- 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.
+ = case (lookForConstructor env con con_args) of
+ Nothing -> Nothing
+ Just var -> Just (VarArg var, ConReused)
+
+exprToAtom env other
+ = Nothing
+\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
+fix_up_demandedness True {- Will be demanded -} bind
= bind -- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
- = CoNonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
- = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
+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` noInfo, occ_info)
-is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
-is_cheap_prim_app other = False
+is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
+is_cheap_prim_app other = False
-computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
+computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
computeResultType env expr args
- = do expr_ty' args
+ = go expr_ty' args
where
- expr_ty = typeOfCoreExpr (unTagBinders expr)
+ expr_ty = coreExprType (unTagBinders expr)
expr_ty' = simplTy env expr_ty
- do ty [] = ty
- do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
- do ty (ValArg a : args) = case maybeUnpackFunTy ty of
- Just (_, res_ty) -> do res_ty args
- Nothing -> panic "computeResultType"
+ go ty [] = ty
+ go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
+ go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
+ Just (_, res_ty) -> go res_ty args
+ Nothing -> panic "computeResultType"
\end{code}
projects / ghc-hetmet.git / blobdiff