\section[SimplStg]{Driver for simplifying @STG@ programs}
\begin{code}
-#include "HsVersions.h"
-
module SimplStg ( stg2stg ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(IO(hPutStr,stderr))
+#include "HsVersions.h"
import StgSyn
-import StgUtils
import LambdaLift ( liftProgram )
import Name ( isLocallyDefined )
+import UniqSet ( UniqSet, mapUniqSet )
+import CostCentre ( CostCentre )
import SCCfinal ( stgMassageForProfiling )
-import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
-import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
+import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+ opt_DoStgLinting,
StgToDo(..)
)
import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
- growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
- GenId{-instance Eq/Outputable -}
+ growIdEnvList, isNullIdEnv, IdEnv,
+ GenId{-instance Eq/Outputable -}, Id
)
import Maybes ( maybeToBool )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
-import UniqSupply ( splitUniqSupply )
+import ErrUtils ( doIfSet )
+import UniqSupply ( splitUniqSupply, UniqSupply )
import Util ( mapAccumL, panic, assertPanic )
-
+import IO ( hPutStr, stderr )
+import Outputable
+import GlaExts ( trace )
\end{code}
\begin{code}
stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
-> FAST_STRING -- module name (profiling only)
- -> PprStyle -- printing style (for debugging only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
([CostCentre], -- local cost-centres that need to be decl'd
[CostCentre])) -- "extern" cost-centres
-stg2stg stg_todos module_name ppr_style us binds
+stg2stg stg_todos module_name us binds
= case (splitUniqSupply us) of { (us4now, us4later) ->
- (if do_verbose_stg2stg then
- hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
- hPutStr stderr (ppShow 1000
- (ppAbove (ppStr ("*** Core2Stg:"))
- (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
- ))
- else return ()) >>
+ doIfSet do_verbose_stg2stg
+ (printErrs (text "VERBOSE STG-TO-STG:" $$
+ text "*** Core2Stg:" $$
+ vcat (map ppr (setStgVarInfo False binds)))) >>
-- Do the main business!
foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
-- Do essential wind-up
{- Nuked for now SLPJ Dec 96
+
-- Essential wind-up: part (a), saturate RHSs
-- This must occur *after* elimIndirections, because elimIndirections
-- can change things' arities. Consider:
-- Then elimIndirections will change the program to
-- x_global = f x
-- and lo and behold x_global's arity has changed!
-
case (satStgRhs processed_binds us4later) of { saturated_binds ->
-}
-- correct, which is done by satStgRhs.
--
-{- Done in Core now. Nuke soon. SLPJ Nov 96
- let
- -- ToDo: provide proper flag control!
- binds_to_mangle
- = if not do_unlocalising
- then saturated_binds
- else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
- in
--}
-
return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
}
where
do_let_no_escapes = opt_StgDoLetNoEscapes
do_verbose_stg2stg = opt_D_verbose_stg2stg
+{-
+ (do_unlocalising, unlocal_tag)
+ = case opt_EnsureSplittableC of
+ Just tag -> (True, _PK_ tag)
+ Nothing -> (False, panic "tag")
+-}
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
-------------
- stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
- then lintStgBindings ppr_style
+ stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
+ then lintStgBindings
else ( \ whodunnit binds -> binds )
-------------------------------------------
_scc_ "StgLambdaLift"
-- NB We have to do setStgVarInfo first!
let
- binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
+ binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
in
end_pass us2 "LambdaLift" ccs binds3
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- hPutStr stderr (ppShow 1000
- (ppAbove (ppStr ("*** "++what++":"))
- (ppAboves (map (ppr ppr_style) binds2))
+ hPutStr stderr (showSDoc
+ (text ("*** "++what++":") $$ vcat (map ppr binds2)
))
else return ()) >>
let
foldl_mn f z (x:xs) = f z x >>= \ zz ->
foldl_mn f zz xs
\end{code}
-
-