import UpdAnal ( updateAnalyse )
import SRT ( computeSRTs )
-import CmdLineOpts ( opt_SccGroup,
- opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
- opt_DoStgLinting,
+import CmdLineOpts ( opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+ opt_DoStgLinting, opt_D_dump_stg,
StgToDo(..)
)
import Id ( Id )
+import Module ( Module, moduleString )
import VarEnv
-import ErrUtils ( doIfSet )
+import ErrUtils ( doIfSet, dumpIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
-import Util ( panic, assertPanic, trace )
import IO ( hPutStr, stderr )
import Outputable
\end{code}
\begin{code}
stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
- -> FAST_STRING -- module name (profiling only)
+ -> Module -- module name (profiling only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
stg2stg stg_todos module_name us binds
= case (splitUniqSupply us) of { (us4now, us4later) ->
- doIfSet do_verbose_stg2stg
- (printErrs (text "VERBOSE STG-TO-STG:" $$
- text "*** Core2Stg:" $$
- vcat (map ppr (setStgVarInfo False binds)))) >>
+ doIfSet opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>
+
+ end_pass us4now "Core2Stg" ([],[],[]) binds
+ >>= \ (binds', us, ccs) ->
-- Do the main business!
- foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
+ foldl_mn do_stg_pass (binds', us, ccs) stg_todos
>>= \ (processed_binds, _, cost_centres) ->
-- Do essential wind-up
--
let
- annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
+ annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
srt_binds = computeSRTs annotated_binds
in
+ dumpIfSet opt_D_dump_stg "STG syntax:"
+ (pprStgBindingsWithSRTs srt_binds) >>
+
return (srt_binds, cost_centres)
}
- where
- do_let_no_escapes = opt_StgDoLetNoEscapes
- do_verbose_stg2stg = opt_D_verbose_stg2stg
- grp_name = case (opt_SccGroup) of
- Just xx -> _PK_ xx
- Nothing -> module_name -- default: module name
-
- -------------
+ where
stg_linter = if opt_DoStgLinting
then lintStgBindings
else ( \ whodunnit binds -> binds )
_scc_ "StgLambdaLift"
-- NB We have to do setStgVarInfo first!
let
- binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
+ binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
in
end_pass us2 "LambdaLift" ccs binds3
_scc_ "ProfMassage"
let
(collected_CCs, binds3)
- = stgMassageForProfiling module_name grp_name us1 binds
+ = stgMassageForProfiling module_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
end_pass us2 what ccs binds2
= -- report verbosely, if required
- (if do_verbose_stg2stg then
- hPutStr stderr (show
+ (if opt_D_verbose_stg2stg then
+ hPutStr stderr (showSDoc
(text ("*** "++what++":") $$ vcat (map ppr binds2)
))
else return ()) >>