#include "HsVersions.h"
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult, switchIsOn,
- opt_D_dump_occur_anal,
+ SwitchResult(..), switchIsOn, intSwitchSet,
+ opt_D_dump_occur_anal, opt_D_dump_rules,
opt_D_dump_simpl_iterations,
- opt_D_simplifier_stats,
- opt_D_dump_simpl,
+ opt_D_dump_simpl_stats,
+ opt_D_dump_simpl, opt_D_dump_rules,
opt_D_verbose_core2core,
- opt_D_dump_occur_anal
+ opt_D_dump_occur_anal,
+ opt_UsageSPOn,
)
import CoreLint ( beginPass, endPass )
import CoreSyn
+import CSE ( cseProgram )
+import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
+import CoreUnfold
import PprCore ( pprCoreBindings )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( exprIsTrivial, coreExprType )
-import Simplify ( simplBind )
-import SimplUtils ( etaCoreExpr, findDefault )
+import Simplify ( simplTopBinds, simplExpr )
+import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
import SimplMonad
-import CoreUnfold
import Const ( Con(..), Literal(..), literalType, mkMachInt )
import ErrUtils ( dumpIfSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkUserId,
- setIdVisibility, setIdUnfolding,
- getIdSpecialisation, setIdSpecialisation,
- getInlinePragma, setInlinePragma,
- idType, setIdType
+import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
+ idType, setIdType, idName, idInfo, setIdNoDiscard
)
-import IdInfo ( InlinePragInfo(..) )
import VarEnv
import VarSet
-import Name ( isExported, mkSysLocalName,
- Module, NamedThing(..), OccName(..)
+import Module ( Module )
+import Name ( mkLocalName, tidyOccName, tidyTopName,
+ NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
import PrimOp ( PrimOp(..) )
-import PrelInfo ( unpackCStringId, unpackCString2Id,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId,
- int2IntegerId, addr2IntegerId
- )
+import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType, mkTyVarTy, Type )
-import TysWiredIn ( isIntegerTy )
+ isUnLiftedType,
+ tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
+ Type
+ )
+import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
import LiberateCase ( liberateCase )
-import PprType ( nmbrType )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
-import SpecEnv ( specEnvToList, specEnvFromList )
-import StrictAnal ( saWwTopBinds )
-import Var ( TyVar, setTyVarName )
+import UsageSPInf ( doUsageSPInf )
+import StrictAnal ( saBinds )
+import WorkWrap ( wwTopBinds )
+import CprAnalyse ( cprAnalyse )
+
import Unique ( Unique, Uniquable(..),
- ratioTyConKey, mkUnique, incrUnique, initTidyUniques
+ ratioTyConKey
)
-import UniqSupply ( UniqSupply, splitUniqSupply )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
+import Util ( mapAccumL )
+import SrcLoc ( noSrcLoc )
import Bag
import Maybes
import IO ( hPutStr, stderr )
import Outputable
+
+import Ratio ( numerator, denominator )
\end{code}
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
\begin{code}
core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> FAST_STRING -- Module name (profiling only)
- -> UniqSupply -- A name supply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- Result
+ -> [CoreBind] -- Binds in
+ -> [ProtoCoreRule] -- Rules
+ -> IO ([CoreBind], [ProtoCoreRule])
-core2core core_todos module_name us binds
+core2core core_todos binds rules
= do
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, us1) = splitUniqSupply us
+ (ru_us, ps_us) = splitUniqSupply us1
+
+ better_rules <- simplRules ru_us rules binds
+
+ let (binds1, rule_base) = prepareRuleBase binds better_rules
+
-- Do the main business
- processed_binds <- doCorePasses us binds core_todos
+ (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
+ rule_base core_todos
- -- Do the final tidy-up
- final_binds <- tidyCorePgm module_name processed_binds
+ dumpIfSet opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
+
+ -- Do the post-simplification business
+ post_simpl_binds <- doPostSimplification ps_us processed_binds
-- Return results
- return final_binds
+ return (post_simpl_binds, filter orphanRule better_rules)
+
-doCorePasses us binds []
- = return binds
+doCorePasses stats us binds irs []
+ = return (stats, binds)
-doCorePasses us binds (to_do : to_dos)
+doCorePasses stats us binds irs (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
+ (stats1, binds1) <- doCorePass us1 binds irs to_do
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
+doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf"
+ if opt_UsageSPOn then
+ noStats (doUsageSPInf us binds)
+ else
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+ noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }
\end{code}
%************************************************************************
%* *
+\subsection{Dealing with rules}
+%* *
+%************************************************************************
+
+We must do some gentle simplifiation 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}
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
+simplRules us rules binds
+ = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
+
+ dumpIfSet opt_D_dump_rules
+ "Transformation rules"
+ (vcat (map pprProtoCoreRule better_rules))
+
+ return better_rules
+ where
+ black_list_all v = True -- This stops all inlining
+ sw_chkr any = SwBool False -- A bit bogus
+
+ -- Boringly, we need to gather the in-scope set.
+ -- Typically this thunk won't even be force, but the test in
+ -- simpVar fails if it isn't right, and it might conceivably matter
+ bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
+ | not is_local
+ = returnSmpl rule -- No need to fiddle with imported rules
+ | otherwise
+ = simplBinders bndrs $ \ bndrs' ->
+ mapSmpl simplExpr args `thenSmpl` \ args' ->
+ simplExpr rhs `thenSmpl` \ rhs' ->
+ returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+\end{code}
+
+%************************************************************************
+%* *
\subsection{The driver for the simplifier}
%* *
%************************************************************************
\begin{code}
-simplifyPgm :: (SimplifierSwitch -> SwitchResult)
+simplifyPgm :: RuleBase
+ -> (SimplifierSwitch -> SwitchResult)
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- New bindings
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm sw_chkr us binds
+simplifyPgm (imported_rule_ids, rule_lhs_fvs)
+ sw_chkr us binds
= do {
beginPass "Simplify";
- (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
-
- dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
+ -- 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. Our solution is to do this occasional glom-together step,
+ -- just once per overall simplfication step.
+
+ let { recd_binds = [Rec (flattenBinds binds)] };
+
+ (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
+
+ dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+ "Simplifier statistics"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
text "",
- pprSimplCount counts]);
+ pprSimplCount counts_out]);
endPass "Simplify"
(opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
- binds'
+ binds' ;
+
+ return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- simpl_switch_is_on = switchIsOn sw_chkr
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
| otherwise = empty
iteration us iteration_no counts binds
= do {
-- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+
dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- Simplify
- let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
+ let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
+ black_list_fn
+ (simplTopBinds tagged_binds);
all_counts = counts `plusSimplCount` counts'
} ;
dumpIfSet opt_D_dump_simpl_iterations
("Simplifier iteration " ++ show iteration_no
++ " out of " ++ show max_iterations)
- (vcat[pprSimplCount counts',
- text "",
- core_iter_dump binds']) ;
+ (pprSimplCount counts') ;
+
+ if opt_D_dump_simpl_iterations then
+ endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
+ opt_D_verbose_core2core
+ binds'
+ else
+ return [] ;
-- Stop if we've run out of iterations
if iteration_no == max_iterations then
do {
- if max_iterations > 1 then
+ if max_iterations > 2 then
hPutStr stderr ("NOTE: Simplifier still going after " ++
show max_iterations ++
" iterations; bailing out.\n")
} }
where
(us1, us2) = splitUniqSupply us
-
-
-simplTopBinds [] = returnSmpl []
-simplTopBinds (bind1 : binds) = (simplBind bind1 $
- simplTopBinds binds) `thenSmpl` \ (binds1', binds') ->
- returnSmpl (binds1' ++ binds')
\end{code}
%************************************************************************
%* *
-\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
+\subsection{PostSimplification}
%* *
%************************************************************************
-Several tasks are done by @tidyCorePgm@
-
-----------------
- [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
+Several tasks are performed by the post-simplification pass
-2. Make certain top-level bindings into Globals. The point is that
- Global things get externally-visible labels at code generation
- time
-
-3. Make the representation of NoRep literals explicit, and
+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
let x = y in e
with a floated "foo". What a bore.
-4. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
-
-5. *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.
-
-6. 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 5 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. The code generator knows
- how to push a seq frame on the stack if 'e' is of function type,
- or is polymorphic.
-
-
-7. Do eta reduction for lambda abstractions appearing in:
+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.)
+ 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)
+
-9. 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.]
+------------------- 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
~~~~~~~~~~~~
and we can safely ignore f as a CAF, since it can only ever be entered once.
-\begin{code}
-tidyCorePgm :: Module -> [CoreBind] -> IO [CoreBind]
-
-tidyCorePgm mod binds_in
- = do
- beginPass "Tidy Core"
- let binds_out = bagToList (initTM mod (tidyTopBindings binds_in))
-
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
-\end{code}
-
-Top level bindings
-~~~~~~~~~~~~~~~~~~
\begin{code}
-tidyTopBindings [] = returnTM emptyBag
-tidyTopBindings (b:bs)
- = tidyTopBinding b $
- tidyTopBindings bs
-
-tidyTopBinding :: CoreBind
- -> TopTidyM (Bag CoreBind)
- -> TopTidyM (Bag CoreBind)
-
-tidyTopBinding (NonRec bndr rhs) thing_inside
- = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
- tidyTopBinder bndr $ \ bndr' ->
- thing_inside `thenTM` \ binds ->
- let
- this_bind {- | isBottomingId bndr
- = unitBag (NonRec bndr' (foldrBag Let rhs' floats))
- | otherwise -}
- = floats `snocBag` NonRec bndr' rhs'
- in
- returnTM (this_bind `unionBags` binds)
-
-tidyTopBinding (Rec pairs) thing_inside
- = tidyTopBinders binders $ \ binders' ->
- initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
- thing_inside `thenTM` \ binds_inside ->
- returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
+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
- (binders, rhss) = unzip pairs
+ (bndrs, rhss) = unzip pairs
\end{code}
-\begin{code}
-tidyTopBinder :: Id -> (Id -> TopTidyM (Bag CoreBind)) -> TopTidyM (Bag CoreBind)
-tidyTopBinder id thing_inside
- = mungeTopBndr id $ \ id' ->
- let
- spec_items = specEnvToList (getIdSpecialisation id')
- in
- if null spec_items then
-
- -- Common case, no specialisations to tidy
- thing_inside id'
- else
-
- -- Oh well, tidy those specialisations
- initNestedTM (mapTM tidySpecItem spec_items) `thenTM` \ (spec_items', floats) ->
- let
- id'' = setIdSpecialisation id' (specEnvFromList spec_items')
- in
- extendEnvTM id (Var id'') $
- thing_inside id'' `thenTM` \ binds ->
- returnTM (floats `unionBags` binds)
-
-tidyTopBinders [] k = k []
-tidyTopBinders (b:bs) k = tidyTopBinder b $ \ b' ->
- tidyTopBinders bs $ \ bs' ->
- k (b' : bs')
-
-tidySpecItem (tyvars, tys, rhs)
- = newBndrs tyvars $ \ tyvars' ->
- mapTM tidyTy tys `thenTM` \ tys' ->
- tidyCoreExpr rhs `thenTM` \ rhs' ->
- returnTM (tyvars', tys', rhs')
-\end{code}
Expressions
~~~~~~~~~~~
\begin{code}
-tidyCoreExpr (Var v) = lookupId v
-
-tidyCoreExpr (Type ty)
- = tidyTy ty `thenTM` \ ty' ->
- returnTM (Type ty')
+postSimplExpr (Var v) = returnPM (Var v)
+postSimplExpr (Type ty) = returnPM (Type ty)
-tidyCoreExpr (App fun arg)
- = tidyCoreExpr fun `thenTM` \ fun' ->
- tidyCoreExpr arg `thenTM` \ arg' ->
- returnTM (App fun' arg')
+postSimplExpr (App fun arg)
+ = postSimplExpr fun `thenPM` \ fun' ->
+ postSimplExpr arg `thenPM` \ arg' ->
+ returnPM (App fun' arg')
-tidyCoreExpr (Con (Literal lit) args)
+postSimplExpr (Con (Literal lit) args)
= ASSERT( null args )
- litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
- getInsideLambda `thenTM` \ in_lam ->
+ 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 `thenTM` \ v ->
- returnTM (Var v)
+ addTopFloat lit_ty lit_expr `thenPM` \ v ->
+ returnPM (Var v)
else
- returnTM lit_expr
-
-tidyCoreExpr (Con con args)
- = mapTM tidyCoreExpr args `thenTM` \ args' ->
- returnTM (Con con args')
-
-tidyCoreExpr (Lam bndr body)
- = newBndr bndr $ \ bndr' ->
- insideLambda bndr $
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam bndr' body')
-
-tidyCoreExpr (Let (NonRec bndr rhs) body)
- = tidyCoreExpr rhs `thenTM` \ rhs' ->
- tidyBindNonRec bndr rhs' body
-
-tidyCoreExpr (Let (Rec pairs) body)
- = newBndrs bndrs $ \ bndrs' ->
- mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
- tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Let (Rec (bndrs' `zip` rhss')) body')
+ 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')
+
+postSimplExpr (Case scrut case_bndr alts)
+ = postSimplExpr scrut `thenPM` \ scrut' ->
+ mapPM ps_alt alts `thenPM` \ alts' ->
+ returnPM (Case scrut' case_bndr alts')
where
- (bndrs, rhss) = unzip pairs
-
-tidyCoreExpr (Note (Coerce to_ty from_ty) body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- tidyTy to_ty `thenTM` \ to_ty' ->
- tidyTy from_ty `thenTM` \ from_ty' ->
- returnTM (Note (Coerce to_ty' from_ty') body')
-
-tidyCoreExpr (Note note body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Note note body')
-
--- seq#: see notes above.
-tidyCoreExpr (Case scrut@(Con (PrimOp SeqOp) [Type _, e]) bndr alts)
- = tidyCoreExpr e `thenTM` \ e' ->
- newBndr bndr $ \ bndr' ->
- let new_bndr = setIdType bndr' (coreExprType e') in
- tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
- returnTM (Case e' new_bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
--- par#: see notes above.
-tidyCoreExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
- | funnyParallelOp op && maybeToBool maybe_default
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- newBndr bndr $ \ bndr' ->
- tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
- returnTM (Case scrut' bndr' [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
-tidyCoreExpr (Case scrut case_bndr alts)
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- newBndr case_bndr $ \ case_bndr' ->
- mapTM tidy_alt alts `thenTM` \ alts' ->
- returnTM (Case scrut' case_bndr' alts')
- where
- tidy_alt (con,bndrs,rhs) = newBndrs bndrs $ \ bndrs' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (con, bndrs', rhs')
-
-tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
- returnTM (etaCoreExpr e')
-
-tidyBindNonRec bndr val' body
- | exprIsTrivial val'
- = extendEnvTM bndr val' (tidyCoreExpr body)
+ ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
+ returnPM (con, bndrs, rhs')
- | otherwise
- = newBndr bndr $ \ bndr' ->
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Let (NonRec bndr' val') body')
+postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
+ returnPM (etaCoreExpr e')
\end{code}
binding out to the top level.
\begin{code}
-
-litToRep :: Literal -> NestTidyM (Type, CoreExpr)
+litToRep :: Literal -> PostM (Type, CoreExpr)
litToRep (NoRepStr s ty)
- = returnTM (ty, rhs)
+ = returnPM (ty, rhs)
where
rhs = if (any is_NUL (_UNPK_ s))
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@.
+otherwise, wrap with @addr2Integer@.
\begin{code}
litToRep (NoRepInteger i integer_ty)
- = returnTM (integer_ty, rhs)
+ = 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
+ rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
i < tARGET_MAX_INT
- = App (Var int2IntegerId) (Con (Literal (mkMachInt i)) [])
+ = Con (DataCon smallIntegerDataCon) [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)
- = tidyCoreExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
- tidyCoreExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
- returnTM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+ = 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])
where
(ratio_data_con, integer_ty)
= case (splitAlgTyConApp_maybe rational_ty) of
_ -> (panic "ratio_data_con", panic "integer_ty")
-litToRep other_lit = returnTM (literalType other_lit, mkLit other_lit)
+litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
\end{code}
-\begin{code}
-funnyParallelOp ParOp = True
-funnyParallelOp _ = False
-\end{code}
-
%************************************************************************
%* *
%************************************************************************
\begin{code}
-type TidyM a state = Module
- -> Bool -- True <=> inside a *value* lambda
- -> (TyVarEnv Type, IdEnv CoreExpr, IdOrTyVarSet)
- -- Substitution and in-scope binders
- -> state
- -> (a, state)
+type PostM a = Bool -- True <=> inside a *value* lambda
+ -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
+ -> (a, (UniqSupply, Bag CoreBind))
-type TopTidyM a = TidyM a Unique
-type NestTidyM a = TidyM a (Unique, -- Global names
- Unique, -- Local names
- Bag CoreBind) -- Floats
-
-
-(initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
-
-initTM :: Module -> TopTidyM a -> a
-initTM mod m
- = case m mod False {- not inside lambda -} empty_env initialTopTidyUnique of
+initPM :: UniqSupply -> PostM a -> a
+initPM us m
+ = case m False {- not inside lambda -} (us, emptyBag) of
(result, _) -> result
- where
- empty_env = (emptyVarEnv, emptyVarEnv, emptyVarSet)
-initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBind)
-initNestedTM m mod in_lam env global_us
- = case m mod in_lam env (global_us, initialNestedTidyUnique, emptyBag) of
- (result, (global_us', _, floats)) -> ((result, floats), global_us')
+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'
-returnTM v mod in_lam env usf = (v, usf)
-thenTM m k mod in_lam env usf = case m mod in_lam env usf of
- (r, usf') -> k r mod in_lam env usf'
+mapPM f [] = returnPM []
+mapPM f (x:xs) = f x `thenPM` \ r ->
+ mapPM f xs `thenPM` \ rs ->
+ returnPM (r:rs)
-mapTM f [] = returnTM []
-mapTM f (x:xs) = f x `thenTM` \ r ->
- mapTM f xs `thenTM` \ rs ->
- returnTM (r:rs)
+insideLambda :: CoreBndr -> PostM a -> PostM a
+insideLambda bndr m in_lam usf | isId bndr = m True usf
+ | otherwise = m in_lam usf
-insideLambda :: CoreBndr -> NestTidyM a -> NestTidyM a
-insideLambda bndr m mod in_lam env usf | isId bndr = m mod True env usf
- | otherwise = m mod in_lam env usf
+getInsideLambda :: PostM Bool
+getInsideLambda in_lam usf = (in_lam, usf)
-getInsideLambda :: NestTidyM Bool
-getInsideLambda mod in_lam env usf = (in_lam, usf)
-\end{code}
-
-Need to extend the environment when we munge a binder, so that
-occurrences of the binder will print the correct way (e.g. as a global
-not a local).
-
-In cases where we don't clone the binder (because it's an exported
-id), we still zap the unfolding and inline pragma info so that
-unnecessary gumph isn't carried into the code generator. This fixes a
-nasty space leak.
-
-\begin{code}
-mungeTopBndr id thing_inside mod in_lam env@(ty_env, val_env, in_scope) us
- = thing_inside id' mod in_lam (ty_env, val_env', in_scope') us'
- where
- (id', us') | isExported id = (zapSomeIdInfo id, us)
- | otherwise = (zapSomeIdInfo (setIdVisibility (Just mod) us id),
- incrUnique us)
- val_env' = extendVarEnv val_env id (Var id')
- in_scope' = extendVarSet in_scope id'
-
-zapSomeIdInfo id = id `setIdUnfolding` noUnfolding `setInlinePragma` new_ip
- where new_ip = case getInlinePragma id of
- ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
- something_else -> something_else
-
-addTopFloat :: Type -> CoreExpr -> NestTidyM Id
-addTopFloat lit_ty lit_rhs mod in_lam env (gus, lus, floats)
+getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
+getFloatsPM m in_lam (us, floats)
= let
- gus' = incrUnique gus
- lit_local = mkSysLocal gus lit_ty
- lit_id = setIdVisibility (Just mod) gus lit_local
+ (a, (us', floats')) = m in_lam (us, emptyBag)
in
- (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
-
-lookupId :: Id -> TidyM CoreExpr state
-lookupId v mod in_lam (_, val_env, _) usf
- = case lookupVarEnv val_env v of
- Nothing -> (Var v, usf)
- Just e -> (e, usf)
-
-extendEnvTM :: Id -> CoreExpr -> (TidyM a state) -> TidyM a state
-extendEnvTM v e m mod in_lam (ty_env, val_env, in_scope) usf
- = m mod in_lam (ty_env, extendVarEnv val_env v e, in_scope) usf
-\end{code}
+ ((a, floats'), (us', floats))
-
-Making new local binders
-~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-newBndr tyvar thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
- | isTyVar tyvar
+addTopFloat :: Type -> CoreExpr -> PostM Id
+addTopFloat lit_ty lit_rhs in_lam (us, floats)
= let
- local_uniq' = incrUnique local_uniq
- tyvar' = setTyVarName tyvar (mkSysLocalName local_uniq)
- ty_env' = extendVarEnv ty_env tyvar (mkTyVarTy tyvar')
- in_scope' = extendVarSet in_scope tyvar'
- in
- thing_inside tyvar' mod in_lam (ty_env', val_env, in_scope') (gus, local_uniq', floats)
-
-newBndr id thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
- | isId id
- = let
- -- Give the Id a fresh print-name, *and* rename its type
- local_uniq' = incrUnique local_uniq
- name' = mkSysLocalName local_uniq
- ty' = nmbrType ty_env local_uniq' (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.
-
- val_env' = extendVarEnv val_env id (Var id')
- in_scope' = extendVarSet in_scope id'
+ (us1, us2) = splitUniqSupply us
+ uniq = uniqFromSupply us1
+ lit_id = mkSysLocal SLIT("lf") uniq lit_ty
in
- thing_inside id' mod in_lam (ty_env, val_env', in_scope') (gus, local_uniq', floats)
-
-newBndrs [] thing_inside
- = thing_inside []
-newBndrs (bndr:bndrs) thing_inside
- = newBndr bndr $ \ bndr' ->
- newBndrs bndrs $ \ bndrs' ->
- thing_inside (bndr' : bndrs')
+ (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
\end{code}
-Re-numbering types
-~~~~~~~~~~~~~~~~~~
-\begin{code}
-tidyTy ty mod in_lam (ty_env, val_env, in_scope) usf@(_, local_uniq, _)
- = (nmbrType ty_env local_uniq ty, usf)
- -- We can use local_uniq as a base for renaming forall'd variables
- -- in the type; we don't need to know how many are consumed.
-\end{code}
--- Get rid of this function when we move to the new code generator.
-
-\begin{code}
-typeOkForCase :: Type -> Bool
-typeOkForCase ty
- | isUnLiftedType ty -- Primitive case
- = True
-
- | otherwise
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, ty_args, []) -> False
- Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
- other -> False
- -- Null data cons => type is abstract, which code gen can't
- -- currently handle. (ToDo: when return-in-heap is universal we
- -- don't need to worry about this.)
-\end{code}
projects / ghc-hetmet.git / blobdiff