2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
7 #include "HsVersions.h"
9 module SimplStg ( stg2stg ) where
16 import LambdaLift ( liftProgram )
17 import SCCfinal ( stgMassageForProfiling )
18 import SatStgRhs ( satStgRhs )
19 import StgLint ( lintStgBindings )
20 import StgSAT ( doStaticArgs )
21 import StgStats ( showStgStats )
22 import StgVarInfo ( setStgVarInfo )
23 import UpdAnal ( updateAnalyse )
25 import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
26 opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
29 import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
30 growIdEnvList, isNullIdEnv, IdEnv(..),
31 GenId{-instance Eq/Outputable -}
33 import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
34 import Maybes ( maybeToBool )
35 import Outputable ( isExported )
36 import PprType ( GenType{-instance Outputable-} )
37 import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
38 import UniqSupply ( splitUniqSupply )
39 import Util ( mapAccumL, panic, assertPanic )
41 unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
45 stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
46 -> FAST_STRING -- module name (profiling only)
47 -> PprStyle -- printing style (for debugging only)
48 -> UniqSupply -- a name supply
49 -> [StgBinding] -- input...
51 ([StgBinding], -- output program...
52 ([CostCentre], -- local cost-centres that need to be decl'd
53 [CostCentre])) -- "extern" cost-centres
55 stg2stg stg_todos module_name ppr_style us binds
57 case (splitUniqSupply us) of { (us4now, us4later) ->
59 (if do_verbose_stg2stg then
60 writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
61 writeMn stderr (ppShow 1000
62 (ppAbove (ppStr ("*** Core2Stg:"))
63 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
65 else returnMn ()) `thenMn_`
67 -- Do the main business!
68 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
69 `thenMn` \ (processed_binds, _, cost_centres) ->
70 -- Do essential wind-up: part (a) is SatStgRhs
72 -- Not optional, because correct arity information is used by
73 -- the code generator. Afterwards do setStgVarInfo; it gives
74 -- the wrong answers if arities are subsequently changed,
75 -- which stgSatRhs might do. Furthermore, setStgVarInfo
76 -- decides about let-no-escape things, which in turn do a
77 -- better job if arities are correct, which is done by
80 case (satStgRhs processed_binds us4later) of { saturated_binds ->
82 -- Essential wind-up: part (b), eliminate indirections
84 let no_ind_binds = elimIndirections saturated_binds in
87 -- Essential wind-up: part (c), do setStgVarInfo. It has to
88 -- happen regardless, because the code generator uses its
91 -- Why does it have to happen last? Because earlier passes
92 -- may move things around, which would change the live-var
93 -- info. Also, setStgVarInfo decides about let-no-escape
94 -- things, which in turn do a better job if arities are
95 -- correct, which is done by satStgRhs.
98 -- ToDo: provide proper flag control!
100 = if not do_unlocalising
102 else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
104 returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
108 do_let_no_escapes = opt_StgDoLetNoEscapes
109 do_verbose_stg2stg = opt_D_verbose_stg2stg
111 (do_unlocalising, unlocal_tag)
112 = case (opt_EnsureSplittableC) of
113 Nothing -> (False, panic "tag")
114 Just tag -> (True, tag)
116 grp_name = case (opt_SccGroup) of
118 Nothing -> module_name -- default: module name
121 stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
122 then lintStgBindings ppr_style
123 else ( \ whodunnit binds -> binds )
125 -------------------------------------------
126 do_stg_pass (binds, us, ccs) to_do
128 (us1, us2) = splitUniqSupply us
132 ASSERT(null (fst ccs) && null (snd ccs))
133 BSCC("StgStaticArgs")
135 binds3 = doStaticArgs binds us1
137 end_pass us2 "StgStaticArgs" ccs binds3
140 StgDoUpdateAnalysis ->
141 ASSERT(null (fst ccs) && null (snd ccs))
143 -- NB We have to do setStgVarInfo first! (There's one
144 -- place free-var info is used) But no let-no-escapes,
145 -- because update analysis doesn't care.
146 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
150 trace (showStgStats binds)
151 end_pass us2 "StgStats" ccs binds
154 BSCC("StgLambdaLift")
155 -- NB We have to do setStgVarInfo first!
157 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
159 end_pass us2 "LambdaLift" ccs binds3
162 StgDoMassageForProfiling ->
165 (collected_CCs, binds3)
166 = stgMassageForProfiling module_name grp_name us1 binds
168 end_pass us2 "ProfMassage" collected_CCs binds3
171 end_pass us2 what ccs binds2
172 = -- report verbosely, if required
173 (if do_verbose_stg2stg then
174 writeMn stderr (ppShow 1000
175 (ppAbove (ppStr ("*** "++what++":"))
176 (ppAboves (map (ppr ppr_style) binds2))
178 else returnMn ()) `thenMn_`
180 linted_binds = stg_linter what binds2
182 returnMn (linted_binds, us2, ccs)
183 -- return: processed binds
184 -- UniqueSupply for the next guy to use
185 -- cost-centres to be declared/registered (specialised)
186 -- add to description of what's happened (reverse order)
188 -- here so it can be inlined...
189 foldl_mn f z [] = returnMn z
190 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
194 %************************************************************************
196 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
198 %************************************************************************
200 The idea of all this ``unlocalise'' stuff is that in certain (prelude
201 only) modules we split up the .hc file into lots of separate little
202 files, which are separately compiled by the C compiler. That gives
203 lots of little .o files. The idea is that if you happen to mention
204 one of them you don't necessarily pull them all in. (Pulling in a
205 piece you don't need can be v bad, because it may mention other pieces
206 you don't need either, and so on.)
208 Sadly, splitting up .hc files means that local names (like s234) are
209 now globally visible, which can lead to clashes between two .hc
210 files. So unlocaliseWhatnot goes through making all the local things
211 into global things, essentially by giving them full names so when they
212 are printed they'll have their module name too. Pretty revolting
216 type UnlocalEnv = IdEnv Id
218 lookup_uenv :: UnlocalEnv -> Id -> Id
219 lookup_uenv env id = case lookupIdEnv env id of
221 Just new_id -> new_id
223 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
225 unlocaliseStgBinds mod uenv [] = (uenv, [])
227 unlocaliseStgBinds mod uenv (b : bs)
228 = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) ->
229 BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
230 (uenv3, new_b : new_bs)
235 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
237 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
238 = let new_uenv = case unlocaliseId mod binder of
240 Just new_binder -> addOneToIdEnv uenv binder new_binder
242 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
244 unlocal_top_bind mod uenv bind@(StgRec pairs)
245 = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
246 new_uenv = growIdEnvList uenv [ (b,new_b)
247 | (b, Just new_b) <- maybe_unlocaliseds]
249 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
252 %************************************************************************
254 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
256 %************************************************************************
258 In @elimIndirections@, we look for things at the top-level of the form...
265 In cases we find like this, we go {\em backwards} and replace
266 \tr{x_local} with \tr{...rhs...}, to produce
268 x_exported = ...rhs...
272 This saves a gratuitous jump
273 (from \tr{x_exported} to \tr{x_local}), and makes strictness
274 information propagate better.
276 If more than one exported thing is equal to a local thing (i.e., the
277 local thing really is shared), then we eliminate only the first one. Thus:
281 x_exported1 = x_local
283 x_exported2 = x_local
288 x_exported1 = ....rhs...
291 x_exported2 = x_exported1
295 We also have to watch out for
299 This can arise post lambda lifting; the original might have been
301 f = \xyz -> letrec g = [xy] \ [k] -> e
305 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
306 Then blast the whole program (LHSs as well as RHSs) with it.
309 elimIndirections :: [StgBinding] -> [StgBinding]
311 elimIndirections binds_in
312 = if isNullIdEnv blast_env then
313 binds_in -- Nothing to do
315 [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
317 lookup_fn id = case lookupIdEnv blast_env id of
318 Just new_id -> new_id
321 (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
323 try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
325 (StgNonRec exported_binder
326 (StgRhsClosure _ _ _ _
328 (StgApp (StgVarArg local_binder) fun_args _)
330 | isExported exported_binder && -- Only if this is exported
331 not (isExported local_binder) && -- Only if this one is defined in this
332 isLocallyDefined local_binder && -- module, so that we *can* change its
333 -- binding to be the exported thing!
334 not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
335 args_match lambda_args fun_args -- Just an eta-expansion
337 = (addOneToIdEnv env_so_far local_binder exported_binder,
340 args_match [] [] = True
341 args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
342 args_match _ _ = False
344 try_bind env_so_far bind
345 = (env_so_far, Just bind)
347 in_dom env id = maybeToBool (lookupIdEnv env id)
350 @renameTopStgBind@ renames top level binders and all occurrences thereof.
353 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
355 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
356 renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]