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 StgStats ( showStgStats )
20 import StgVarInfo ( setStgVarInfo )
21 import UpdAnal ( updateAnalyse )
24 import Id ( unlocaliseId )
27 import Maybes ( maybeToBool, Maybe(..) )
31 import StgLint ( lintStgBindings )
32 import StgSAT ( doStaticArgs )
39 stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
40 -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
41 -> FAST_STRING -- module name (profiling only)
42 -> PprStyle -- printing style (for debugging only)
43 -> SplitUniqSupply -- a name supply
44 -> [PlainStgBinding] -- input...
46 ([PlainStgBinding], -- output program...
47 ([CostCentre], -- local cost-centres that need to be decl'd
48 [CostCentre])) -- "extern" cost-centres
50 stg2stg stg_todos sw_chkr module_name ppr_style us binds
52 case (splitUniqSupply us) of { (us4now, us4later) ->
54 (if do_verbose_stg2stg then
55 writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
56 writeMn stderr (ppShow 1000
57 (ppAbove (ppStr ("*** Core2Stg:"))
58 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
60 else returnMn ()) `thenMn_`
62 -- Do the main business!
63 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
64 `thenMn` \ (processed_binds, _, cost_centres) ->
65 -- Do essential wind-up: part (a) is SatStgRhs
67 -- Not optional, because correct arity information is used by
68 -- the code generator. Afterwards do setStgVarInfo; it gives
69 -- the wrong answers if arities are subsequently changed,
70 -- which stgSatRhs might do. Furthermore, setStgVarInfo
71 -- decides about let-no-escape things, which in turn do a
72 -- better job if arities are correct, which is done by
75 case (satStgRhs processed_binds us4later) of { saturated_binds ->
77 -- Essential wind-up: part (b), eliminate indirections
79 let no_ind_binds = elimIndirections saturated_binds in
82 -- Essential wind-up: part (c), do setStgVarInfo. It has to
83 -- happen regardless, because the code generator uses its
86 -- Why does it have to happen last? Because earlier passes
87 -- may move things around, which would change the live-var
88 -- info. Also, setStgVarInfo decides about let-no-escape
89 -- things, which in turn do a better job if arities are
90 -- correct, which is done by satStgRhs.
93 -- ToDo: provide proper flag control!
95 = if not do_unlocalising
97 else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
99 returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
103 switch_is_on = switchIsOn sw_chkr
105 do_let_no_escapes = switch_is_on StgDoLetNoEscapes
106 do_verbose_stg2stg = switch_is_on D_verbose_stg2stg
108 (do_unlocalising, unlocal_tag)
109 = case (stringSwitchSet sw_chkr EnsureSplittableC) of
110 Nothing -> (False, panic "tag")
111 Just tag -> (True, _PK_ tag)
113 grp_name = case (stringSwitchSet sw_chkr SccGroup) of
115 Nothing -> module_name -- default: module name
118 stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
119 then lintStgBindings ppr_style
120 else ( \ whodunnit binds -> binds )
122 -------------------------------------------
123 do_stg_pass (binds, us, ccs) to_do
125 (us1, us2) = splitUniqSupply us
129 ASSERT(null (fst ccs) && null (snd ccs))
130 BSCC("StgStaticArgs")
132 binds3 = doStaticArgs binds us1
134 end_pass us2 "StgStaticArgs" ccs binds3
137 StgDoUpdateAnalysis ->
138 ASSERT(null (fst ccs) && null (snd ccs))
140 -- NB We have to do setStgVarInfo first! (There's one
141 -- place free-var info is used) But no let-no-escapes,
142 -- because update analysis doesn't care.
143 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
147 trace (showStgStats binds)
148 end_pass us2 "StgStats" ccs binds
151 BSCC("StgLambdaLift")
152 -- NB We have to do setStgVarInfo first!
154 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
156 end_pass us2 "LambdaLift" ccs binds3
159 StgDoMassageForProfiling ->
162 (collected_CCs, binds3)
163 = stgMassageForProfiling module_name grp_name us1 switch_is_on binds
165 end_pass us2 "ProfMassage" collected_CCs binds3
168 end_pass us2 what ccs binds2
169 = -- report verbosely, if required
170 (if do_verbose_stg2stg then
171 writeMn stderr (ppShow 1000
172 (ppAbove (ppStr ("*** "++what++":"))
173 (ppAboves (map (ppr ppr_style) binds2))
175 else returnMn ()) `thenMn_`
177 linted_binds = stg_linter what binds2
179 returnMn (linted_binds, us2, ccs)
180 -- return: processed binds
181 -- UniqueSupply for the next guy to use
182 -- cost-centres to be declared/registered (specialised)
183 -- add to description of what's happened (reverse order)
185 -- here so it can be inlined...
186 foldl_mn f z [] = returnMn z
187 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
191 %************************************************************************
193 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
195 %************************************************************************
197 The idea of all this ``unlocalise'' stuff is that in certain (prelude
198 only) modules we split up the .hc file into lots of separate little
199 files, which are separately compiled by the C compiler. That gives
200 lots of little .o files. The idea is that if you happen to mention
201 one of them you don't necessarily pull them all in. (Pulling in a
202 piece you don't need can be v bad, because it may mention other pieces
203 you don't need either, and so on.)
205 Sadly, splitting up .hc files means that local names (like s234) are
206 now globally visible, which can lead to clashes between two .hc
207 files. So unlocaliseWhatnot goes through making all the local things
208 into global things, essentially by giving them full names so when they
209 are printed they'll have their module name too. Pretty revolting
213 type UnlocalEnv = IdEnv Id
215 lookup_uenv :: UnlocalEnv -> Id -> Id
216 lookup_uenv env id = case lookupIdEnv env id of
218 Just new_id -> new_id
220 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding])
222 unlocaliseStgBinds mod uenv [] = (uenv, [])
224 unlocaliseStgBinds mod uenv (b : bs)
225 = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) ->
226 BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
227 (uenv3, new_b : new_bs)
232 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding)
234 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
235 = let new_uenv = case unlocaliseId mod binder of
237 Just new_binder -> addOneToIdEnv uenv binder new_binder
239 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
241 unlocal_top_bind mod uenv bind@(StgRec pairs)
242 = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
243 new_uenv = growIdEnvList uenv [ (b,new_b)
244 | (b, Just new_b) <- maybe_unlocaliseds]
246 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
249 %************************************************************************
251 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
253 %************************************************************************
255 In @elimIndirections@, we look for things at the top-level of the form...
262 In cases we find like this, we go {\em backwards} and replace
263 \tr{x_local} with \tr{...rhs...}, to produce
265 x_exported = ...rhs...
269 This saves a gratuitous jump
270 (from \tr{x_exported} to \tr{x_local}), and makes strictness
271 information propagate better.
273 If more than one exported thing is equal to a local thing (i.e., the
274 local thing really is shared), then we eliminate only the first one. Thus:
278 x_exported1 = x_local
280 x_exported2 = x_local
285 x_exported1 = ....rhs...
288 x_exported2 = x_exported1
292 We also have to watch out for
296 This can arise post lambda lifting; the original might have been
298 f = \xyz -> letrec g = [xy] \ [k] -> e
302 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
303 Then blast the whole program (LHSs as well as RHSs) with it.
306 elimIndirections :: [PlainStgBinding] -> [PlainStgBinding]
308 elimIndirections binds_in
309 = if isNullIdEnv blast_env then
310 binds_in -- Nothing to do
312 [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
314 lookup_fn id = case lookupIdEnv blast_env id of
315 Just new_id -> new_id
318 (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
320 try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding)
322 (StgNonRec exported_binder
323 (StgRhsClosure _ _ _ _
325 (StgApp (StgVarAtom local_binder) fun_args _)
327 | isExported exported_binder && -- Only if this is exported
328 not (isExported local_binder) && -- Only if this one is defined in this
329 isLocallyDefined local_binder && -- module, so that we *can* change its
330 -- binding to be the exported thing!
331 not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
332 args_match lambda_args fun_args -- Just an eta-expansion
334 = (addOneToIdEnv env_so_far local_binder exported_binder,
337 args_match [] [] = True
338 args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas
339 args_match _ _ = False
341 try_bind env_so_far bind
342 = (env_so_far, Just bind)
344 in_dom env id = maybeToBool (lookupIdEnv env id)
347 @renameTopStgBind@ renames top level binders and all occurrences thereof.
350 renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
352 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
353 renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]