2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
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 )
15 import SCCfinal ( stgMassageForProfiling )
16 import StgLint ( lintStgBindings )
17 import StgStats ( showStgStats )
18 import StgVarInfo ( setStgVarInfo )
19 import UpdAnal ( updateAnalyse )
21 import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
22 opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
26 import ErrUtils ( doIfSet )
27 import UniqSupply ( splitUniqSupply, UniqSupply )
28 import Util ( panic, assertPanic, trace )
29 import IO ( hPutStr, stderr )
34 stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
35 -> FAST_STRING -- module name (profiling only)
36 -> UniqSupply -- a name supply
37 -> [StgBinding] -- input...
39 ([StgBinding], -- output program...
40 ([CostCentre], -- local cost-centres that need to be decl'd
41 [CostCentre])) -- "extern" cost-centres
43 stg2stg stg_todos module_name us binds
44 = case (splitUniqSupply us) of { (us4now, us4later) ->
46 doIfSet do_verbose_stg2stg
47 (printErrs (text "VERBOSE STG-TO-STG:" $$
48 text "*** Core2Stg:" $$
49 vcat (map ppr (setStgVarInfo False binds)))) >>
51 -- Do the main business!
52 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
53 >>= \ (processed_binds, _, cost_centres) ->
55 -- Do essential wind-up
57 {- Nuked for now SLPJ Dec 96
59 -- Essential wind-up: part (a), saturate RHSs
60 -- This must occur *after* elimIndirections, because elimIndirections
61 -- can change things' arities. Consider:
63 -- x_global = \a -> x_local a
64 -- Then elimIndirections will change the program to
66 -- and lo and behold x_global's arity has changed!
67 case (satStgRhs processed_binds us4later) of { saturated_binds ->
70 -- Essential wind-up: part (b), do setStgVarInfo. It has to
71 -- happen regardless, because the code generator uses its
74 -- Why does it have to happen last? Because earlier passes
75 -- may move things around, which would change the live-var
76 -- info. Also, setStgVarInfo decides about let-no-escape
77 -- things, which in turn do a better job if arities are
78 -- correct, which is done by satStgRhs.
81 return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
84 do_let_no_escapes = opt_StgDoLetNoEscapes
85 do_verbose_stg2stg = opt_D_verbose_stg2stg
88 (do_unlocalising, unlocal_tag)
89 = case opt_EnsureSplittableC of
90 Just tag -> (True, _PK_ tag)
91 Nothing -> (False, panic "tag")
93 grp_name = case (opt_SccGroup) of
95 Nothing -> module_name -- default: module name
98 stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
100 else ( \ whodunnit binds -> binds )
102 -------------------------------------------
103 do_stg_pass (binds, us, ccs) to_do
105 (us1, us2) = splitUniqSupply us
108 StgDoStaticArgs -> panic "STG static argument transformation deleted"
110 StgDoUpdateAnalysis ->
111 ASSERT(null (fst ccs) && null (snd ccs))
113 -- NB We have to do setStgVarInfo first! (There's one
114 -- place free-var info is used) But no let-no-escapes,
115 -- because update analysis doesn't care.
116 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
119 trace (showStgStats binds)
120 end_pass us2 "StgStats" ccs binds
123 _scc_ "StgLambdaLift"
124 -- NB We have to do setStgVarInfo first!
126 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
128 end_pass us2 "LambdaLift" ccs binds3
130 StgDoMassageForProfiling ->
133 (collected_CCs, binds3)
134 = stgMassageForProfiling module_name grp_name us1 binds
136 end_pass us2 "ProfMassage" collected_CCs binds3
138 end_pass us2 what ccs binds2
139 = -- report verbosely, if required
140 (if do_verbose_stg2stg then
141 hPutStr stderr (showSDoc
142 (text ("*** "++what++":") $$ vcat (map ppr binds2)
146 linted_binds = stg_linter what binds2
148 return (linted_binds, us2, ccs)
149 -- return: processed binds
150 -- UniqueSupply for the next guy to use
151 -- cost-centres to be declared/registered (specialised)
152 -- add to description of what's happened (reverse order)
154 -- here so it can be inlined...
155 foldl_mn f z [] = return z
156 foldl_mn f z (x:xs) = f z x >>= \ zz ->