SCCfinal.lhs 13.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
%
4
\section[SCCfinal]{Modify and collect code generation for final STG program}
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.

* Traverses the STG program collecting the cost centres. These are
  required to declare the cost centres at the start of code
  generation.

  Note: because of cross-module unfolding, some of these cost centres
  may be from other modules.  But will still have to give them
  "extern" declarations.

* Puts on CAF cost-centres if the user has asked for individual CAF
  cost-centres.

* Ditto for individual DICT cost-centres.

* Boxes top-level inherited functions passed as arguments.

* "Distributes" given cost-centres to all as-yet-unmarked RHSs.

\begin{code}
#include "HsVersions.h"

module SCCfinal ( stgMassageForProfiling ) where

30
IMP_Ubiq(){-uitous-}
31
32

import StgSyn
33
34

import CmdLineOpts	( opt_AutoSccsOnIndividualCafs,
35
			  opt_CompilingGhcInternals
36
			)
37
import CostCentre	-- lots of things
sof's avatar
sof committed
38
import Id		( idType, mkSysLocal, emptyIdSet, SYN_IE(Id) )
39
import Maybes		( maybeToBool )
40
import SrcLoc		( noSrcLoc )
41
import Type		( splitSigmaTy, getFunTy_maybe )
sof's avatar
sof committed
42
43
import UniqSupply	( getUnique, splitUniqSupply, UniqSupply )
import Unique           ( Unique )
44
import Util		( removeDups, assertPanic )
sof's avatar
sof committed
45
import Outputable	-- ToDo: rm
46
47
48
49
50

infixr 9 `thenMM`, `thenMM_`
\end{code}

\begin{code}
51
52
type CollectedCCs = ([CostCentre],	-- locally defined ones
		     [CostCentre])	-- ones needing "extern" decls
53
54

stgMassageForProfiling
55
56
57
	:: FAST_STRING -> FAST_STRING	-- module name, group name
	-> UniqSupply		    	-- unique supply
	-> [StgBinding]		    	-- input
58
	-> (CollectedCCs, [StgBinding])
59

60
stgMassageForProfiling mod_name grp_name us stg_binds
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
  = let
	((local_ccs, extern_ccs),
	 stg_binds2)
	  = initMM mod_name us (mapMM do_top_binding stg_binds)

	fixed_ccs
	  = if do_auto_sccs_on_cafs || doing_prelude
	    then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
	    else [all_cafs_cc]

	local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
	extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
    in
    ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
  where
76
    do_auto_sccs_on_cafs  = opt_AutoSccsOnIndividualCafs  -- only use!
77
    doing_prelude	  = opt_CompilingGhcInternals
78
79
80
81
82
83

    all_cafs_cc = if doing_prelude
		  then preludeCafsCostCentre
		  else mkAllCafsCC mod_name grp_name

    ----------
84
    do_top_binding :: StgBinding -> MassageM StgBinding
85

86
    do_top_binding (StgNonRec b rhs) 
87
88
89
90
91
92
93
      = do_top_rhs b rhs 		`thenMM` \ rhs' ->
	returnMM (StgNonRec b rhs')

    do_top_binding (StgRec pairs)
      = mapMM do_pair pairs		`thenMM` \ pairs2 ->
	returnMM (StgRec pairs2)
      where
94
	do_pair (b, rhs) 
95
96
97
98
	   = do_top_rhs b rhs	`thenMM` \ rhs2 ->
	     returnMM (b, rhs2)

    ----------
99
    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
100

101
102
103
104
    do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
      | not (isSccCountCostCentre cc)
	-- Trivial _scc_ around nothing but static data
	-- Eliminate _scc_ ... and turn into StgRhsCon
105
106
      = returnMM (StgRhsCon dontCareCostCentre con args)

107
108
109
110
111
112
113
114
115
116
117
118
119
    do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
      | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc)
        && not (isSccCountCostCentre cc)
	-- Top level CAF without a cost centre attached
	-- Attach and collect cc of trivial _scc_ in body
      = collectCC cc					`thenMM_`
	set_prevailing_cc cc (do_expr expr)		`thenMM`  \ expr' ->
        returnMM (StgRhsClosure cc bi fv u [] expr')

    do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body)
      | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc
	-- Top level CAF without a cost centre attached
	-- Attach CAF cc (collect if individual CAF ccs)
