Commit 6858f7c1 authored by simonpj's avatar simonpj

[project @ 2001-09-26 16:19:28 by simonpj]

------------------
		Simon's big commit
		------------------
	[ These files seem to have been left out for some reason ]


This commit, which I don't think I can sensibly do piecemeal, consists
of the things I've been doing recently, mainly directed at making
Manuel, George, and Marcin happier with RULES.


Reogranise the simplifier
~~~~~~~~~~~~~~~~~~~~~~~~~
1. The simplifier's environment is now an explicit parameter.  This
makes it a bit easier to figure out where it is going.

2. Constructor arguments can now be arbitrary expressions, except
when the application is the RHS of a let(rec).  This makes it much
easier to match rules like

	RULES
	    "foo"  f (h x, g y) = f' x y

In the simplifier, it's Simplify.mkAtomicArgs that ANF-ises a
constructor application where necessary.  In the occurrence analyser,
there's a new piece of context info (OccEncl) to say whether a
constructor app is in a place where it should be in ANF.  (Unless
it knows this it'll give occurrence info which will inline the
argument back into the constructor app.)

3. I'm experimenting with doing the "float-past big lambda" transformation
in the full laziness pass, rather than mixed in with the simplifier (was
tryRhsTyLam).

4.  Arrange that
	case (coerce (S,T) (x,y)) of ...
will simplify.  Previous it didn't.
A local change to CoreUtils.exprIsConApp_maybe.

5. Do a better job in CoreUtils.exprEtaExpandArity when there's an
error function in one branch.


Phase numbers, RULES, and INLINE pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.  Phase numbers decrease from N towards zero (instead of increasing).
This makes it easier to add new earlier phases, which is what users want
to do.

2.  RULES get their own phase number, N, and are disabled in phases before N.

