+import Var ( TyVar, setTyVarName )
+import Unique ( Unique, Uniquable(..),
+ ratioTyConKey, mkUnique, incrUnique, initTidyUniques
+ )
+import UniqSupply ( UniqSupply, splitUniqSupply )
+import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
+import Bag
+import Maybes
+import IO ( hPutStr, stderr )
+import Outputable
+\end{code}
+
+\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
+
+core2core core_todos module_name us binds
+ = do
+ -- Do the main business
+ processed_binds <- doCorePasses us binds core_todos
+
+ -- Do the final tidy-up
+ final_binds <- tidyCorePgm module_name processed_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
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
+\begin{code}
+simplifyPgm :: (SimplifierSwitch -> SwitchResult)
+ -> UniqSupply
+ -> [CoreBind] -- Input
+ -> IO [CoreBind] -- New bindings
+
+simplifyPgm 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"
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+ text "",
+ pprSimplCount counts]);
+
+ 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
+
+ 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 };
+ 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'
+ } ;
+
+ -- Stop if nothing happened; don't dump output
+ if isZeroSimplCount counts' then
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ else do {
+
+ -- 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
+
+
+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}
+%* *
+%************************************************************************
+
+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
+
+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
+ 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.
+
+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:
+ - 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.)
+
+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.]
+
+
+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'
+
+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)
+ where
+ (binders, 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')