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 Name ( isLocallyDefined )
18 import SCCfinal ( stgMassageForProfiling )
19 import SatStgRhs ( satStgRhs )
20 import StgLint ( lintStgBindings )
21 import StgSAT ( doStaticArgs )
22 import StgStats ( showStgStats )
23 import StgVarInfo ( setStgVarInfo )
24 import UpdAnal ( updateAnalyse )
26 import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
27 opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
30 import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
31 growIdEnvList, isNullIdEnv, IdEnv(..),
32 GenId{-instance Eq/Outputable -}
34 import Maybes ( maybeToBool )
35 import Name ( 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
56 = case (splitUniqSupply us) of { (us4now, us4later) ->
58 (if do_verbose_stg2stg then
59 hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
60 hPutStr stderr (ppShow 1000
61 (ppAbove (ppStr ("*** Core2Stg:"))
62 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
66 -- Do the main business!
67 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
68 >>= \ (processed_binds, _, cost_centres) ->
69 -- Do essential wind-up: part (a) is SatStgRhs
71 -- Not optional, because correct arity information is used by
72 -- the code generator. Afterwards do setStgVarInfo; it gives
73 -- the wrong answers if arities are subsequently changed,
74 -- which stgSatRhs might do. Furthermore, setStgVarInfo
75 -- decides about let-no-escape things, which in turn do a
76 -- better job if arities are correct, which is done by
79 case (satStgRhs processed_binds us4later) of { saturated_binds ->
81 -- Essential wind-up: part (b), eliminate indirections
83 let no_ind_binds = elimIndirections saturated_binds in
86 -- Essential wind-up: part (c), do setStgVarInfo. It has to
87 -- happen regardless, because the code generator uses its
90 -- Why does it have to happen last? Because earlier passes
91 -- may move things around, which would change the live-var
92 -- info. Also, setStgVarInfo decides about let-no-escape
93 -- things, which in turn do a better job if arities are
94 -- correct, which is done by satStgRhs.
97 -- ToDo: provide proper flag control!
99 = if not do_unlocalising
101 else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
103 return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
106 do_let_no_escapes = opt_StgDoLetNoEscapes
107 do_verbose_stg2stg = opt_D_verbose_stg2stg
109 (do_unlocalising, unlocal_tag)
110 = case (opt_EnsureSplittableC) of
111 Nothing -> (False, panic "tag")
112 Just tag -> (True, _PK_ tag)
114 grp_name = case (opt_SccGroup) of
116 Nothing -> module_name -- default: module name
119 stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
120 then lintStgBindings ppr_style
121 else ( \ whodunnit binds -> binds )
123 -------------------------------------------
124 do_stg_pass (binds, us, ccs) to_do
126 (us1, us2) = splitUniqSupply us
130 ASSERT(null (fst ccs) && null (snd ccs))
131 _scc_ "StgStaticArgs"
133 binds3 = doStaticArgs binds us1
135 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))
146 trace (showStgStats binds)
147 end_pass us2 "StgStats" ccs binds
150 _scc_ "StgLambdaLift"
151 -- NB We have to do setStgVarInfo first!
153 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
155 end_pass us2 "LambdaLift" ccs binds3
157 StgDoMassageForProfiling ->
160 (collected_CCs, binds3)
161 = stgMassageForProfiling module_name grp_name us1 binds
163 end_pass us2 "ProfMassage" collected_CCs binds3
165 end_pass us2 what ccs binds2
166 = -- report verbosely, if required
167 (if do_verbose_stg2stg then
168 hPutStr stderr (ppShow 1000
169 (ppAbove (ppStr ("*** "++what++":"))
170 (ppAboves (map (ppr ppr_style) binds2))
174 linted_binds = stg_linter what binds2
176 return (linted_binds, us2, ccs)
177 -- return: processed binds
178 -- UniqueSupply for the next guy to use
179 -- cost-centres to be declared/registered (specialised)
180 -- add to description of what's happened (reverse order)
182 -- here so it can be inlined...
183 foldl_mn f z [] = return z
184 foldl_mn f z (x:xs) = f z x >>= \ zz ->
188 %************************************************************************
190 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
192 %************************************************************************
194 The idea of all this ``unlocalise'' stuff is that in certain (prelude
195 only) modules we split up the .hc file into lots of separate little
196 files, which are separately compiled by the C compiler. That gives
197 lots of little .o files. The idea is that if you happen to mention
198 one of them you don't necessarily pull them all in. (Pulling in a
199 piece you don't need can be v bad, because it may mention other pieces
200 you don't need either, and so on.)
202 Sadly, splitting up .hc files means that local names (like s234) are
203 now globally visible, which can lead to clashes between two .hc
204 files. So unlocaliseWhatnot goes through making all the local things
205 into global things, essentially by giving them full names so when they
206 are printed they'll have their module name too. Pretty revolting
210 type UnlocalEnv = IdEnv Id
212 lookup_uenv :: UnlocalEnv -> Id -> Id
213 lookup_uenv env id = case lookupIdEnv env id of
215 Just new_id -> new_id
217 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
219 unlocaliseStgBinds mod uenv [] = (uenv, [])
221 unlocaliseStgBinds mod uenv (b : bs)
222 = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) ->
223 case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
224 (uenv3, new_b : new_bs) }}
228 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
230 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
231 = let new_uenv = case unlocaliseId mod binder of
233 Just new_binder -> addOneToIdEnv uenv binder new_binder
235 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
237 unlocal_top_bind mod uenv bind@(StgRec pairs)
238 = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
239 new_uenv = growIdEnvList uenv [ (b,new_b)
240 | (b, Just new_b) <- maybe_unlocaliseds]
242 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
245 %************************************************************************
247 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
249 %************************************************************************
251 In @elimIndirections@, we look for things at the top-level of the form...
258 In cases we find like this, we go {\em backwards} and replace
259 \tr{x_local} with \tr{...rhs...}, to produce
261 x_exported = ...rhs...
265 This saves a gratuitous jump
266 (from \tr{x_exported} to \tr{x_local}), and makes strictness
267 information propagate better.
269 If more than one exported thing is equal to a local thing (i.e., the
270 local thing really is shared), then we eliminate only the first one. Thus:
274 x_exported1 = x_local
276 x_exported2 = x_local
281 x_exported1 = ....rhs...
284 x_exported2 = x_exported1
288 We also have to watch out for
292 This can arise post lambda lifting; the original might have been
294 f = \xyz -> letrec g = [xy] \ [k] -> e
298 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
299 Then blast the whole program (LHSs as well as RHSs) with it.
302 elimIndirections :: [StgBinding] -> [StgBinding]
304 elimIndirections binds_in
305 = if isNullIdEnv blast_env then
306 binds_in -- Nothing to do
308 [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
310 lookup_fn id = case lookupIdEnv blast_env id of
311 Just new_id -> new_id
314 (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
316 try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
318 (StgNonRec exported_binder
319 (StgRhsClosure _ _ _ _
321 (StgApp (StgVarArg local_binder) fun_args _)
323 | isExported exported_binder && -- Only if this is exported
324 not (isExported local_binder) && -- Only if this one is defined in this
325 isLocallyDefined local_binder && -- module, so that we *can* change its
326 -- binding to be the exported thing!
327 not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
328 args_match lambda_args fun_args -- Just an eta-expansion
330 = (addOneToIdEnv env_so_far local_binder exported_binder,
333 args_match [] [] = True
334 args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
335 args_match _ _ = False
337 try_bind env_so_far bind
338 = (env_so_far, Just bind)
340 in_dom env id = maybeToBool (lookupIdEnv env id)
343 @renameTopStgBind@ renames top level binders and all occurrences thereof.
346 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
348 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
349 renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]