\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult, switchIsOn,
- opt_D_dump_occur_anal,
- opt_D_dump_simpl_iterations,
- opt_D_simplifier_stats,
- opt_D_dump_simpl,
- opt_D_verbose_core2core,
- opt_D_dump_occur_anal
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SimplifierMode(..), DynFlags, DynFlag(..), dopt,
+ dopt_CoreToDo, buildCoreToDo
)
-import CoreLint ( beginPass, endPass )
import CoreSyn
-import PprCore ( pprCoreBindings )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( exprIsTrivial, coreExprType )
-import Simplify ( simplBind )
-import SimplUtils ( etaCoreExpr, findDefault )
+import TcIface ( loadImportedRules )
+import HscTypes ( HscEnv(..), ModGuts(..), ModGuts,
+ ModDetails(..), HomeModInfo(..) )
+import CSE ( cseProgram )
+import Rules ( RuleBase, ruleBaseIds,
+ extendRuleBaseList, pprRuleBase, getLocalRules,
+ ruleCheckProgram )
+import Module ( moduleEnvElts )
+import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
+import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
+import CoreUtils ( coreBindsSize )
+import Simplify ( simplTopBinds, simplExpr )
+import SimplUtils ( simplBinders )
import SimplMonad
-import CoreUnfold
-import Const ( Con(..), Literal(..), literalType, mkMachInt )
-import ErrUtils ( dumpIfSet )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
+import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkUserId, isBottomingId,
- idType, setIdType, idName, idInfo, idDetails
- )
-import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
- inlinePragInfo, setInlinePragInfo,
- setUnfoldingInfo
- )
-import VarEnv
+import Id ( idIsFrom, idSpecialisation, setIdSpecialisation )
import VarSet
-import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
- Module, NamedThing(..), OccName
- )
-import TyCon ( TyCon, isDataTyCon )
-import PrimOp ( PrimOp(..) )
-import PrelInfo ( unpackCStringId, unpackCString2Id,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId,
- int2IntegerId, addr2IntegerId
- )
-import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType, mkTyVarTy,
- tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
- Type
- )
-import Class ( Class, classSelIds )
-import TysWiredIn ( isIntegerTy )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
-import SpecEnv ( specEnvToList, specEnvFromList )
-import StrictAnal ( saWwTopBinds )
-import Var ( TyVar, mkId )
-import Unique ( Unique, Uniquable(..),
- ratioTyConKey, mkUnique, incrUnique, initTidyUniques
- )
-import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
-import Util ( mapAccumL )
-import Bag
-import Maybes
+import SpecConstr ( specConstrProgram)
+import DmdAnal ( dmdAnalPgm )
+import WorkWrap ( wwTopBinds )
+#ifdef OLD_STRICTNESS
+import StrictAnal ( saBinds )
+import CprAnalyse ( cprAnalyse )
+#endif
+
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
import Outputable
-\end{code}
-
-\begin{code}
-core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> Module -- Module name (profiling only)
- -> [Class] -- Local classes
- -> UniqSupply -- A name supply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- Result
-
-core2core core_todos module_name classes us binds
- = do
- let (us1, us2) = splitUniqSupply us
-
- -- Do the main business
- processed_binds <- doCorePasses us1 binds core_todos
-
- -- Do the post-simplification business
- post_simpl_binds <- doPostSimplification us2 processed_binds
-
- -- Do the final tidy-up
- final_binds <- tidyCorePgm module_name classes post_simpl_binds
-
- -- Return results
- return final_binds
-
-doCorePasses us binds []
- = return binds
-doCorePasses us binds (to_do : to_dos)
- = do
- let (us1, us2) = splitUniqSupply us
- binds1 <- doCorePass us1 binds to_do
- doCorePasses us2 binds1 to_dos
-
-doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds
-doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds
-doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
-doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
-doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
-doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saWwTopBinds us binds
-doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
+import Maybes ( orElse )
\end{code}
-
%************************************************************************
%* *
\subsection{The driver for the simplifier}
%************************************************************************
\begin{code}
-simplifyPgm :: (SimplifierSwitch -> SwitchResult)
- -> UniqSupply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- New bindings
+core2core :: HscEnv
+ -> ModGuts
+ -> IO ModGuts
-simplifyPgm sw_chkr us binds
- = do {
- beginPass "Simplify";
+core2core hsc_env
+ mod_impl@(ModGuts { mg_binds = binds_in })
+ = do
+ let dflags = hsc_dflags hsc_env
+ core_todos
+ | Just todo <- dopt_CoreToDo dflags = todo
+ | otherwise = buildCoreToDo dflags
- (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, ru_us) = splitUniqSupply us
- dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
- (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
- text "",
- pprSimplCount counts]);
+ -- COMPUTE THE RULE BASE TO USE
+ (rule_base, local_rule_ids, orphan_rules)
+ <- prepareRules hsc_env mod_impl ru_us
- endPass "Simplify"
- (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
- binds'
- }
- where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- simpl_switch_is_on = switchIsOn sw_chkr
+ -- PREPARE THE BINDINGS
+ let binds1 = updateBinders local_rule_ids binds_in
- core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
- | otherwise = empty
+ -- DO THE BUSINESS
+ (stats, processed_binds)
+ <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
- iteration us iteration_no counts binds
- = do {
- -- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
- dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
- (pprCoreBindings tagged_binds);
-
- -- Simplify
- let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
- all_counts = counts `plusSimplCount` counts'
- } ;
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
- -- Stop if nothing happened; don't dump output
- if isZeroSimplCount counts' then
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
- else do {
+ -- Return results
+ -- We only return local orphan rules, i.e., local rules not attached to an Id
+ -- The bindings cotain more rules, embedded in the Ids
+ return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
- -- Dump the result of this iteration
- dumpIfSet opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
- (vcat[pprSimplCount counts',
- text "",
- core_iter_dump binds']) ;
-
- -- Stop if we've run out of iterations
- if iteration_no == max_iterations then
- do {
- if max_iterations > 1 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else return ();
-
- return ("Simplifier baled out", iteration_no, all_counts, binds')
- }
-
- -- Else loop
- else iteration us2 (iteration_no + 1) all_counts binds'
- } }
- where
- (us1, us2) = splitUniqSupply us
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+ -> CoreExpr
+ -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+simplifyExpr dflags expr
+ = do {
+ ; showPass dflags "Simplify"
-simplTopBinds binds = go binds `thenSmpl` \ (binds', _) ->
- returnSmpl binds'
- where
- go [] = returnSmpl ([], ())
- go (bind1 : binds) = simplBind bind1 (go binds)
-\end{code}
+ ; us <- mkSplitUniqSupply 's'
+ ; let env = emptySimplEnv SimplGently [] emptyVarSet
+ (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
-%************************************************************************
-%* *
-\subsection{Tidying core}
-%* *
-%************************************************************************
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
-Several tasks are done by @tidyCorePgm@
+ ; return expr'
+ }
-1. Make certain top-level bindings into Globals. The point is that
- Global things get externally-visible labels at code generation
- time
+doCorePasses :: DynFlags
+ -> RuleBase -- the main rule base
+ -> SimplCount -- simplifier stats
+ -> UniqSupply -- uniques
+ -> [CoreBind] -- local binds in (with rules attached)
+ -> [CoreToDo] -- which passes to do
+ -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
-2. Give all binders a nice print-name. Their uniques aren't changed;
- rather we give them lexically unique occ-names, so that we can
- safely print the OccNae only in the interface file. [Bad idea to
- change the uniques, because the code generator makes global labels
- from the uniques for local thunks etc.]
+doCorePasses dflags rb stats us binds []
+ = return (stats, binds)
-
-\begin{code}
-tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
-tidyCorePgm mod local_classes binds_in
+doCorePasses dflags rb stats us binds (to_do : to_dos)
= do
- beginPass "Tidy Core"
- let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
- where
- -- Make sure to avoid the names of class operations
- -- They don't have top-level bindings, so we won't see them
- -- in binds_in; so we must initialise the tidy_env appropriately
- --
- -- We also make sure to avoid any exported binders. Consider
- -- f{-u1-} = 1 -- Local decl
- -- ...
- -- f{-u2-} = 2 -- Exported decl
- --
- -- The second exported decl must 'get' the name 'f', so we
- -- have to put 'f' in the avoids list before we get to the first
- -- decl. Name.tidyName then does a no-op on exported binders.
- init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
- avoids = [getOccName sel_id | cls <- local_classes,
- sel_id <- classSelIds cls]
- ++
- [getOccName bndr | bind <- binds_in,
- bndr <- bindersOf bind,
- isExported bndr]
-
-tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
- -> TidyEnv
- -> CoreBind
- -> (TidyEnv, CoreBind)
-tidyBind maybe_mod env (NonRec bndr rhs)
- = let
- (env', bndr') = tidyBndr maybe_mod env bndr
- rhs' = tidyExpr env rhs
- in
- (env', NonRec bndr' rhs')
-
-tidyBind maybe_mod env (Rec pairs)
- = let
- -- We use env' when tidying the rhss
- -- When tidying the binder itself we may tidy it's
- -- specialisations; if any of these mention other binders
- -- in the group we should really feed env' to them too;
- -- but that seems (a) unlikely and (b) a bit tiresome.
- -- So I left it out for now
-
- (bndrs, rhss) = unzip pairs
- (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
- rhss' = map (tidyExpr env') rhss
- in
- (env', Rec (zip bndrs' rhss'))
-
-tidyExpr env (Type ty) = Type (tidyType env ty)
-tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
-tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
-tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
-
-tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
- where
- (env', b') = tidyBind Nothing env b
-
-tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyExpr env (Var v) = case lookupVarEnv var_env v of
- Just v' -> Var v'
- Nothing -> Var v
- where
- (_, var_env) = env
-
-tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
- where
- (env', vs') = mapAccumL tidyNestedBndr env vs
-
-tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
-\end{code}
+ let (us1, us2) = splitUniqSupply us
+
+ (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
+
+ doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
+
+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
+ = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
+doCorePass dfs rb us binds CoreDoFloatInwards
+ = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
+doCorePass dfs rb us binds (CoreDoFloatOutwards f)
+ = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
+doCorePass dfs rb us binds CoreDoStaticArgs
+ = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
+doCorePass dfs rb us binds CoreDoStrictness
+ = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
+doCorePass dfs rb us binds CoreDoWorkerWrapper
+ = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
+doCorePass dfs rb us binds CoreDoSpecialising
+ = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
+doCorePass dfs rb us binds CoreDoSpecConstr
+ = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
+#ifdef OLD_STRICTNESS
+doCorePass dfs rb us binds CoreDoOldStrictness
+ = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
+#endif
+doCorePass dfs rb us binds CoreDoPrintCore
+ = _scc_ "PrintCore" noStats dfs (printCore binds)
+doCorePass dfs rb us binds CoreDoGlomBinds
+ = noStats dfs (glomBinds dfs 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)
+
+#ifdef OLD_STRICTNESS
+doOldStrictness dfs binds
+ = do binds1 <- saBinds dfs binds
+ binds2 <- cprAnalyse dfs binds1
+ return binds2
+#endif
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings 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) }
-\begin{code}
-tidyBndr (Just mod) env id = tidyTopBndr mod env id
-tidyBndr Nothing env var = tidyNestedBndr env var
-
-tidyNestedBndr env tyvar
- | isTyVar tyvar
- = tidyTyVar env tyvar
-
-tidyNestedBndr env@(tidy_env, var_env) id
- = -- Non-top-level variables
- let
- -- Give the Id a fresh print-name, *and* rename its type
- name' = mkLocalName (getUnique id) occ'
- (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
- ty' = tidyType env (idType id)
- id' = mkUserId name' ty'
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it.
- var_env' = extendVarEnv var_env id id'
- in
- ((tidy_env', var_env'), id')
-
-tidyTopBndr mod env@(tidy_env, var_env) id
- = -- Top level variables
- let
- (tidy_env', name') = tidyTopName mod tidy_env (idName id)
- ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo env (idInfo id)
- id' = mkId name' ty' (idDetails id) idinfo'
- var_env' = extendVarEnv var_env id id'
- in
- ((tidy_env', var_env'), id')
-
--- tidyIdInfo does these things:
--- a) tidy the specialisation info (if any)
--- b) zap a complicated ICanSafelyBeINLINEd pragma,
--- c) zap the unfolding
--- The latter two are to avoid space leaks
-
-tidyIdInfo env info
- = info3
- where
- spec_items = specEnvToList (specInfo info)
- spec_env' = specEnvFromList (map tidy_item spec_items)
- info1 | null spec_items = info
- | otherwise = spec_env' `setSpecInfo` info
-
- info2 = case inlinePragInfo info of
- ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
- other -> info1
-
- info3 = noUnfolding `setUnfoldingInfo` info2
-
- tidy_item (tyvars, tys, rhs)
- = (tyvars', tidyTypes env' tys, tidyExpr env rhs)
- where
- (env', tyvars') = tidyTyVars env tyvars
\end{code}
%************************************************************************
%* *
-\subsection{PostSimplification}
+\subsection{Dealing with rules}
%* *
%************************************************************************
-Several tasks are performed by the post-simplification pass
-
-1. Make the representation of NoRep literals explicit, and
- float their bindings to the top level. We only do the floating
- part for NoRep lits inside a lambda (else no gain). We need to
- take care with let x = "foo" in e
- that we don't end up with a silly binding
- let x = y in e
- with a floated "foo". What a bore.
-
-2. *Mangle* cases involving par# in the discriminant. The unfolding
- for par in PrelConc.lhs include case expressions with integer
- results solely to fool the strictness analyzer, the simplifier,
- and anyone else who might want to fool with the evaluation order.
- At this point in the compiler our evaluation order is safe.
- Therefore, we convert expressions of the form:
-
- case par# e of
- 0# -> rhs
- _ -> parError#
- ==>
- case par# e of
- _ -> rhs
-
- fork# isn't handled like this - it's an explicit IO operation now.
- The reason is that fork# returns a ThreadId#, which gets in the
- way of the above scheme. And anyway, IO is the only guaranteed
- way to enforce ordering --SDM.
-
-3. Mangle cases involving seq# in the discriminant. Up to this
- point, seq# will appear like this:
-
- case seq# e of
- 0# -> seqError#
- _ -> ...
-
- where the 0# branch is purely to bamboozle the strictness analyser
- (see case 4 above). This code comes from an unfolding for 'seq'
- in Prelude.hs. We translate this into
-
- case e of
- _ -> ...
-
- Now that the evaluation order is safe.
-
-4. Do eta reduction for lambda abstractions appearing in:
- - the RHS of case alternatives
- - the body of a let
-
- These will otherwise turn into local bindings during Core->STG;
- better to nuke them if possible. (In general the simplifier does
- eta expansion not eta reduction, up to this point. It does eta
- on the RHSs of bindings but not the RHSs of case alternatives and
- let bodies)
+-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
+-- It attaches those rules that are for local Ids to their binders, and
+-- returns the remainder attached to Ids in an IdSet. It also returns
+-- Ids mentioned on LHS of some rule; these should be blacklisted.
+-- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
+-- so that the opportunity to apply the rule isn't lost too soon
-------------------- NOT DONE ANY MORE ------------------------
-[March 98] Indirections are now elimianted by the occurrence analyser
-1. Eliminate indirections. The point here is to transform
- x_local = E
- x_exported = x_local
- ==>
- x_exported = E
-
-[Dec 98] [Not now done because there is no penalty in the code
- generator for using the former form]
-2. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
---------------------------------------------------------------
-
-Special case
-~~~~~~~~~~~~
-
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
-things, and we need local Ids for non-floated stuff):
-
- Don't float stuff out of a binder that's marked as a bottoming Id.
- Reason: it doesn't do any good, and creates more CAFs that increase
- the size of SRTs.
-
-eg.
-
- f = error "string"
-
-is translated to
-
- f' = unpackCString# "string"
- f = error f'
-
-hence f' and f become CAFs. Instead, the special case for
-tidyTopBinding below makes sure this comes out as
-
- f = let f' = unpackCString# "string" in error f'
+\begin{code}
+prepareRules :: HscEnv
+ -> ModGuts
+ -> UniqSupply
+ -> IO (RuleBase, -- Full rule base
+ IdSet, -- Local rule Ids
+ [IdCoreRule]) -- Orphan rules defined in this module
+
+prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
+ guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
+ us
+ = do { pkg_rule_base <- loadImportedRules hsc_env guts
+
+ ; let env = emptySimplEnv SimplGently [] local_ids
+ (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+ full_rule_base = extendRuleBaseList imp_rule_base better_rules
+
+ (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
+ -- NB: the imported rules may include rules for Ids in this module
+ -- which is why we suck the local rules out of full_rule_base
+
+ orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat [text "Local rules", pprIdRules better_rules,
+ text "",
+ text "Imported rules", pprRuleBase final_rule_base])
+
+ ; return (final_rule_base, local_rule_ids, orphan_rules)
+ }
+ where
+ add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
+
+ -- Boringly, we need to gather the in-scope set.
+ local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+updateBinders :: IdSet -- Locally defined ids with their Rules attached
+ -> [CoreBind] -> [CoreBind]
+ -- A horrible function
+
+-- Update the binders of top-level bindings by
+-- attaching the rules for each locally-defined Id to that Id.
+--
+-- Reason
+-- - It makes the rules easier to look up
+-- - It means that transformation rules and specialisations for
+-- locally defined Ids are handled uniformly
+-- - It keeps alive things that are referred to only from a rule
+-- (the occurrence analyser knows about rules attached to Ids)
+-- - It makes sure that, when we apply a rule, the free vars
+-- of the RHS are more likely to be in scope
+
+updateBinders rule_ids binds
+ = map update_bndrs binds
+ where
+ update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+ update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
-and we can safely ignore f as a CAF, since it can only ever be entered once.
+ update_bndr bndr = case lookupVarSet rule_ids bndr of
+ Nothing -> bndr
+ Just id -> bndr `setIdSpecialisation` idSpecialisation id
+\end{code}
+We must do some gentle simplification on the template (but not the RHS)
+of each rule. The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+This doesn't match unless you do eta reduction on the build argument.
\begin{code}
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-doPostSimplification us binds_in
- = do
- beginPass "Post-simplification pass"
- let binds_out = initPM us (postSimplTopBinds binds_in)
- endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
-
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
-postSimplTopBinds binds
- = mapPM postSimplTopBind binds `thenPM` \ binds' ->
- returnPM (bagToList (unionManyBags binds'))
-
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
-postSimplTopBind (NonRec bndr rhs)
- | isBottomingId bndr -- Don't lift out floats for bottoming Ids
- -- See notes above
- = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
- returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
-
-postSimplTopBind bind
- = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
- returnPM (floats `snocBag` bind')
-
-postSimplBind (NonRec bndr rhs)
- = postSimplExpr rhs `thenPM` \ rhs' ->
- returnPM (NonRec bndr rhs')
-
-postSimplBind (Rec pairs)
- = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
- returnPM (Rec (bndrs `zip` rhss'))
- where
- (bndrs, rhss) = unzip pairs
+simplRule env rule@(id, BuiltinRule _ _)
+ = returnSmpl rule
+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:
+-- augment g (build h)
+-- we do not want to get
+-- augment (\a. g a) (build h)
+-- otherwise we don't match when given an argument like
+-- (\a. h a a)
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.
\end{code}
-
-Expressions
-~~~~~~~~~~~
\begin{code}
-postSimplExpr (Var v) = returnPM (Var v)
-postSimplExpr (Type ty) = returnPM (Type ty)
-
-postSimplExpr (App fun arg)
- = postSimplExpr fun `thenPM` \ fun' ->
- postSimplExpr arg `thenPM` \ arg' ->
- returnPM (App fun' arg')
-
-postSimplExpr (Con (Literal lit) args)
- = ASSERT( null args )
- litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
- getInsideLambda `thenPM` \ in_lam ->
- if in_lam && not (exprIsTrivial lit_expr) then
- -- It must have been a no-rep literal with a
- -- non-trivial representation; and we're inside a lambda;
- -- so float it to the top
- addTopFloat lit_ty lit_expr `thenPM` \ v ->
- returnPM (Var v)
- else
- returnPM lit_expr
-
-postSimplExpr (Con con args)
- = mapPM postSimplExpr args `thenPM` \ args' ->
- returnPM (Con con args')
-
-postSimplExpr (Lam bndr body)
- = insideLambda bndr $
- postSimplExpr body `thenPM` \ body' ->
- returnPM (Lam bndr body')
-
-postSimplExpr (Let bind body)
- = postSimplBind bind `thenPM` \ bind' ->
- postSimplExprEta body `thenPM` \ body' ->
- returnPM (Let bind' body')
-
-postSimplExpr (Note note body)
- = postSimplExprEta body `thenPM` \ body' ->
- returnPM (Note note body')
-
--- seq#: see notes above.
--- NB: seq# :: forall a. a -> Int#
-postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
- = postSimplExpr e `thenPM` \ e' ->
- let
- -- The old binder can't have been used, so we
- -- can gaily re-use it (yuk!)
- new_bndr = setIdType bndr ty
- in
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
--- par#: see notes above.
-postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
- | funnyParallelOp op && maybeToBool maybe_default
- = postSimplExpr scrut `thenPM` \ scrut' ->
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
+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
+--
+-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
+-- enforce that; it just simplifies the expression twice
+
+simplExprGently env expr
+ = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
+ simplExpr env (occurAnalyseGlobalExpr expr1)
+\end{code}
-postSimplExpr (Case scrut case_bndr alts)
- = postSimplExpr scrut `thenPM` \ scrut' ->
- mapPM ps_alt alts `thenPM` \ alts' ->
- returnPM (Case scrut' case_bndr alts')
- where
- ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
- returnPM (con, bndrs, rhs')
-postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
- returnPM (etaCoreExpr e')
-\end{code}
+%************************************************************************
+%* *
+\subsection{Glomming}
+%* *
+%************************************************************************
\begin{code}
-funnyParallelOp ParOp = True
-funnyParallelOp _ = False
-\end{code}
+glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
+-- Glom all binds together in one Rec, in case any
+-- transformations have introduced any new dependencies
+--
+-- NB: the global invariant is this:
+-- *** the top level bindings are never cloned, and are always unique ***
+--
+-- We sort them into dependency order, but applying transformation rules may
+-- make something at the top refer to something at the bottom:
+-- f = \x -> p (q x)
+-- h = \y -> 3
+--
+-- RULE: p (q x) = h x
+--
+-- Applying this rule makes f refer to h,
+-- although it doesn't appear to in the source program.
+-- This pass lets us control where it happens.
+--
+-- NOTICE that this cannot happen for rules whose head is a locally-defined
+-- function. It only happens for rules whose head is an imported function
+-- (p in the example above). So, for example, the rule had been
+-- RULE: f (p x) = h x
+-- then the rule for f would be attached to f itself (in its IdInfo)
+-- by prepareLocalRuleBase and h would be regarded by the occurrency
+-- analyser as free in f.
+
+glomBinds dflags binds
+ = do { showPass dflags "GlomBinds" ;
+ let { recd_binds = [Rec (flattenBinds binds)] } ;
+ return recd_binds }
+ -- Not much point in printing the result...
+ -- just consumes output bandwidth
+\end{code}
%************************************************************************
%* *
-\subsection[coreToStg-lits]{Converting literals}
+\subsection{The driver for the simplifier}
%* *
%************************************************************************
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
\begin{code}
-litToRep :: Literal -> PostM (Type, CoreExpr)
-
-litToRep (NoRepStr s ty)
- = returnPM (ty, rhs)
- where
- rhs = if (any is_NUL (_UNPK_ s))
+simplifyPgm :: DynFlags
+ -> RuleBase
+ -> SimplifierMode
+ -> [SimplifierSwitch]
+ -> UniqSupply
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
- then -- Must cater for NULs in literal string
- mkApps (Var unpackCString2Id)
- [mkLit (MachStr s),
- mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
+simplifyPgm dflags rule_base
+ mode switches us binds
+ = do {
+ showPass dflags "Simplify";
- else -- No NULs in the string
- App (Var unpackCStringId) (mkLit (MachStr s))
+ (termination_msg, it_count, counts_out, binds')
+ <- iteration us 1 (zeroSimplCount dflags) binds;
- is_NUL c = c == '\0'
-\end{code}
+ dumpIfSet (dopt Opt_D_verbose_core2core dflags
+ && dopt Opt_D_dump_simpl_stats dflags)
+ "Simplifier statistics"
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+ text "",
+ pprSimplCount counts_out]);
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @litString2Integer@.
+ endPass dflags "Simplify" Opt_D_verbose_core2core binds';
-\begin{code}
-litToRep (NoRepInteger i integer_ty)
- = returnPM (integer_ty, rhs)
- where
- rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
- | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
- | i == 2 = Var integerPlusTwoId
- | i == (-1) = Var integerMinusOneId
-
- | i > tARGET_MIN_INT && -- Small enough, so start from an Int
- i < tARGET_MAX_INT
- = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
-
- | otherwise -- Big, so start from a string
- = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
-
-
-litToRep (NoRepRational r rational_ty)
- = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
- postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
- returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+ return (counts_out, binds')
+ }
where
- (ratio_data_con, integer_ty)
- = case (splitAlgTyConApp_maybe rational_ty) of
- Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
- (con, i_ty)
-
- _ -> (panic "ratio_data_con", panic "integer_ty")
+ phase_info = case mode of
+ SimplGently -> "gentle"
+ SimplPhase n -> show n
+
+ imported_rule_ids = ruleBaseIds rule_base
+ simpl_env = emptySimplEnv mode switches imported_rule_ids
+ sw_chkr = getSwitchChecker simpl_env
+ max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
+
+ iteration us iteration_no counts binds
+ -- iteration_no is the number of the iteration we are
+ -- about to begin, with '1' for the first
+ | iteration_no > max_iterations -- Stop if we've run out of iterations
+ = do {
+#ifdef DEBUG
+ if max_iterations > 2 then
+ hPutStr stderr ("NOTE: Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out.\n")
+ else
+ return ();
+#endif
+ -- Subtract 1 from iteration_no to get the
+ -- number of iterations we actually completed
+ return ("Simplifier baled out", iteration_no - 1, counts, binds)
+ }
+
+ -- Try and force thunks off the binds; significantly reduces
+ -- space usage, especially with -O. JRS, 000620.
+ | let sz = coreBindsSize binds in sz == sz
+ = do {
+ -- Occurrence analysis
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
-\end{code}
+ dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+ (pprCoreBindings tagged_binds);
+ -- SIMPLIFY
+ -- We do this with a *case* not a *let* because lazy pattern
+ -- matching bit us with bad space leak!
+ -- With a let, we ended up with
+ -- let
+ -- t = initSmpl ...
+ -- counts' = snd t
+ -- in
+ -- case t of {(_,counts') -> if counts'=0 then ... }
+ -- So the conditional didn't force counts', because the
+ -- selection got duplicated. Sigh!
+ case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
+ (binds', counts') -> do {
+ -- The imported_rule_ids are used by initSmpl to initialise
+ -- the in-scope set. That way, the simplifier will change any
+ -- occurrences of the imported id to the one in the imported_rule_ids
+ -- set, which are decorated with their rules.
+
+ let { all_counts = counts `plusSimplCount` counts' ;
+ herald = "Simplifier phase " ++ phase_info ++
+ ", iteration " ++ show iteration_no ++
+ " out of " ++ show max_iterations
+ } ;
-%************************************************************************
-%* *
-\subsection{The monad}
-%* *
-%************************************************************************
+ -- Stop if nothing happened; don't dump output
+ if isZeroSimplCount counts' then
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ else do {
-\begin{code}
-type PostM a = Bool -- True <=> inside a *value* lambda
- -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
- -> (a, (UniqSupply, Bag CoreBind))
-
-initPM :: UniqSupply -> PostM a -> a
-initPM us m
- = case m False {- not inside lambda -} (us, emptyBag) of
- (result, _) -> result
-
-returnPM v in_lam usf = (v, usf)
-thenPM m k in_lam usf = case m in_lam usf of
- (r, usf') -> k r in_lam usf'
-
-mapPM f [] = returnPM []
-mapPM f (x:xs) = f x `thenPM` \ r ->
- mapPM f xs `thenPM` \ rs ->
- returnPM (r:rs)
-
-insideLambda :: CoreBndr -> PostM a -> PostM a
-insideLambda bndr m in_lam usf | isId bndr = m True usf
- | otherwise = m in_lam usf
-
-getInsideLambda :: PostM Bool
-getInsideLambda in_lam usf = (in_lam, usf)
-
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
-getFloatsPM m in_lam (us, floats)
- = let
- (a, (us', floats')) = m in_lam (us, emptyBag)
- in
- ((a, floats'), (us', floats))
-
-addTopFloat :: Type -> CoreExpr -> PostM Id
-addTopFloat lit_ty lit_rhs in_lam (us, floats)
- = let
- (us1, us2) = splitUniqSupply us
- uniq = uniqFromSupply us1
- lit_id = mkSysLocal SLIT("lf") uniq lit_ty
- in
- (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
-\end{code}
+ -- Dump the result of this iteration
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ (pprSimplCount counts') ;
+ endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
+ -- Loop
+ iteration us2 (iteration_no + 1) all_counts binds'
+ } } } }
+ where
+ (us1, us2) = splitUniqSupply us
+\end{code}
projects / ghc-hetmet.git / blobdiff