120
      = let
121
	    (collect, caf_cc)
122
123
124
125
126
	      = if do_auto_sccs_on_cafs then
		   (True, mkAutoCC binder mod_name grp_name IsCafCC)
		else
		   (False, all_cafs_cc)
	in
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
	(if collect then collectCC caf_cc else nopMM)	`thenMM_`
	set_prevailing_cc caf_cc (do_expr body)		`thenMM`  \ body' ->
        returnMM (StgRhsClosure caf_cc bi fv u [] body')

    do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
	-- Top level CAF with cost centre attached
	-- Should this be a CAF cc ??? Does this ever occur ???
      = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $
	collectCC cc					`thenMM_`
        set_prevailing_cc cc (do_expr body)		`thenMM` \ body' ->
	returnMM (StgRhsClosure cc bi fv u [] body')

    do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
      | not (isSccCountCostCentre cc)
	-- Top level function with trivial _scc_ in body
	-- Attach and collect cc of trivial _scc_
      = collectCC cc					`thenMM_`
	set_prevailing_cc cc (do_expr expr)		`thenMM` \ expr' ->
	returnMM (StgRhsClosure cc bi fv u args expr')
146
147

    do_top_rhs binder (StgRhsClosure cc bi fv u args body)
148
	-- Top level function, probably subsumed
149
      = let
150
151
152
153
154
155
156
	    (cc_closure, cc_body)
	      = if noCostCentreAttached cc
		then (subsumedCosts, useCurrentCostCentre)
		else (cc, cc)
        in
	set_prevailing_cc cc_body (do_expr body)	`thenMM` \ body' ->
	returnMM (StgRhsClosure cc_closure bi fv u args body')
157
158
159
160
161

    do_top_rhs binder (StgRhsCon cc con args)
	-- Top-level (static) data is not counted in heap
	-- profiles; nor do we set CCC from it; so we
	-- just slam in dontCareCostCentre
162
      = returnMM (StgRhsCon dontCareCostCentre con args)
163
164

    ------
165
    do_expr :: StgExpr -> MassageM StgExpr
166
167
168
169

    do_expr (StgApp fn args lvs)
      = boxHigherOrderArgs (StgApp fn) args lvs

170
171
    do_expr (StgCon con args lvs)
      = boxHigherOrderArgs (StgCon con) args lvs
172

173
174
    do_expr (StgPrim op args lvs)
      = boxHigherOrderArgs (StgPrim op) args lvs
175
176

    do_expr (StgSCC ty cc expr)	-- Ha, we found a cost centre!
177
178
      = collectCC cc				`thenMM_`
	set_prevailing_cc cc (do_expr expr)	`thenMM`  \ expr' ->
179
180
181
182
183
184
185
	returnMM (StgSCC ty cc expr')

    do_expr (StgCase expr fv1 fv2 uniq alts)
      = do_expr expr		`thenMM` \ expr' ->
	do_alts alts		`thenMM` \ alts' ->
	returnMM (StgCase expr' fv1 fv2 uniq alts')
      where
186
	do_alts (StgAlgAlts ty alts def) 
187
188
189
190
191
192
193
194
	  = mapMM do_alt alts 	`thenMM` \ alts' ->
	    do_deflt def	`thenMM` \ def' ->
	    returnMM (StgAlgAlts ty alts' def')
	  where
	    do_alt (id, bs, use_mask, e)
	      = do_expr e `thenMM` \ e' ->
		returnMM (id, bs, use_mask, e')

195
	do_alts (StgPrimAlts ty alts def) 
196
197
198
199
200
201
202
203
204
	  = mapMM do_alt alts	`thenMM` \ alts' ->
	    do_deflt def	`thenMM` \ def' ->
	    returnMM (StgPrimAlts ty alts' def')
	  where
	    do_alt (l,e)
	      = do_expr e `thenMM` \ e' ->
		returnMM (l,e')

	do_deflt StgNoDefault = returnMM StgNoDefault
205
	do_deflt (StgBindDefault b is_used e) 
206
207
208
209
	  = do_expr e			`thenMM` \ e' ->
	    returnMM (StgBindDefault b is_used e')

    do_expr (StgLet b e)
210
211
212
      = do_binding b		 	`thenMM` \ b' ->
	do_expr e		  	`thenMM` \ e' ->
	returnMM (StgLet b' e')
213
214

    do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
215
216
217
      = do_binding rhs			`thenMM` \ rhs' ->
	do_expr body			`thenMM` \ body' ->
	returnMM (StgLetNoEscape lvs1 lvs2 rhs' body')
218
219

    ----------
220
    do_binding :: StgBinding -> MassageM StgBinding
221

222
    do_binding (StgNonRec b rhs) 
223
224
225
226
227
228
229
230
231
232
233
      = do_rhs rhs 			`thenMM` \ rhs' ->
	returnMM (StgNonRec b rhs')

    do_binding (StgRec pairs)
      = mapMM do_pair pairs `thenMM` \ new_pairs ->
	returnMM (StgRec new_pairs)
      where
	do_pair (b, rhs)
	  = do_rhs rhs	`thenMM` \ rhs' ->
	    returnMM (b, rhs')

234
    do_rhs :: StgRhs -> MassageM StgRhs
235
	-- We play much the same game as we did in do_top_rhs above;
236
	-- but we don't have to worry about cafs etc.
237

238
239
    do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
      | not (isSccCountCostCentre cc)
240
241
242
      = collectCC cc `thenMM_`
	returnMM (StgRhsCon cc con args)

243
244
245
246
247
    do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
      | not (isSccCountCostCentre cc)
      = collectCC cc 				`thenMM_`
	set_prevailing_cc cc (do_expr expr)	`thenMM` \ expr' ->
	returnMM (StgRhsClosure cc bi fv u args expr')
248
249

    do_rhs (StgRhsClosure cc bi fv u args body)
250
251
252
      = set_prevailing_cc_maybe cc 		$ \ cc' ->
	set_lambda_cc (do_expr body)		`thenMM` \ body' ->
	returnMM (StgRhsClosure cc' bi fv u args body')
253
254

    do_rhs (StgRhsCon cc con args)
255
256
257
258
259
      = set_prevailing_cc_maybe cc 		$ \ cc' ->
        returnMM (StgRhsCon cc' con args)

      	-- ToDo: Box args and sort out any let bindings ???
      	-- Nope: maybe later? WDP 94/06
260
261
262
263
264
265
266
267
268
269
\end{code}

%************************************************************************
%*									*
\subsection{Boxing higher-order args}
%*									*
%************************************************************************

\begin{code}
boxHigherOrderArgs
270
    :: ([StgArg] -> StgLiveVars -> StgExpr)
271
272
			-- An application lacking its arguments and live-var info
    -> [StgArg]		-- arguments which we might box
273
    -> StgLiveVars	-- live var info, which we do *not* try
274
275
			-- to maintain/update (setStgVarInfo will
			-- do that)
276
    -> MassageM StgExpr
277
278

boxHigherOrderArgs almost_expr args live_vars
279
280
281
282
283
284
285
286
287
288
289
290
291
  = returnMM (almost_expr args live_vars)

{- No boxing for now ... should be moved to desugarer and preserved ... 

boxHigherOrderArgs almost_expr args live_vars
  = get_prevailing_cc			`thenMM` \ cc ->
    if (isCafCC cc || isDictCC cc) then
	-- no boxing required inside CAF/DICT cc
	-- since CAF/DICT functions are subsumed anyway
	returnMM (almost_expr args live_vars)
    else
        mapAccumMM do_arg [] args	`thenMM` \ (let_bindings, new_args) ->
        returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
292
293
  where
    ---------------
294
    do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
295

296
    do_arg bindings atom@(StgVarAtom old_var)
297
      = let
298
	    var_type = getIdUniType old_var
299
	in
300
301
302
	if toplevelishId old_var && isFunType (getTauType var_type)
	then
	    -- make a trivial let-binding for the top-level function
303
304
	    getUniqueMM		`thenMM` \ uniq ->
	    let
305
		new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
306
	    in
307
308
309
	    returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
	else
	    returnMM (bindings, atom)
310
311

    ---------------
312
    mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
313
314
315

    mk_stg_let cc (new_var, old_var) body
      = let
316
317
318
319
	    rhs_body    = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs
	    rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body
        in
	StgLet (StgNonRec new_var rhs_closure) body
320
      where
321
322
	bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
-}
323
324
325
326
327
328
329
330
331
332
333
334
335
336
\end{code}

%************************************************************************
%*									*
\subsection{Boring monad stuff for this}
%*									*
%************************************************************************

\begin{code}
type MassageM result
  =  FAST_STRING	-- module name
  -> CostCentre		-- prevailing CostCentre
			-- if none, subsumedCosts at top-level
			-- useCurrentCostCentre at nested levels
337
  -> UniqSupply
338
339
340
341
342
343
  -> CollectedCCs
  -> (CollectedCCs, result)

-- the initUs function also returns the final UniqueSupply and CollectedCCs

initMM :: FAST_STRING	-- module name, which we may consult
344
       -> UniqSupply
345
346
347
       -> MassageM a
       -> (CollectedCCs, a)

348
initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[])
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
thenMM_ :: MassageM a -> (MassageM b) -> MassageM b

thenMM expr cont mod scope_cc us ccs
  = case splitUniqSupply us	of { (s1, s2) ->
    case (expr mod scope_cc s1 ccs)    	of { (ccs2, result) ->
    cont result mod scope_cc s2 ccs2 }}

thenMM_ expr cont mod scope_cc us ccs
  = case splitUniqSupply us	of { (s1, s2) ->
    case (expr mod scope_cc s1 ccs)    	of { (ccs2, _) ->
    cont mod scope_cc s2 ccs2 }}

returnMM :: a -> MassageM a
returnMM result mod scope_cc us ccs = (ccs, result)

nopMM :: MassageM ()
nopMM mod scope_cc us ccs = (ccs, ())

mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]

mapMM f [] = returnMM []
mapMM f (m:ms)
  = f m		`thenMM` \ r  ->
    mapMM f ms	`thenMM` \ rs ->
    returnMM (r:rs)

mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])

mapAccumMM f b [] = returnMM (b, [])
mapAccumMM f b (m:ms)
  = f b m		`thenMM` \ (b2, r)  ->
    mapAccumMM f b2 ms	`thenMM` \ (b3, rs) ->
    returnMM (b3, r:rs)

getUniqueMM :: MassageM Unique
386
getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
387
388
389
\end{code}

\begin{code}
390
set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a
391
set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
392
    	-- set unconditionally
393
394
  = action mod cc_to_set_to us ccs

395
396
397
set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a
set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs
    	-- set only if a real cost centre
398
  = let
399
400
401
402
403
404
	cc_to_use
	  = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try
	    then scope_cc    -- carry on as before
	    else cc_to_try   -- use new cost centre
    in
    action cc_to_use mod cc_to_use us ccs
405

406
407
408
409
410
set_lambda_cc :: MassageM a -> MassageM a
set_lambda_cc action mod scope_cc us ccs
	-- used when moving inside a lambda;
  	-- if we were chugging along as "caf/dict" we change to "ccc"
  = let
411
	cc_to_use
412
413
414
	  = if isCafCC scope_cc || isDictCC scope_cc
	    then useCurrentCostCentre
	    else scope_cc
415
416
417
    in
    action mod cc_to_use us ccs

418

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
get_prevailing_cc :: MassageM CostCentre
get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)

\end{code}

\begin{code}
collectCC :: CostCentre -> MassageM ()

collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
  = ASSERT(not (noCostCentreAttached cc))
    ASSERT(not (currentOrSubsumedCosts cc))
    if (cc `ccFromThisModule` mod_name) then
	((cc : local_ccs, extern_ccs), ())
    else -- must declare it "extern"
	((local_ccs, cc : extern_ccs), ())
\end{code}