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 MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
35 import Maybes ( maybeToBool )
36 import Name ( isExported )
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
58 case (splitUniqSupply us) of { (us4now, us4later) ->
60 (if do_verbose_stg2stg then
61 writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
62 writeMn stderr (ppShow 1000
63 (ppAbove (ppStr ("*** Core2Stg:"))
64 (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
66 else returnMn ()) `thenMn_`
68 -- Do the main business!
69 foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
70 `thenMn` \ (processed_binds, _, cost_centres) ->
71 -- Do essential wind-up: part (a) is SatStgRhs
73 -- Not optional, because correct arity information is used by
74 -- the code generator. Afterwards do setStgVarInfo; it gives
75 -- the wrong answers if arities are subsequently changed,
76 -- which stgSatRhs might do. Furthermore, setStgVarInfo
77 -- decides about let-no-escape things, which in turn do a
78 -- better job if arities are correct, which is done by
81 case (satStgRhs processed_binds us4later) of { saturated_binds ->
83 -- Essential wind-up: part (b), eliminate indirections
85 let no_ind_binds = elimIndirections saturated_binds in
88 -- Essential wind-up: part (c), do setStgVarInfo. It has to
89 -- happen regardless, because the code generator uses its
92 -- Why does it have to happen last? Because earlier passes
93 -- may move things around, which would change the live-var
94 -- info. Also, setStgVarInfo decides about let-no-escape
95 -- things, which in turn do a better job if arities are
96 -- correct, which is done by satStgRhs.
99 -- ToDo: provide proper flag control!
101 = if not do_unlocalising
103 else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
105 returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
109 do_let_no_escapes = opt_StgDoLetNoEscapes
110 do_verbose_stg2stg = opt_D_verbose_stg2stg
112 (do_unlocalising, unlocal_tag)
113 = case (opt_EnsureSplittableC) of
114 Nothing -> (False, panic "tag")
115 Just tag -> (True, _PK_ tag)
117 grp_name = case (opt_SccGroup) of
119 Nothing -> module_name -- default: module name
122 stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
123 then lintStgBindings ppr_style
124 else ( \ whodunnit binds -> binds )
126 -------------------------------------------
127 do_stg_pass (binds, us, ccs) to_do
129 (us1, us2) = splitUniqSupply us
133 ASSERT(null (fst ccs) && null (snd ccs))
134 BSCC("StgStaticArgs")
136 binds3 = doStaticArgs binds us1
138 end_pass us2 "StgStaticArgs" ccs binds3
141 StgDoUpdateAnalysis ->
142 ASSERT(null (fst ccs) && null (snd ccs))
144 -- NB We have to do setStgVarInfo first! (There's one
145 -- place free-var info is used) But no let-no-escapes,
146 -- because update analysis doesn't care.
147 end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
151 trace (showStgStats binds)
152 end_pass us2 "StgStats" ccs binds
155 BSCC("StgLambdaLift")
156 -- NB We have to do setStgVarInfo first!
158 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
160 end_pass us2 "LambdaLift" ccs binds3
163 StgDoMassageForProfiling ->
166 (collected_CCs, binds3)
167 = stgMassageForProfiling module_name grp_name us1 binds
169 end_pass us2 "ProfMassage" collected_CCs binds3
172 end_pass us2 what ccs binds2
173 = -- report verbosely, if required
174 (if do_verbose_stg2stg then
175 writeMn stderr (ppShow 1000
176 (ppAbove (ppStr ("*** "++what++":"))
177 (ppAboves (map (ppr ppr_style) binds2))
179 else returnMn ()) `thenMn_`
181 linted_binds = stg_linter what binds2
183 returnMn (linted_binds, us2, ccs)
184 -- return: processed binds
185 -- UniqueSupply for the next guy to use
186 -- cost-centres to be declared/registered (specialised)
187 -- add to description of what's happened (reverse order)
189 -- here so it can be inlined...
190 foldl_mn f z [] = returnMn z
191 foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
195 %************************************************************************
197 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
199 %************************************************************************
201 The idea of all this ``unlocalise'' stuff is that in certain (prelude
202 only) modules we split up the .hc file into lots of separate little
203 files, which are separately compiled by the C compiler. That gives
204 lots of little .o files. The idea is that if you happen to mention
205 one of them you don't necessarily pull them all in. (Pulling in a
206 piece you don't need can be v bad, because it may mention other pieces
207 you don't need either, and so on.)
209 Sadly, splitting up .hc files means that local names (like s234) are
210 now globally visible, which can lead to clashes between two .hc
211 files. So unlocaliseWhatnot goes through making all the local things
212 into global things, essentially by giving them full names so when they
213 are printed they'll have their module name too. Pretty revolting
217 type UnlocalEnv = IdEnv Id
219 lookup_uenv :: UnlocalEnv -> Id -> Id
220 lookup_uenv env id = case lookupIdEnv env id of
222 Just new_id -> new_id
224 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
226 unlocaliseStgBinds mod uenv [] = (uenv, [])
228 unlocaliseStgBinds mod uenv (b : bs)
229 = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) ->
230 BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
231 (uenv3, new_b : new_bs)
236 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
238 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
239 = let new_uenv = case unlocaliseId mod binder of
241 Just new_binder -> addOneToIdEnv uenv binder new_binder
243 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
245 unlocal_top_bind mod uenv bind@(StgRec pairs)
246 = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
247 new_uenv = growIdEnvList uenv [ (b,new_b)
248 | (b, Just new_b) <- maybe_unlocaliseds]
250 (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
253 %************************************************************************
255 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
257 %************************************************************************
259 In @elimIndirections@, we look for things at the top-level of the form...
266 In cases we find like this, we go {\em backwards} and replace
267 \tr{x_local} with \tr{...rhs...}, to produce
269 x_exported = ...rhs...
273 This saves a gratuitous jump
274 (from \tr{x_exported} to \tr{x_local}), and makes strictness
275 information propagate better.
277 If more than one exported thing is equal to a local thing (i.e., the
278 local thing really is shared), then we eliminate only the first one. Thus:
282 x_exported1 = x_local
284 x_exported2 = x_local
289 x_exported1 = ....rhs...
292 x_exported2 = x_exported1
296 We also have to watch out for
300 This can arise post lambda lifting; the original might have been
302 f = \xyz -> letrec g = [xy] \ [k] -> e
306 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
307 Then blast the whole program (LHSs as well as RHSs) with it.
310 elimIndirections :: [StgBinding] -> [StgBinding]
312 elimIndirections binds_in
313 = if isNullIdEnv blast_env then
314 binds_in -- Nothing to do
316 [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
318 lookup_fn id = case lookupIdEnv blast_env id of
319 Just new_id -> new_id
322 (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
324 try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
326 (StgNonRec exported_binder
327 (StgRhsClosure _ _ _ _
329 (StgApp (StgVarArg local_binder) fun_args _)
331 | isExported exported_binder && -- Only if this is exported
332 not (isExported local_binder) && -- Only if this one is defined in this
333 isLocallyDefined local_binder && -- module, so that we *can* change its
334 -- binding to be the exported thing!
335 not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
336 args_match lambda_args fun_args -- Just an eta-expansion
338 = (addOneToIdEnv env_so_far local_binder exported_binder,
341 args_match [] [] = True
342 args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
343 args_match _ _ = False
345 try_bind env_so_far bind
346 = (env_so_far, Just bind)
348 in_dom env id = maybeToBool (lookupIdEnv env id)
351 @renameTopStgBind@ renames top level binders and all occurrences thereof.
354 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
356 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
357 renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]