Commit 4e6d5798 authored by simonpj's avatar simonpj

[project @ 2000-09-07 16:32:23 by simonpj]

A list of simplifier-related stuff, triggered
	by looking at GHC's performance.

	I don't guarantee that this lot will lead to
	a uniform improvement over 4.08, but it it should
	be a bit better.  More work probably required.


* Make the simplifier's Stop continuation record whether the expression being
  simplified is the RHS of a thunk, or (say) the body of a lambda or case RHS.
  In the thunk case we want to be a bit keener about inlining if the type of
  the thunk is amenable to update in place.

* Fix interestingArg, which was being too liberal, and hence doing
  too much inlining.

* Extended CoreUtils.exprIsCheap to make two more things cheap:
    - 	case (coerce x) of ...
    -   let x = y +# z
  This makes a bit more eta expansion happen.  It was provoked by
  a program of Marcin's.

* MkIface.ifaceBinds.   Make sure that we emit rules for things
  (like class operations) that don't get a top-level binding in the
  interface file.  Previously such rules were silently forgotten.

* Move transformRhs to *after* simplification, which makes it a
  little easier to do, and means that the arity it computes is
  readily available to completeBinding.  This gets much better
  arities.

* Do coerce splitting in completeBinding. This gets good code for
	newtype CInt = CInt Int

	test:: CInt -> Int
	test x = case x of
	      	   1 -> 2
	      	   2 -> 4
	      	   3 -> 8
	      	   4 -> 16
	      	   _ -> 0

* Modify the meaning of "arity" so that during compilation it means
  "if you apply this function to fewer args, it will do virtually
  no work".   So, for example
	f = coerce t (\x -> e)
  has arity at least 1.  When a function is exported, it's arity becomes
  the number of exposed, top-level lambdas, which is subtly different.
  But that's ok.

  I removed CoreUtils.exprArity altogether: it looked only at the exposed
  lambdas.  Instead, we use exprEtaExpandArity exclusively.

  All of this makes I/O programs work much better.
