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
12 IMPORT_1_3(IO(hPutStr,stderr))
17 import LambdaLift ( liftProgram )
18 import Name ( isLocallyDefined )
19 import SCCfinal ( stgMassageForProfiling )
20 import SatStgRhs ( satStgRhs )
21 import StgLint ( lintStgBindings )
22 import StgSAT ( doStaticArgs )
23 import StgStats ( showStgStats )
24 import StgVarInfo ( setStgVarInfo )
25 import UpdAnal ( updateAnalyse )
27 import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
28 opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
31 import Id ( externallyVisibleId,
32 nullIdEnv, lookupIdEnv, addOneToIdEnv,
33 growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
34 GenId{-instance Eq/Outputable -}
36 import Maybes ( maybeToBool )
37 import PprType ( GenType{-instance Outputable-} )
38 import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
39 import UniqSupply ( splitUniqSupply )
40 import Util ( mapAccumL, panic, assertPanic )
42 unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
46 stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
47 -> FAST_STRING -- module name (profiling only)
48 -> PprStyle -- printing style (for debugging only)
49 -> UniqSupply -- a name supply
50 -> [StgBinding] -- input...
52 ([StgBinding], -- output program...
53 ([CostCentre], -- local cost-centres that need to be decl'd
54 [CostCentre])) -- "extern" cost-centres
56 stg2stg stg_todos module_name ppr_style us binds
57 = case (splitUniqSupply us) of { (us4now, us4later) ->
59 (if do_verbose_stg2stg then
60 hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
61 hPutStr stderr (ppShow 1000
62 (ppAbove (ppStr ("*** Core2Stg:"))
63 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
67 -- Do the main business!
68 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
69 >>= \ (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 return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
107 do_let_no_escapes = opt_StgDoLetNoEscapes
108 do_verbose_stg2stg = opt_D_verbose_stg2stg
110 (do_unlocalising, unlocal_tag)
111 = case (opt_EnsureSplittableC) of
112 Nothing -> (False, panic "tag")
113 Just tag -> (True, _PK_ tag)
115 grp_name = case (opt_SccGroup) of
117 Nothing -> module_name -- default: module name
120 stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
121 then lintStgBindings ppr_style
122 else ( \ whodunnit binds -> binds )
124 -------------------------------------------
125 do_stg_pass (binds, us, ccs) to_do
127 (us1, us2) = splitUniqSupply us
131 ASSERT(null (fst ccs) && null (snd ccs))
132 _scc_ "StgStaticArgs"
134 binds3 = doStaticArgs binds us1
136 end_pass us2 "StgStaticArgs" ccs binds3
138 StgDoUpdateAnalysis ->
139 ASSERT(null (fst ccs) && null (snd ccs))
141 -- NB We have to do setStgVarInfo first! (There's one
142 -- place free-var info is used) But no let-no-escapes,
143 -- because update analysis doesn't care.
144 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
147 trace (showStgStats binds)
148 end_pass us2 "StgStats" ccs binds
151 _scc_ "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
158 StgDoMassageForProfiling ->
161 (collected_CCs, binds3)
162 = stgMassageForProfiling module_name grp_name us1 binds
164 end_pass us2 "ProfMassage" collected_CCs binds3
166 end_pass us2 what ccs binds2
167 = -- report verbosely, if required
168 (if do_verbose_stg2stg then
169 hPutStr stderr (ppShow 1000
170 (ppAbove (ppStr ("*** "++what++":"))
171 (ppAboves (map (ppr ppr_style) binds2))
175 linted_binds = stg_linter what binds2
177 return (linted_binds, us2, ccs)
178 -- return: processed binds
179 -- UniqueSupply for the next guy to use
180 -- cost-centres to be declared/registered (specialised)
181 -- add to description of what's happened (reverse order)
183 -- here so it can be inlined...
184 foldl_mn f z [] = return z
185 foldl_mn f z (x:xs) = f z x >>= \ zz ->
189 %************************************************************************
191 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
193 %************************************************************************
195 The idea of all this ``unlocalise'' stuff is that in certain (prelude
196 only) modules we split up the .hc file into lots of separate little
197 files, which are separately compiled by the C compiler. That gives
198 lots of little .o files. The idea is that if you happen to mention
199 one of them you don't necessarily pull them all in. (Pulling in a
200 piece you don't need can be v bad, because it may mention other pieces
201 you don't need either, and so on.)
203 Sadly, splitting up .hc files means that local names (like s234) are
204 now globally visible, which can lead to clashes between two .hc
205 files. So unlocaliseWhatnot goes through making all the local things
206 into global things, essentially by giving them full names so when they
207 are printed they'll have their module name too. Pretty revolting
211 type UnlocalEnv = IdEnv Id
213 lookup_uenv :: UnlocalEnv -> Id -> Id
214 lookup_uenv env id = case lookupIdEnv env id of
216 Just new_id -> new_id
218 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
220 unlocaliseStgBinds mod uenv [] = (uenv, [])
222 unlocaliseStgBinds mod uenv (b : bs)
223 = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) ->
224 case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
225 (uenv3, new_b : new_bs) }}
229 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
231 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
232 = let new_uenv = case unlocaliseId mod binder of
234 Just new_binder -> addOneToIdEnv uenv binder new_binder
236 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
238 unlocal_top_bind mod uenv bind@(StgRec pairs)
239 = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
240 new_uenv = growIdEnvList uenv [ (b,new_b)
241 | (b, Just new_b) <- maybe_unlocaliseds]
243 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
246 %************************************************************************
248 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
250 %************************************************************************
252 In @elimIndirections@, we look for things at the top-level of the form...
259 In cases we find like this, we go {\em backwards} and replace
260 \tr{x_local} with \tr{...rhs...}, to produce
262 x_exported = ...rhs...
266 This saves a gratuitous jump
267 (from \tr{x_exported} to \tr{x_local}), and makes strictness
268 information propagate better.
270 If more than one exported thing is equal to a local thing (i.e., the
271 local thing really is shared), then we eliminate only the first one. Thus:
275 x_exported1 = x_local
277 x_exported2 = x_local
282 x_exported1 = ....rhs...
285 x_exported2 = x_exported1
289 We also have to watch out for
293 This can arise post lambda lifting; the original might have been
295 f = \xyz -> letrec g = [xy] \ [k] -> e
299 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
300 Then blast the whole program (LHSs as well as RHSs) with it.
303 elimIndirections :: [StgBinding] -> [StgBinding]
305 elimIndirections binds_in
306 = if isNullIdEnv blast_env then
307 binds_in -- Nothing to do
309 [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
311 lookup_fn id = case lookupIdEnv blast_env id of
312 Just new_id -> new_id
315 (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
317 try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
319 (StgNonRec exported_binder
320 (StgRhsClosure _ _ _ _
322 (StgApp (StgVarArg local_binder) fun_args _)
324 | externallyVisibleId exported_binder && -- Only if this is exported
325 not (externallyVisibleId local_binder) && -- Only if this one is defined in this
326 isLocallyDefined local_binder && -- module, so that we *can* change its
327 -- binding to be the exported thing!
328 not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
329 args_match lambda_args fun_args -- Just an eta-expansion
331 = (addOneToIdEnv env_so_far local_binder exported_binder,
334 args_match [] [] = True
335 args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
336 args_match _ _ = False
338 try_bind env_so_far bind
339 = (env_so_far, Just bind)
341 in_dom env id = maybeToBool (lookupIdEnv env id)
344 @renameTopStgBind@ renames top level binders and all occurrences thereof.
347 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
349 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
350 renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]