2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
7 module SimplStg ( stg2stg ) where
9 #include "HsVersions.h"
13 import LambdaLift ( liftProgram )
14 import CostCentre ( CostCentre, CostCentreStack )
15 import SCCfinal ( stgMassageForProfiling )
16 import StgLint ( lintStgBindings )
17 import StgStats ( showStgStats )
18 import StgVarInfo ( setStgVarInfo )
19 import UpdAnal ( updateAnalyse )
20 import SRT ( computeSRTs )
22 import CmdLineOpts ( opt_SccGroup,
23 opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
28 import Module ( Module, moduleString )
30 import ErrUtils ( doIfSet )
31 import UniqSupply ( splitUniqSupply, UniqSupply )
32 import IO ( hPutStr, stderr )
37 stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
38 -> Module -- module name (profiling only)
39 -> UniqSupply -- a name supply
40 -> [StgBinding] -- input...
42 ([(StgBinding,[Id])], -- output program...
43 ([CostCentre], -- local cost-centres that need to be decl'd
44 [CostCentre], -- "extern" cost-centres
45 [CostCentreStack])) -- pre-defined "singleton" cost centre stacks
47 stg2stg stg_todos module_name us binds
48 = case (splitUniqSupply us) of { (us4now, us4later) ->
50 doIfSet do_verbose_stg2stg
51 (printErrs (text "VERBOSE STG-TO-STG:" $$
52 text "*** Core2Stg:" $$
53 vcat (map ppr (setStgVarInfo False binds)))) >>
55 -- Do the main business!
56 foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
57 >>= \ (processed_binds, _, cost_centres) ->
59 -- Do essential wind-up
61 -- Essential wind-up: part (b), do setStgVarInfo. It has to
62 -- happen regardless, because the code generator uses its
65 -- Why does it have to happen last? Because earlier passes
66 -- may move things around, which would change the live-var
67 -- info. Also, setStgVarInfo decides about let-no-escape
68 -- things, which in turn do a better job if arities are
69 -- correct, which is done by satStgRhs.
73 annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
74 srt_binds = computeSRTs annotated_binds
77 return (srt_binds, cost_centres)
80 do_let_no_escapes = opt_StgDoLetNoEscapes
81 do_verbose_stg2stg = opt_D_verbose_stg2stg
83 grp_name = case (opt_SccGroup) of
85 Nothing -> _PK_ (moduleString module_name) -- default: module name
88 stg_linter = if opt_DoStgLinting
90 else ( \ whodunnit binds -> binds )
92 -------------------------------------------
93 do_stg_pass (binds, us, ccs) to_do
95 (us1, us2) = splitUniqSupply us
98 StgDoStaticArgs -> panic "STG static argument transformation deleted"
100 StgDoUpdateAnalysis ->
102 -- NB We have to do setStgVarInfo first! (There's one
103 -- place free-var info is used) But no let-no-escapes,
104 -- because update analysis doesn't care.
105 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
108 trace (showStgStats binds)
109 end_pass us2 "StgStats" ccs binds
112 _scc_ "StgLambdaLift"
113 -- NB We have to do setStgVarInfo first!
115 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
117 end_pass us2 "LambdaLift" ccs binds3
119 StgDoMassageForProfiling ->
122 (collected_CCs, binds3)
123 = stgMassageForProfiling module_name grp_name us1 binds
125 end_pass us2 "ProfMassage" collected_CCs binds3
127 end_pass us2 what ccs binds2
128 = -- report verbosely, if required
129 (if do_verbose_stg2stg then
130 hPutStr stderr (showSDoc
131 (text ("*** "++what++":") $$ vcat (map ppr binds2)
135 linted_binds = stg_linter what binds2
137 return (linted_binds, us2, ccs)
138 -- return: processed binds
139 -- UniqueSupply for the next guy to use
140 -- cost-centres to be declared/registered (specialised)
141 -- add to description of what's happened (reverse order)
143 -- here so it can be inlined...
144 foldl_mn f z [] = return z
145 foldl_mn f z (x:xs) = f z x >>= \ zz ->