parent e9f0fa88
......@@ -27,16 +27,16 @@ module Id (
externallyVisibleId,
idFreeTyVars,
isIP,
-- Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
isSpecPragmaId, isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
isExportedId, isUserExportedId,
mayHaveNoBinding,
hasNoBinding,
-- Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
-- One shot lambda stuff
isOneShotLambda, setOneShotLambda, clearOneShotLambda,
......@@ -237,16 +237,13 @@ isSpecPragmaId id = case idFlavour id of
SpecPragmaId -> True
other -> False
mayHaveNoBinding id = case idFlavour id of
hasNoBinding id = case idFlavour id of
DataConId _ -> True
PrimOpId _ -> True
other -> False
-- mayHaveNoBinding returns True of an Id which may not have a
-- hasNoBinding returns True of an Id which may not have a
-- binding, even though it is defined in this module. Notably,
-- the constructors of a dictionary are in this situation.
--
-- mayHaveNoBinding returns True of some things that *do* have a local binding,
-- so it's only an approximation. That's ok... it's only use for assertions.
-- Don't drop a binding for an exported Id,
-- if it otherwise looks dead.
......@@ -294,9 +291,7 @@ exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id
\begin{code}
isDeadBinder :: Id -> Bool
isDeadBinder bndr | isId bndr = case idOccInfo bndr of
IAmDead -> True
other -> False
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False -- TyVars count as not dead
isIP id = isIPOcc (getOccName id)
......
......@@ -18,7 +18,7 @@ module CoreFVs (
#include "HsVersions.h"
import CoreSyn
import Id ( Id, idFreeTyVars, mayHaveNoBinding, idSpecialisation )
import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation )
import VarSet
import Var ( Var, isId )
import Name ( isLocallyDefined )
......@@ -37,7 +37,7 @@ import Outputable
mustHaveLocalBinding :: Var -> Bool
-- True <=> the variable must have a binding in this module
mustHaveLocalBinding v
| isId v = isLocallyDefined v && not (mayHaveNoBinding v)
| isId v = isLocallyDefined v && not (hasNoBinding v)
| otherwise = True -- TyVars etc must
\end{code}
......
......@@ -214,7 +214,18 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
size_up (Case (Var v) _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
= case alts of
=
{- I'm nuking this special case; BUT see the comment with case alternatives.
(a) It's too eager. We don't want to inline a wrapper into a
context with no benefit.
E.g. \ x. f (x+x) o point in inlining (+) here!
(b) It's ineffective. Once g's wrapper is inlined, its case-expressions
aren't scrutinising arguments any more
case alts of
[alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
-- We want to make wrapper-style evaluation look cheap, so that
-- when we inline a wrapper it doesn't make call site (much) bigger
......@@ -227,7 +238,9 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
-- ordering difference, we make (case a of (x,y) -> ...),
-- *where a is one of the arguments* look free.
other -> alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee
other ->
-}
alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee
(foldr1 maxSize alt_sizes)
-- Good to inline if an arg is scrutinised, because
......@@ -301,7 +314,8 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
------------
size_up_alt (con, bndrs, rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
------------
-- We want to record if we're case'ing, or applying, an argument
......@@ -602,7 +616,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
#ifdef DEBUG
if opt_D_dump_inlinings then
pprTrace "Considering inlining"
(ppr id <+> vcat [text "black listed" <+> ppr black_listed,
(ppr id <+> vcat [text "black listed:" <+> ppr black_listed,
text "occ info:" <+> ppr occ,
text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr interesting_cont,
......@@ -700,8 +714,8 @@ normal_case rule_vars phase v
| from_INLINE -> has_rules -- Black list until final phase
| otherwise -> True -- Always blacklisted
IMustNotBeINLINEd from_inline (Just threshold)
| from_inline -> (phase < threshold && has_rules)
IMustNotBeINLINEd from_INLINE (Just threshold)
| from_INLINE -> (phase < threshold && has_rules)
| otherwise -> (phase < threshold || has_rules)
where
has_rules = v `elemVarSet` rule_vars
......
......@@ -11,7 +11,7 @@ module CoreUtils (
mkPiType,
-- Properties of expressions
exprType, coreAltsType, exprArity,
exprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe,
......@@ -300,19 +300,16 @@ shared. The main examples of things which aren't WHNF but are
* case e of
pi -> ei
(where e, and all the ei are cheap)
where e, and all the ei are cheap; and
* let x = e
in b
where e and b are cheap; and
* let x = e in b
(where e and b are cheap)
* op x1 ... xn
where op is a cheap primitive operator
(where op is a cheap primitive operator)
* error "foo"
(because we are happy to substitute it inside a lambda)
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.
......@@ -324,10 +321,18 @@ exprIsCheap (Type _) = True
exprIsCheap (Var _) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
exprIsCheap (Case e _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- This improves arities of overloaded functions where
-- there is only dictionary selection (no construction) involved
exprIsCheap (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e
| otherwise = False
-- strict lets always have cheap right hand sides, and
-- do no allocation.
exprIsCheap other_expr
= go other_expr 0 True
where
......@@ -337,9 +342,8 @@ exprIsCheap other_expr
|| idAppIsBottom f n_args
-- Application of a function which
-- always gives bottom; we treat this as
-- a WHNF, because it certainly doesn't
-- need to be shared!
-- always gives bottom; we treat this as cheap
-- because it certainly doesn't need to be shared!
go (App f a) n_args args_cheap
| isTypeArg a = go f n_args args_cheap
......@@ -475,25 +479,6 @@ idAppIsValue id n_val_args
-- then we could get an infinite loop...
\end{code}
\begin{code}
exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
exprArity (Lam b e) | isTyVar b = exprArity e
| otherwise = 1 + exprArity e
exprArity (Note note e) | ok_note note = exprArity e
where
ok_note (Coerce _ _) = True
-- We *do* look through coerces when getting arities.
-- Reason: arities are to do with *representation* and
-- work duplication.
ok_note InlineMe = True
ok_note InlineCall = True
ok_note other = False
-- SCC and TermUsg might be over-conservative?
exprArity other = 0
\end{code}
\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
exprIsConApp_maybe expr
......
......@@ -24,7 +24,7 @@ import RnMonad
import TcInstUtil ( InstInfo(..) )
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
idSpecialisation
)
import Var ( isId )
......@@ -68,6 +68,7 @@ import Bag
import Outputable
import Maybe ( isNothing )
import List ( partition )
import Monad ( when )
\end{code}
......@@ -322,6 +323,7 @@ completeIface new_iface local_tycons local_classes
all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
(inst_dcls, inst_ids) = ifaceInstances inst_info
cls_dcls = map ifaceClass local_classes
ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
(val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
......@@ -358,7 +360,10 @@ ifaceRules rules emitted
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
-- from coming out, and to make it work properly we need to add
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- Spit out a rule only if all its lhs free vars are emitted
-- This is a good reason not to do it when we emit the Id itself
]
......@@ -489,6 +494,11 @@ ifaceBinds needed_ids final_ids binds
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
go needed [] decls emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
......@@ -496,18 +506,24 @@ ifaceBinds needed_ids final_ids binds
| otherwise = (decls, emitted)
go needed (NonRec id rhs : binds) decls emitted
= case ifaceId get_idinfo needed False id rhs of
Nothing -> go needed binds decls emitted
Just (decl, extras) -> let
needed' = (needed `unionVarSet` extras) `delVarSet` id
-- 'extras' can include the Id itself via a rule
emitted' = emitted `extendVarSet` id
in
go needed' binds (decl `consBag` decls) emitted'
| need_id needed id
= if omitIfaceSigForId id then
go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
else
go ((needed `unionVarSet` extras) `delVarSet` id)
binds
(decl `consBag` decls)
(emitted `extendVarSet` id)
| otherwise
= go needed binds decls emitted
where
(decl, extras) = ifaceId get_idinfo False id rhs
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
-- have to look for a fixed point.
-- have to look for a fixed point. We don't want necessarily them all,
-- because without -O we may only need the first one (if we don't emit
-- its unfolding)
go needed (Rec pairs : binds) decls emitted
= go needed' binds decls' emitted'
where
......@@ -519,42 +535,29 @@ ifaceBinds needed_ids final_ids binds
go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
go_rec needed pairs
| null decls = (emptyBag, emptyVarSet, emptyVarSet)
| otherwise = (more_decls `unionBags` listToBag decls,
more_emitted `unionVarSet` mkVarSet emitted,
more_extras `unionVarSet` extras)
| otherwise = (more_decls `unionBags` listToBag decls,
more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
more_extras `unionVarSet` extras)
where
maybes = map do_one pairs
emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
(decls, extras_s) = unzip (catMaybes maybes)
extras = unionVarSets extras_s
(more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs
do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
(needed_prs,leftover_prs) = partition is_needed pairs
(decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
| (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
extras = unionVarSets extras_s
(more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
is_needed (id,_) = need_id needed id
\end{code}
\begin{code}
ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
-- by the STG passes. Sigh
-> IdSet -- Set of Ids that are needed by earlier interface
-- file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo needed_ids is_rec id rhs
| not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
(isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
= Nothing -- Well, that was easy!
-> (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo needed_ids is_rec id rhs
= ASSERT2( arity_matches_strictness, ppr id )
Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),
new_needed_ids)
ifaceId get_idinfo is_rec id rhs
= (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), new_needed_ids)
where
id_type = idType id
core_idinfo = idInfo id
......@@ -565,7 +568,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
arity_info = arityInfo stg_idinfo
arity_info = arityInfo stg_idinfo
stg_arity = arityLowerBound arity_info
arity_hsinfo = case arityInfo stg_idinfo of
a@(ArityExactly n) -> [HsArity a]
other -> []
......@@ -589,11 +593,40 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ Worker --------------
work_info = workerInfo core_idinfo
has_worker = workerExists work_info
wrkr_hsinfo = case work_info of
HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
other -> []
-- We only treat a function as having a worker if
-- the exported arity (which is now the number of visible lambdas)
-- is the same as the arity at the moment of the w/w split
-- If so, we can safely omit the unfolding inside the wrapper, and
-- instead re-generate it from the type/arity/strictness info
-- But if the arity has changed, we just take the simple path and
-- put the unfolding into the interface file, forgetting the fact
-- that it's a wrapper.
--
-- How can this happen? Sometimes we get
-- f = coerce t (\x y -> $wf x y)
-- at the moment of w/w split; but the eta reducer turns it into
-- f = coerce t $wf
-- which is perfectly fine except that the exposed arity so far as
-- the code generator is concerned (zero) differs from the arity
-- when we did the split (2).
--
-- All this arises because we use 'arity' to mean "exactly how many
-- top level lambdas are there" in interface files; but during the
-- compilation of this module it means "how many things can I apply
-- this to".
work_info = workerInfo core_idinfo
HasWorker work_id _ = work_info
has_worker = case work_info of
HasWorker work_id wrap_arity
| wrap_arity == stg_arity -> True
| otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
False
other -> False
wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
| otherwise = []
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
......@@ -623,11 +656,10 @@ ifaceId get_idinfo needed_ids is_rec id rhs
unfold_ids `unionVarSet`
spec_ids
worker_ids = case work_info of
HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
other -> emptyVarSet
| otherwise = emptyVarSet
spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
......@@ -644,7 +676,6 @@ ifaceId get_idinfo needed_ids is_rec id rhs
HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
other -> True
interestingId id = isId id && isLocallyDefined id &&
not (omitIfaceSigForId id)
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
\end{code}
......@@ -87,20 +87,20 @@ occurAnalyseRule (Rule str tpl_vars tpl_args rhs)
In @occAnalTop@ we do indirection-shorting. That is, if we have this:
loc = <expression>
x_local = <expression>
...
exp = loc
x_exported = loc
where exp is exported, and loc is not, then we replace it with this:
loc = exp
exp = <expression>
x_local = x_exported
x_exported = <expression>
...
Without this we never get rid of the exp = loc thing. This save a
gratuitous jump (from \tr{x_exported} to \tr{x_local}), and makes
strictness information propagate better. This used to happen in the
final phase, but it's tidier to do it here.
Without this we never get rid of the x_exported = x_local thing. This
save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
makes strictness information propagate better. This used to happen in
the final phase, but it's tidier to do it here.
If more than one exported thing is equal to a local thing (i.e., the
local thing really is shared), then we do one only:
......@@ -171,7 +171,7 @@ occurAnalyseBinds binds
ind_env' = extendVarEnv ind_env local_id exported_id
other -> -- Ho ho! The normal case
(final_usage, ind_env, new_binds ++ binds')
(final_usage, ind_env, new_binds ++ binds')
initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting
emptyVarSet
......
......@@ -133,9 +133,6 @@ ltLvl (Level maj1 min1) (Level maj2 min2)
ltMajLvl :: Level -> Level -> Bool
-- Tells if one level belongs to a difft *lambda* level to another
-- But it returns True regardless if l1 is the top level
-- We always like to float to the top!
ltMajLvl (Level 0 0) _ = True
ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
......@@ -144,6 +141,9 @@ isTopLvl other = False
instance Outputable Level where
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
instance Eq Level where
(Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2
\end{code}
%************************************************************************
......@@ -226,8 +226,8 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg)
-- but we do if the function is big and hairy, like a case
lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
-- Don't float anything out of an InlineMe
= lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' ->
-- Don't float anything out of an InlineMe; hence the tOP_LEVEL
= lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' ->
returnLvl (Note InlineMe expr')
lvlExpr ctxt_lvl env (_, AnnNote note expr)
......@@ -305,6 +305,8 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
|| not good_destination
|| exprIsTrivial expr -- Is trivial
|| (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom
-- e.g. \x -> error "foo"
-- No gain from floating this
= -- Don't float it out
lvlExpr ctxt_lvl env ann_expr
......@@ -734,11 +736,9 @@ subst_id_info (_, _, subst, _) ctxt_lvl dest_lvl v
-- VERY IMPORTANT: we must zap the demand info
-- if the thing is going to float out past a lambda
zap_dmd info
| float_past_lam && isStrict (demandInfo info)
= setDemandInfo info wwLazy
| otherwise
= info
| stays_put || not (isStrict (demandInfo info)) = info
| otherwise = setDemandInfo info wwLazy
float_past_lam = ctxt_lvl `ltMajLvl` dest_lvl
stays_put = ctxt_lvl == dest_lvl
\end{code}
......@@ -39,14 +39,19 @@ module SimplMonad (
getSubstEnv, extendSubst, extendSubstList,
getInScope, setInScope, modifyInScope, addNewInScopeIds,
setSubstEnv, zapSubstEnv,
getSimplBinderStuff, setSimplBinderStuff
getSimplBinderStuff, setSimplBinderStuff,
-- Adding bindings
addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
addCaseBind, needsCaseBinding, addNonRecBind
) where
#include "HsVersions.h"
import Id ( Id, mkSysLocal, idUnfolding, isDataConWrapId )
import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId )
import CoreSyn
import CoreUnfold ( isCompulsoryUnfolding )
import CoreUtils ( exprOkForSpeculation )
import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
import Name ( isLocallyDefined )
......@@ -57,7 +62,7 @@ import qualified Subst
import Subst ( Subst, mkSubst, substEnv,
InScopeSet, mkInScopeSet, substInScope, isInScope
)
import Type ( Type )
import Type ( Type, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
......@@ -106,6 +111,45 @@ type OutStuff a = ([OutBind], a)
-- incrementally. Comments just before simplExprB in Simplify.lhs
\end{code}
\begin{code}
addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
addLetBind bind thing_inside
= thing_inside `thenSmpl` \ (binds, res) ->
returnSmpl (bind : binds, res)
addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
addLetBinds binds1 thing_inside
= thing_inside `thenSmpl` \ (binds2, res) ->
returnSmpl (binds1 ++ binds2, res)
addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-- Extends the in-scope environment as well as wrapping the bindings
addAuxiliaryBinds binds1 thing_inside
= addNewInScopeIds (bindersOfBinds binds1) $
addLetBinds binds1 thing_inside
addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-- Extends the in-scope environment as well as wrapping the bindings
addAuxiliaryBind bind thing_inside
= addNewInScopeIds (bindersOf bind) $
addLetBind bind thing_inside
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
-- These can arise either from the desugarer,
-- or from beta reductions: (\x.e) (x +# y)
addCaseBind bndr rhs thing_inside
= getInScope `thenSmpl` \ in_scope ->
thing_inside `thenSmpl` \ (floats, (_, body)) ->
returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)]))
addNonRecBind bndr rhs thing_inside
-- Checks for needing a case binding
| needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
| otherwise = addLetBind (NonRec bndr rhs) thing_inside
\end{code}
%************************************************************************
%* *
......
......@@ -11,7 +11,7 @@ module SimplUtils (
-- The continuation type
SimplCont(..), DupFlag(..), contIsDupable, contResultType,
countValArgs, countArgs,
countValArgs, countArgs, mkRhsStop, mkStop,
getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
) where
......@@ -44,6 +44,7 @@ import DataCon ( dataConRepArity )
import VarSet
import VarEnv ( SubstEnv, SubstResult(..) )
import Util ( lengthExceeds )
import BasicTypes ( Arity )
import Outputable
\end{code}
......@@ -56,7 +57,10 @@ import Outputable
\begin{code}
data SimplCont -- Strict contexts
= Stop OutType -- Type of the result
= Stop OutType -- Type of the result
Bool -- True => This is the RHS of a thunk whose type suggests
-- that update-in-place would be possible
-- (This makes the inliner a little keener.)
| CoerceIt OutType -- The To-type, simplified
SimplCont
......@@ -83,7 +87,7 @@ data SimplCont -- Strict contexts
-- The result expression in the OutExprStuff has type cont_ty
instance Outputable SimplCont where
ppr (Stop _) = ptext SLIT("Stop")
ppr (Stop _ _) = ptext SLIT("Stop")
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
......@@ -97,9 +101,16 @@ instance Outputable DupFlag where
ppr OkToDup = ptext SLIT("ok")
ppr NoDup = ptext SLIT("nodup")
-------------------
mkRhsStop, mkStop :: OutType -> SimplCont
mkStop ty = Stop ty False
mkRhsStop ty = Stop ty (canUpdateInPlace ty)
-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop _) = True
contIsDupable (Stop _ _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (ArgOf OkToDup _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
......@@ -115,21 +126,22 @@ discardInline cont = cont
-------------------
discardableCont :: SimplCont -> Bool
discardableCont (Stop _) = False
discardableCont (Stop _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
discardableCont (InlinePlease cont) = discardableCont cont
discardableCont other = True
discardCont :: SimplCont -- A continuation, expecting
-> SimplCont -- Replace the continuation with a suitable coerce
discardCont (Stop to_ty) = Stop to_ty
discardCont cont = CoerceIt to_ty (Stop to_ty)
where
to_ty = contResultType cont
discardCont cont = case cont of
Stop to_ty _ -> cont
other -> CoerceIt to_ty (mkStop to_ty)
where
to_ty = contResultType cont