summaryrefslogtreecommitdiff
path: root/compiler/profiling/SCCfinal.hs
blob: 2b2e329841ff0d7f30ac515eb60df5c7291c5f02 (plain)
1
2
3
4
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- Modify and collect code generation for final STG program

{-
 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.

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

module SCCfinal ( stgMassageForProfiling ) where

#include "HsVersions.h"

import StgSyn

import CostCentre       -- lots of things
import Id
import Name
import Module
import UniqSupply       ( UniqSupply )
import ListSetOps       ( removeDups )
import Outputable
import DynFlags
import CoreSyn          ( Tickish(..) )
import FastString
import SrcLoc
import Util

import Control.Monad (liftM, ap)

stgMassageForProfiling
        :: DynFlags
        -> Module                       -- module name
        -> UniqSupply                   -- unique supply
        -> [StgBinding]                 -- input
        -> (CollectedCCs, [StgBinding])

stgMassageForProfiling dflags mod_name _us stg_binds
  = let
        ((local_ccs, extern_ccs, cc_stacks),
         stg_binds2)
          = initMM mod_name (do_top_bindings stg_binds)

        (fixed_ccs, fixed_cc_stacks)
          = if gopt Opt_AutoSccsOnIndividualCafs dflags
            then ([],[])  -- don't need "all CAFs" CC
            else ([all_cafs_cc], [all_cafs_ccs])

        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,
      fixed_cc_stacks ++ cc_stacks), stg_binds2)
  where

    span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
    all_cafs_cc  = mkAllCafsCC mod_name span
    all_cafs_ccs = mkSingletonCCS all_cafs_cc

    ----------
    do_top_bindings :: [StgBinding] -> MassageM [StgBinding]

    do_top_bindings [] = return []

    do_top_bindings (StgNonRec b rhs : bs) = do
        rhs' <- do_top_rhs b rhs
        bs' <- do_top_bindings bs
        return (StgNonRec b rhs' : bs')

    do_top_bindings (StgRec pairs : bs) = do
        pairs2 <- mapM do_pair pairs
        bs' <- do_top_bindings bs
        return (StgRec pairs2 : bs')
      where
        do_pair (b, rhs) = do
             rhs2 <- do_top_rhs b rhs
             return (b, rhs2)

    ----------
    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs

    do_top_rhs _ (StgRhsClosure _ _ _ _ []
                     (StgTick (ProfNote _cc False{-not tick-} _push)
                              (StgConApp con args)))
      | not (isDllConApp dflags mod_name con args)
        -- Trivial _scc_ around nothing but static data
        -- Eliminate _scc_ ... and turn into StgRhsCon

        -- isDllConApp checks for LitLit args too
      = return (StgRhsCon dontCareCCS con args)

    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
      = do
        -- Top level CAF without a cost centre attached
        -- Attach CAF cc (collect if individual CAF ccs)
        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
                   then let cc = mkAutoCC binder modl CafCC
                            ccs = mkSingletonCCS cc
                                   -- careful: the binder might be :Main.main,
                                   -- which doesn't belong to module mod_name.
                                   -- bug #249, tests prof001, prof002
                            modl | Just m <- nameModule_maybe (idName binder) = m
                                 | otherwise = mod_name
                        in do
                        collectNewCC  cc
                        collectCCS ccs
                        return ccs
                   else
                        return all_cafs_ccs
        body' <- do_expr body
        return (StgRhsClosure caf_ccs bi fv u [] body')

    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
      = do body' <- do_expr body
           return (StgRhsClosure dontCareCCS bi fv u args body')

    do_top_rhs _ (StgRhsCon _ con args)
        -- Top-level (static) data is not counted in heap
        -- profiles; nor do we set CCCS from it; so we
        -- just slam in dontCareCostCentre
      = return (StgRhsCon dontCareCCS con args)

    ------
    do_expr :: StgExpr -> MassageM StgExpr

    do_expr (StgLit l) = return (StgLit l)

    do_expr (StgApp fn args)
      = return (StgApp fn args)

    do_expr (StgConApp con args)
      = return (StgConApp con args)

    do_expr (StgOpApp con args res_ty)
      = return (StgOpApp con args res_ty)

    do_expr (StgTick note@(ProfNote cc _ _) expr) = do
        -- Ha, we found a cost centre!
        collectCC cc
        expr' <- do_expr expr
        return (StgTick note expr')

    do_expr (StgTick ti expr) = do
        expr' <- do_expr expr
        return (StgTick ti expr')

    do_expr (StgCase expr bndr alt_type alts) = do
        expr' <- do_expr expr
        alts' <- mapM do_alt alts
        return (StgCase expr' bndr alt_type alts')
      where
        do_alt (id, bs, e) = do
            e' <- do_expr e
            return (id, bs, e')

    do_expr (StgLet b e) = do
          (b,e) <- do_let b e
          return (StgLet b e)

    do_expr (StgLetNoEscape b e) = do
          (b,e) <- do_let b e
          return (StgLetNoEscape b e)

    do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)

    ----------------------------------

    do_let (StgNonRec b rhs) e = do
        rhs' <- do_rhs rhs
        e' <- do_expr e
        return (StgNonRec b rhs',e')

    do_let (StgRec pairs) e = do
        pairs' <- mapM do_pair pairs
        e' <- do_expr e
        return (StgRec pairs', e')
      where
        do_pair (b, rhs) = do
             rhs2 <- do_rhs rhs
             return (b, rhs2)

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

        -- throw away the SCC if we don't have to count entries.  This
        -- is a little bit wrong, because we're attributing the
        -- allocation of the constructor to the wrong place (XXX)
        -- We should really attach (PushCC cc CurrentCCS) to the rhs,
        -- but need to reinstate PushCC for that.
    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
               (StgTick (ProfNote cc False{-not tick-} _push)
                        (StgConApp con args)))
      = do collectCC cc
           return (StgRhsCon currentCCS con args)

    do_rhs (StgRhsClosure _ bi fv u args expr) = do
        expr' <- do_expr expr
        return (StgRhsClosure currentCCS bi fv u args expr')

    do_rhs (StgRhsCon _ con args)
      = return (StgRhsCon currentCCS con args)


-- -----------------------------------------------------------------------------
-- Boring monad stuff for this

newtype MassageM result
  = MassageM {
      unMassageM :: Module              -- module name
                 -> CollectedCCs
                 -> (CollectedCCs, result)
    }

instance Functor MassageM where
      fmap = liftM

instance Applicative MassageM where
      pure x = MassageM (\_ ccs -> (ccs, x))
      (<*>) = ap
      (*>) = thenMM_

instance Monad MassageM where
    (>>=) = thenMM
    (>>)  = (*>)

-- the initMM function also returns the final CollectedCCs

initMM :: Module        -- module name, which we may consult
       -> MassageM a
       -> (CollectedCCs, a)

initMM mod_name (MassageM m) = m mod_name ([],[],[])

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

thenMM expr cont = MassageM $ \mod ccs ->
    case unMassageM expr mod ccs of { (ccs2, result) ->
    unMassageM (cont result) mod ccs2 }

thenMM_ expr cont = MassageM $ \mod ccs ->
    case unMassageM expr mod ccs of { (ccs2, _) ->
    unMassageM cont mod ccs2 }


collectCC :: CostCentre -> MassageM ()
collectCC cc
 = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
  -> if (cc `ccFromThisModule` mod_name) then
        ((cc : local_ccs, extern_ccs, ccss), ())
     else -- must declare it "extern"
        ((local_ccs, cc : extern_ccs, ccss), ())

-- Version of collectCC used when we definitely want to declare this
-- CC as local, even if its module name is not the same as the current
-- module name (eg. the special :Main module) see bug #249, #1472,
-- test prof001,prof002.
collectNewCC :: CostCentre -> MassageM ()
collectNewCC cc
 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
              -> ((cc : local_ccs, extern_ccs, ccss), ())

collectCCS :: CostCentreStack -> MassageM ()

collectCCS ccs
 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
              -> ASSERT(not (noCCSAttached ccs))
                       ((local_ccs, extern_ccs, ccs : ccss), ())