e.g. 	{-# RULES "foo" [2] forall x y.  f (x,y) = f' x y #-}

Note the [2], which says "only active in phase 2 and later".

3.  INLINE and NOINLINE pragmas have a phase number to.  This is now treated
in just the same way as the phase number on RULE; that is, the Id is not inlined
in phases earlier than N.  In phase N and later the Id *may* be inlined, and
here is where INLINE and NOINLINE differ: INLNE makes the RHS look small, so
as soon as it *may* be inlined it probably *will* be inlined.

The syntax of the phase number on an INLINE/NOINLINE pragma has changed to be
like the RULES case (i.e. in square brackets).  This should also make sure
you examine all such phase numbers; many will need to change now the numbering
is reversed.

Inlining Ids is no longer affected at all by whether the Id appears on the
LHS of a rule.  Now it's up to the programmer to put a suitable INLINE/NOINLINE
pragma to stop it being inlined too early.


Implementation notes:

*  A new data type, BasicTypes.Activation says when a rule or inline pragma
is active.   Functions isAlwaysActive, isNeverActive, isActive, do the
obvious thing (all in BasicTypes).

* Slight change in the SimplifierSwitch data type, which led to a lot of
simplifier-specific code moving from CmdLineOpts to SimplMonad; a Good Thing.

* The InlinePragma in the IdInfo of an Id is now simply an Activation saying
when the Id can be inlined.  (It used to be a rather bizarre pair of a
Bool and a (Maybe Phase), so this is much much easier to understand.)

* The simplifier has a "mode" environment switch, replacing the old
black list.  Unfortunately the data type decl has to be in
CmdLineOpts, because it's an argument to the CoreDoSimplify switch

    data SimplifierMode = SimplGently | SimplPhase Int

Here "gently" means "no rules, no inlining".   All the crucial
inlining decisions are now collected together in SimplMonad
(preInlineUnconditionally, postInlineUnconditionally, activeInline,
activeRule).


Specialisation
~~~~~~~~~~~~~~
1.  Only dictionary *functions* are made INLINE, not dictionaries that
have no parameters.  (This inline-dictionary-function thing is Marcin's
idea and I'm still not sure whether it's a good idea.  But it's definitely
a Bad Idea when there are no arguments.)

2.  Be prepared to specialise an INLINE function: an easy fix in
Specialise.lhs

But there is still a problem, which is that the INLINE wins
at the call site, so we don't use the specialised version anyway.
I'm still unsure whether it makes sense to SPECIALISE something
you want to INLINE.





Random smaller things
~~~~~~~~~~~~~~~~~~~~~~

* builtinRules (there was only one, but may be more) in PrelRules are now
  incorporated.   They were being ignored before...

* OrdList.foldOL -->  OrdList.foldrOL, OrdList.foldlOL

* Some tidying up of the tidyOpenTyVar, tidyTyVar functions.  I've
  forgotten exactly what!
parent e0d750be
......@@ -30,7 +30,7 @@ simplNonRecBind: [was simplBeta]
else
completeLazyBind
simplRecPair: [binder already simplified, but not its IdInfo]
simplLazyBind: [binder already simplified, but not its IdInfo]
[used for both rec and top-lvl non-rec]
[must not be strict/unboxed; case not allowed]
- check for PreInlineUnconditionally
......
......@@ -162,6 +162,9 @@ ppr_ds_rules rules
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way
= returnDs (fun, rule)
dsRule in_scope (HsRule name act sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
......
......@@ -782,6 +782,7 @@ data RuleDecl name pat
name -- Head of LHS
CoreRule
isIfaceRuleDecl :: RuleDecl name pat -> Bool
isIfaceRuleDecl (HsRule _ _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
......
......@@ -182,13 +182,17 @@ So we treat lambda in groups, using the following rule:
fiExpr to_drop (_, AnnLam b body)
= case collect [b] body of
(bndrs, real_body)
| all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
-- | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
-- [July 01: I'm experiment with getting the full laziness
-- pass to floats bindings out past big lambdas (instead of the simplifier)
-- so I don't want the float-in pass to just push them right back in.
-- I'm going to try just dumping all bindings outside lambdas.]
| otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
where
collect bs (_, AnnLam b body) = collect (b:bs) body
collect bs body = (reverse bs, body)
is_ok bndr = isTyVar bndr || isOneShotLambda bndr
-- is_ok bndr = isTyVar bndr || isOneShotLambda bndr
\end{code}
We don't float lets inwards past an SCC.
......
......@@ -13,7 +13,7 @@ module FloatOut ( floatOutwards ) where
import CoreSyn
import CoreUtils ( mkSCC )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
......
......@@ -144,12 +144,6 @@ data LibCaseEnv
initEnv :: Int -> LibCaseEnv
initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
pprEnv :: LibCaseEnv -> SDoc
pprEnv (LibCaseEnv _ lvl lvl_env _ scruts)
= vcat [text "LibCaseEnv" <+> int lvl,
fsep (map ppr (ufmToList lvl_env)),
fsep (map ppr scruts)]
bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
\end{code}
......
......@@ -22,7 +22,7 @@ import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo,
isExportedId, modifyIdInfo, idInfo, idArity,
idSpecialisation, isLocalId,
idType, idUnique, Id
)
......@@ -52,29 +52,19 @@ import Outputable
Here's the externally-callable interface:
\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
-> (IdEnv OccInfo, -- Occ info for interesting free vars
CoreExpr)
occurAnalyseExpr interesting expr
= occAnal initial_env expr
where
initial_env = OccEnv interesting emptyVarSet []
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
snd (occurAnalyseExpr (\_ -> False) expr)
snd (occAnal (initOccEnv emptyVarSet) expr)
occurAnalyseRule :: CoreRule -> CoreRule
occurAnalyseRule rule@(BuiltinRule _ _) = rule
occurAnalyseRule (Rule str tpl_vars tpl_args rhs)
occurAnalyseRule (Rule str act tpl_vars tpl_args rhs)
-- Add occ info to tpl_vars, rhs
= Rule str tpl_vars' tpl_args rhs'
= Rule str act tpl_vars' tpl_args rhs'
where
(rhs_uds, rhs') = occurAnalyseExpr isLocalId rhs
(rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs
(_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
......@@ -137,7 +127,7 @@ occurAnalyseBinds :: [CoreBind] -> [CoreBind]
occurAnalyseBinds binds
= binds'
where
(_, _, binds') = go initialTopEnv binds
(_, _, binds') = go (initOccEnv emptyVarSet) binds
go :: OccEnv -> [CoreBind]
-> (UsageDetails, -- Occurrence info
......@@ -173,10 +163,6 @@ occurAnalyseBinds binds
other -> -- Ho ho! The normal case
(final_usage, ind_env, new_binds ++ binds')
initialTopEnv = OccEnv isLocalId -- Anything local is interesting
emptyVarSet
[]
-- Deal with any indirections
zapBind ind_env (NonRec bndr rhs)
......@@ -521,7 +507,7 @@ occAnalRhs :: OccEnv
occAnalRhs env id rhs
= (final_usage, rhs')
where
(rhs_usage, rhs') = occAnal (zapCtxt env) rhs
(rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
......@@ -598,7 +584,7 @@ occAnal env (Note note body)
\begin{code}
occAnal env app@(App fun arg)
= occAnalApp env (collectArgs app)
= occAnalApp env (collectArgs app) False
-- Ignore type variables altogether
-- (a) occurrences inside type lambdas only not marked as InsideLam
......@@ -619,7 +605,7 @@ occAnal env expr@(Lam x body) | isTyVar x
-- Then, the simplifier is careful when partially applying lambdas.
occAnal env expr@(Lam _ _)
= case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
= case occAnal env_body body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagBinders body_usage binders
-- URGH! Sept 99: we don't seem to be able to use binders' here, because
......@@ -634,12 +620,15 @@ occAnal env expr@(Lam _ _)
(really_final_usage,
mkLams tagged_binders body') }
where
(binders, body) = collectBinders expr
(linear, env_body, _) = oneShotGroup env binders
(binders, body) = collectBinders expr
(linear, env1, _) = oneShotGroup env binders
env2 = env1 `addNewCands` binders -- Add in-scope binders
env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') ->
= case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage
......@@ -672,7 +661,7 @@ occAnalArgs env args
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
arg_env = zapCtxt env
arg_env = vanillaCtxt env
\end{code}
Applications are dealt with specially because we want
......@@ -680,7 +669,7 @@ the "build hack" to work.
\begin{code}
-- Hack for build, fold, runST
occAnalApp env (Var fun, args)
occAnalApp env (Var fun, args) is_rhs
= case args_stuff of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
......@@ -695,39 +684,59 @@ occAnalApp env (Var fun, args)
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
| fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
| fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
| isDataConId fun = case occAnalArgs env args of
(arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
-- We mark the free vars of the argument of a constructor as "many"
-- This means that nothing gets inlined into a constructor argument
-- position, which is what we want. Typically those constructor
-- arguments are just variables, or trivial expressions.
| otherwise = occAnalArgs env args
occAnalApp env (fun, args)
= case occAnal (zapCtxt env) fun of { (fun_uds, fun') ->
case occAnalArgs env args of { (args_uds, args') ->
| fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
-- (foldr k z xs) may call k many times, but it never
-- shares a partial application of k; hence [False,True]
-- This means we can optimise
-- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
-- by floating in the v
| isRhsEnv env,
isDataConId fun || valArgCount args < idArity fun
= case occAnalArgs env args of
(arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
-- We mark the free vars of the argument of a constructor or PAP
-- as "many", if it is the RHS of a let(rec).
-- This means that nothing gets inlined into a constructor argument
-- position, which is what we want. Typically those constructor
-- arguments are just variables, or trivial expressions.
| otherwise = occAnalArgs env args
occAnalApp env (fun, args) is_rhs
= case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
-- The addAppCtxt is a bit cunning. One iteration of the simplifier
-- often leaves behind beta redexs like
-- (\x y -> e) a1 a2
-- Here we would like to mark x,y as one-shot, and treat the whole
-- thing much like a let. We do this by pushing some True items
-- onto the context stack.
case occAnalArgs env args of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
in
(final_uds, mkApps fun' args') }}
appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr])
appSpecial :: OccEnv
-> Int -> CtxtTy -- Argument number, and context to use for it
-> [CoreExpr]
-> (UsageDetails, [CoreExpr])
appSpecial env n ctxt args
= go n args
where
arg_env = vanillaCtxt env
go n [] = (emptyDetails, []) -- Too few args
go 1 (arg:args) -- The magic arg
= case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') ->
case occAnalArgs env args of { (args_uds, args') ->
= case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
case occAnalArgs env args of { (args_uds, args') ->
(combineUsageDetails arg_uds args_uds, arg':args') }}
go n (arg:args)
= case occAnal env arg of { (arg_uds, arg') ->
= case occAnal arg_env arg of { (arg_uds, arg') ->
case go (n-1) args of { (args_uds, args') ->
(combineUsageDetails arg_uds args_uds, arg':args') }}
\end{code}
......@@ -735,31 +744,53 @@ appSpecial env n ctxt args
Case alternatives
~~~~~~~~~~~~~~~~~
If the case binder occurs at all, the other binders effectively do too.
For example
case e of x { (a,b) -> rhs }
is rather like
let x = (a,b) in rhs
If e turns out to be (e1,e2) we indeed get something like
let a = e1; b = e2; x = (a,b) in rhs
\begin{code}
occAnalAlt env (con, bndrs, rhs)
occAnalAlt env case_bndr (con, bndrs, rhs)
= case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
let
(final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
| otherwise = tagged_bndrs
-- Leave the binders untagged if the case
-- binder occurs at all; see note above
in
(final_usage, (con, tagged_bndrs, rhs')) }
(final_usage, (con, final_bndrs, rhs')) }
\end{code}
%************************************************************************
%* *
\subsection[OccurAnal-types]{Data types}
\subsection[OccurAnal-types]{OccEnv}
%* *
%************************************************************************
\begin{code}
-- We gather inforamtion for variables that are either
-- (a) in scope or
-- (b) interesting
data OccEnv =
OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting,
IdSet -- In-scope Ids
CtxtTy -- Tells about linearity
data OccEnv
= OccEnv IdSet -- In-scope Ids; we gather info about these only
OccEncl -- Enclosing context information
CtxtTy -- Tells about linearity
-- OccEncl is used to control whether to inline into constructor arguments
-- For example:
-- x = (p,q) -- Don't inline p or q
-- y = /\a -> (p a, q a) -- Still don't inline p or q
-- z = f (p,q) -- Do inline p,q; it may make a rule fire
-- So OccEncl tells enought about the context to know what to do when
-- we encounter a contructor application or PAP.
data OccEncl
= OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
-- Don't inline into constructor args here
| OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
-- Do inline into constructor args here
type CtxtTy = [Bool]
-- [] No info
......@@ -771,19 +802,25 @@ type CtxtTy = [Bool]
-- be applied many times; but when it is,
-- the CtxtTy inside applies
initOccEnv :: VarSet -> OccEnv
initOccEnv vars = OccEnv vars OccRhs []
isRhsEnv (OccEnv _ OccRhs _) = True
isRhsEnv (OccEnv _ OccVanilla _) = False
isCandidate :: OccEnv -> Id -> Bool
isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id
isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands
addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv ifun cands ctxt) ids
= OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt
addNewCands (OccEnv cands encl ctxt) ids
= OccEnv (cands `unionVarSet` mkVarSet ids) encl ctxt
addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv ifun cands ctxt) id
= OccEnv ifun (extendVarSet cands id) ctxt
addNewCand (OccEnv cands encl ctxt) id
= OccEnv (extendVarSet cands id) encl ctxt
setCtxt :: OccEnv -> CtxtTy -> OccEnv
setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
setCtxt (OccEnv cands encl _) ctxt = OccEnv cands encl ctxt
oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
-- True <=> this is a one-shot linear lambda group
......@@ -794,9 +831,9 @@ oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
-- linearity context knows that c,n are one-shot, and it records that fact in
-- the binder. This is useful to guide subsequent float-in/float-out tranformations
oneShotGroup (OccEnv ifun cands ctxt) bndrs
oneShotGroup (OccEnv cands encl ctxt) bndrs
= case go ctxt bndrs [] of
(new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs)
(new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
where
is_one_shot b = isId b && isOneShotLambda b
......@@ -811,9 +848,20 @@ oneShotGroup (OccEnv ifun cands ctxt) bndrs
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
zapCtxt env@(OccEnv ifun cands []) = env
zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
vanillaCtxt (OccEnv cands _ _) = OccEnv cands OccVanilla []
rhsCtxt (OccEnv cands _ _) = OccEnv cands OccRhs []
addAppCtxt (OccEnv cands encl ctxt) args
= OccEnv cands encl (replicate (valArgCount args) True ++ ctxt)
\end{code}
%************************************************************************
%* *
\subsection[OccurAnal-types]{OccEnv}
%* *
%************************************************************************
\begin{code}
type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
combineUsageDetails, combineAltsUsageDetails
......
......@@ -443,7 +443,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
(mkVarApps (Var new_bndr) lam_bndrs))],
poly_env)
| otherwise
| otherwise -- Non-null abs_vars
= newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
......@@ -510,25 +510,6 @@ lvlLamBndrs lvl bndrs
\end{code}
\begin{code}
abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-- Find the variables in fvs, free vars of the target expresion,
-- whose level is less than than the supplied level
-- These are the ones we are going to abstract out
abstractVars dest_lvl env fvs
= uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
where
-- Sort the variables so we don't get
-- mixed-up tyvars and Ids; it's just messy
v1 `lt` v2 = case (isId v1, isId v2) of
(True, False) -> False
(False, True) -> True
other -> v1 < v2 -- Same family
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
| otherwise = v1 : uniq (v2:vs)
uniq vs = vs
-- Destintion level is the max Id level of the expression
-- (We'll abstract the type variables, if any.)
destLevel :: LevelEnv -> VarSet -> Bool -> Level
......@@ -674,13 +655,33 @@ lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
Just (_, expr) -> expr
other -> Var v
abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-- Find the variables in fvs, free vars of the target expresion,
-- whose level is greater than the destination level
-- These are the ones we are going to abstract out
abstractVars dest_lvl env fvs
= uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
where
-- Sort the variables so we don't get
-- mixed-up tyvars and Ids; it's just messy
v1 `lt` v2 = case (isId v1, isId v2) of
(True, False) -> False
(False, True) -> True
other -> v1 < v2 -- Same family
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
| otherwise = v1 : uniq (v2:vs)
uniq vs = vs
absVarsOf :: Level -> LevelEnv -> Var -> [Var]
-- If f is free in the exression, and f maps to poly_f a b c in the
-- If f is free in the expression, and f maps to poly_f a b c in the
-- current substitution, then we must report a b c as candidate type
-- variables
absVarsOf dest_lvl (_, lvl_env, _, id_env) v
| isId v
= [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av]
= [zap av2 | av1 <- lookup_avs v, av2 <- add_tyvars av1, abstract_me av2]
| otherwise
= if abstract_me v then [v] else []
......@@ -694,15 +695,16 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v
Just (abs_vars, _) -> abs_vars
Nothing -> [v]
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id
add_tyvars v | isId v = zap v : varSetElems (idFreeTyVars v)
add_tyvars v | isId v = v : varSetElems (idFreeTyVars v)
| otherwise = [v]
zap v = WARN( workerExists (idWorkerInfo v)
|| not (isEmptyCoreRules (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
not (isEmptyCoreRules (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
\end{code}
\begin{code}
......
......@@ -8,8 +8,7 @@ module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
SwitchResult(..), intSwitchSet,
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..),
DynFlags, DynFlag(..), dopt, dopt_CoreToDo
)
import CoreSyn
......@@ -22,7 +21,6 @@ import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
ruleCheckProgram )
import Module ( moduleEnvElts )
import CoreUnfold
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
......@@ -33,7 +31,7 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( idName, isDataConWrapId, setIdLocalExported, isImplicitId )
import Id ( idName, setIdLocalExported, isImplicitId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
......@@ -111,17 +109,14 @@ simplifyExpr dflags pcs hst expr
; us <- mkSplitUniqSupply 's'
; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_nothing
(simplExprGently expr)
; let env = emptySimplEnv (SimplPhase 0) [] emptyVarSet
(expr', _counts) = initSmpl dflags us (simplExprGently env expr)
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
where
sw_chkr any = SwBool False -- A bit bogus
black_list_nothing v = False -- Black list nothing
doCorePasses :: DynFlags
......@@ -143,8 +138,8 @@ doCorePasses dflags rb stats us binds (to_do : to_dos)
doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
= _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
doCorePass dfs rb us binds (CoreDoSimplify mode switches)
= _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
doCorePass dfs rb us binds CoreCSE
= _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
doCorePass dfs rb us binds CoreLiberateCase
......@@ -172,8 +167,8 @@ doCorePass dfs rb us binds CoreDoUSPInf
= _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
doCorePass dfs rb us binds CoreDoGlomBinds
= noStats dfs (glomBinds dfs binds)
doCorePass dfs rb us binds (CoreDoRuleCheck pat)
= noStats dfs (ruleCheck dfs pat binds)
doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
= noStats dfs (ruleCheck dfs phase pat binds)
doCorePass dfs rb us binds CoreDoNothing
= noStats dfs (return binds)
......@@ -181,9 +176,9 @@ printCore binds = do dumpIfSet True "Print Core"
(pprCoreBindings binds)
return binds
ruleCheck dflags pat binds = do showPass dflags "RuleCheck"
printDump (ruleCheckProgram pat binds)
return binds
ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
printDump (ruleCheckProgram phase pat binds)
return binds
-- most passes return no stats and don't change rules
noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
......@@ -217,8 +212,8 @@ prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
IdSet) -- RHS free vars of all rules
prepareRules dflags pkg_rule_base hst us binds local_rules
= do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
(mapSmpl simplRule local_rules)
= do { let env = emptySimplEnv SimplGently [] local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
-- We use (`elemVarSet` local_ids) rather than isLocalId because
......@@ -247,11 +242,6 @@ prepareRules dflags pkg_rule_base hst us binds local_rules
; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
sw_chkr any = SwBool False -- A bit bogus
black_list_all v = not (isDataConWrapId v)
-- This stops all inlining except the
-- wrappers for data constructors
add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-- Boringly, we need to gather the in-scope set.
......@@ -312,13 +302,13 @@ which without simplification looked like:
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
simplRule rule@(id, BuiltinRule _ _)
simplRule env rule@(id, BuiltinRule _ _)
= returnSmpl rule
simplRule rule@(id, Rule name bndrs args rhs)
= simplBinders bndrs $ \ bndrs' ->
mapSmpl simplExprGently args `thenSmpl` \ args' ->
simplExprGently rhs `thenSmpl` \ rhs' ->
returnSmpl (id, Rule name bndrs' args' rhs')
simplRule env rule@(id, Rule act name bndrs args rhs)
= simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
simplExprGently env rhs `thenSmpl` \ rhs' ->
returnSmpl (id, Rule act name bndrs' args' rhs')
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
......@@ -333,16 +323,16 @@ simplRule rule@(id, Rule name bndrs args rhs)
\end{code}
\begin{code}
simplExprGently :: CoreExpr -> SimplM CoreExpr
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-- Simplifies an expression
-- does occurrence analysis, then simplification
-- and repeats (twice currently) because one pass
-- alone leaves tons of crud.
-- Used (a) for user expressions typed in at the interactive prompt
-- (b) the LHS and RHS of a RULE
simplExprGently expr
= simplExpr (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
simplExpr (occurAnalyseGlobalExpr expr1)
simplExprGently env expr
= simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
simplExpr env (occurAnalyseGlobalExpr expr1)
\end{code}
......@@ -397,13 +387,14 @@ glomBinds dflags binds
\begin{code}
simplifyPgm :: DynFlags
-> RuleBase
-> (SimplifierSwitch -> SwitchResult)
-> SimplifierMode
-> [SimplifierSwitch]
-> UniqSupply
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind]) -- New bindings
simplifyPgm dflags rule_base
sw_chkr us binds
mode switches us binds
= do {
showPass dflags "Simplify";
......@@ -422,10 +413,14 @@ simplifyPgm dflags rule_base
return (counts_out, binds')
}
where
max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
phase_info = case mode of
SimplGently -> "gentle"
SimplPhase n -> show n