SCCfinal.hs 8.84 KB
Newer Older
1
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
2 3
{-# LANGUAGE CPP #-}

4 5
-----------------------------------------------------------------------------
-- Modify and collect code generation for final STG program
6

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

10 11
  - Traverses the STG program collecting the cost centres. These are required
    to declare the cost centres at the start of code generation.
12

13 14
    Note: because of cross-module unfolding, some of these cost centres may be
    from other modules.
15

16 17 18
  - Puts on CAF cost-centres if the user has asked for individual CAF
    cost-centres.
-}
19 20 21

module SCCfinal ( stgMassageForProfiling ) where

22
#include "HsVersions.h"
23

24 25
import GhcPrelude

26
import StgSyn
27

Ian Lynagh's avatar
Ian Lynagh committed
28
import CostCentre       -- lots of things
Simon Marlow's avatar
Simon Marlow committed
29 30
import Id
import Name
31
import Module
32
import UniqSupply       ( UniqSupply )
twanvl's avatar
twanvl committed
33
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
34
import DynFlags
35
import CoreSyn          ( Tickish(..) )
36 37
import FastString
import SrcLoc
38
import Util
39

Austin Seipp's avatar
Austin Seipp committed
40
import Control.Monad (liftM, ap)
41

42
stgMassageForProfiling
Ian Lynagh's avatar
Ian Lynagh committed
43
        :: DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
44 45
        -> Module                       -- module name
        -> UniqSupply                   -- unique supply
46 47
        -> [StgTopBinding]              -- input
        -> (CollectedCCs, [StgTopBinding])
48

49
stgMassageForProfiling dflags mod_name _us stg_binds
50
  = let
51
        ((local_ccs, cc_stacks),
Ian Lynagh's avatar
Ian Lynagh committed
52
         stg_binds2)
53
          = initMM mod_name (do_top_bindings stg_binds)
Ian Lynagh's avatar
Ian Lynagh committed
54 55

        (fixed_ccs, fixed_cc_stacks)
ian@well-typed.com's avatar
ian@well-typed.com committed
56
          = if gopt Opt_AutoSccsOnIndividualCafs dflags
Ian Lynagh's avatar
Ian Lynagh committed
57 58 59
            then ([],[])  -- don't need "all CAFs" CC
            else ([all_cafs_cc], [all_cafs_ccs])

60
        local_ccs_no_dups  = nubSort local_ccs
61
    in
Ian Lynagh's avatar
Ian Lynagh committed
62
    ((fixed_ccs ++ local_ccs_no_dups,
63
      fixed_cc_stacks ++ cc_stacks), stg_binds2)
64 65
  where

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

    ----------
71
    do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]
72

twanvl's avatar
twanvl committed
73
    do_top_bindings [] = return []
74

75
    do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do
twanvl's avatar
twanvl committed
76
        rhs' <- do_top_rhs b rhs
77
        bs' <- do_top_bindings bs
78
        return (StgTopLifted (StgNonRec b rhs') : bs')
79

80
    do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do
81 82
        pairs2 <- mapM do_pair pairs
        bs' <- do_top_bindings bs
83
        return (StgTopLifted (StgRec pairs2) : bs')
84
      where
twanvl's avatar
twanvl committed
85 86 87
        do_pair (b, rhs) = do
             rhs2 <- do_top_rhs b rhs
             return (b, rhs2)
88

89 90 91 92
    do_top_bindings (b@StgTopStringLit{} : bs) = do
        bs' <- do_top_bindings bs
        return (b : bs')

93
    ----------
94
    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
95

96
    do_top_rhs _ (StgRhsClosure _ _ _ _ []
97
                     (StgTick (ProfNote _cc False{-not tick-} _push)
98
                              (StgConApp con args _)))
99
      | not (isDllConApp dflags mod_name con args)
Ian Lynagh's avatar
Ian Lynagh committed
100 101
        -- Trivial _scc_ around nothing but static data
        -- Eliminate _scc_ ... and turn into StgRhsCon
102

Ian Lynagh's avatar
Ian Lynagh committed
103
        -- isDllConApp checks for LitLit args too
twanvl's avatar
twanvl committed
104
      = return (StgRhsCon dontCareCCS con args)
105

106
    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
107
      = do
twanvl's avatar
twanvl committed
108 109
        -- Top level CAF without a cost centre attached
        -- Attach CAF cc (collect if individual CAF ccs)
ian@well-typed.com's avatar
ian@well-typed.com committed
110
        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
twanvl's avatar
twanvl committed
111 112 113 114 115 116 117 118 119 120 121 122 123
                   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
124
        body' <- do_expr body
125
        return (StgRhsClosure caf_ccs bi fv u [] body')
126

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

Ian Lynagh's avatar
Ian Lynagh committed
131
    do_top_rhs _ (StgRhsCon _ con args)
Ian Lynagh's avatar
Ian Lynagh committed
132 133 134
        -- Top-level (static) data is not counted in heap
        -- profiles; nor do we set CCCS from it; so we
        -- just slam in dontCareCostCentre
twanvl's avatar
twanvl committed
135
      = return (StgRhsCon dontCareCCS con args)
136 137

    ------
138
    do_expr :: StgExpr -> MassageM StgExpr
139

twanvl's avatar
twanvl committed
140
    do_expr (StgLit l) = return (StgLit l)
141

142
    do_expr (StgApp fn args)
143
      = return (StgApp fn args)
144

145 146
    do_expr (StgConApp con args ty_args)
      = return (StgConApp con args ty_args)
147

148
    do_expr (StgOpApp con args res_ty)
149
      = return (StgOpApp con args res_ty)
150

151 152
    do_expr (StgTick note@(ProfNote cc _ _) expr) = do
        -- Ha, we found a cost centre!
twanvl's avatar
twanvl committed
153 154
        collectCC cc
        expr' <- do_expr expr
155 156 157 158 159
        return (StgTick note expr')

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

161
    do_expr (StgCase expr bndr alt_type alts) = do
twanvl's avatar
twanvl committed
162 163
        expr' <- do_expr expr
        alts' <- mapM do_alt alts
164
        return (StgCase expr' bndr alt_type alts')
165
      where
166
        do_alt (id, bs, e) = do
twanvl's avatar
twanvl committed
167
            e' <- do_expr e
168
            return (id, bs, e')
169

twanvl's avatar
twanvl committed
170 171 172
    do_expr (StgLet b e) = do
          (b,e) <- do_let b e
          return (StgLet b e)
173

174
    do_expr (StgLetNoEscape b e) = do
twanvl's avatar
twanvl committed
175
          (b,e) <- do_let b e
176
          return (StgLetNoEscape b e)
177

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

180 181
    ----------------------------------

twanvl's avatar
twanvl committed
182 183
    do_let (StgNonRec b rhs) e = do
        rhs' <- do_rhs rhs
184 185 186 187 188 189 190
        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')
191
      where
twanvl's avatar
twanvl committed
192 193 194
        do_pair (b, rhs) = do
             rhs2 <- do_rhs rhs
             return (b, rhs2)
195

196
    ----------------------------------
197
    do_rhs :: StgRhs -> MassageM StgRhs
Ian Lynagh's avatar
Ian Lynagh committed
198 199
        -- We play much the same game as we did in do_top_rhs above;
        -- but we don't have to worry about cafs etc.
200

201 202 203 204 205
        -- 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.
206
    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
207
               (StgTick (ProfNote cc False{-not tick-} _push)
208
                        (StgConApp con args _)))
twanvl's avatar
twanvl committed
209
      = do collectCC cc
210
           return (StgRhsCon currentCCS con args)
211

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

Ian Lynagh's avatar
Ian Lynagh committed
216
    do_rhs (StgRhsCon _ con args)
twanvl's avatar
twanvl committed
217
      = return (StgRhsCon currentCCS con args)
218 219


220 221
-- -----------------------------------------------------------------------------
-- Boring monad stuff for this
222

twanvl's avatar
twanvl committed
223 224 225 226 227 228 229
newtype MassageM result
  = MassageM {
      unMassageM :: Module              -- module name
                 -> CollectedCCs
                 -> (CollectedCCs, result)
    }

Austin Seipp's avatar
Austin Seipp committed
230 231 232 233
instance Functor MassageM where
      fmap = liftM

instance Applicative MassageM where
234
      pure x = MassageM (\_ ccs -> (ccs, x))
Austin Seipp's avatar
Austin Seipp committed
235
      (<*>) = ap
236
      (*>) = thenMM_
Austin Seipp's avatar
Austin Seipp committed
237

twanvl's avatar
twanvl committed
238 239
instance Monad MassageM where
    (>>=) = thenMM
240
    (>>)  = (*>)
241

242
-- the initMM function also returns the final CollectedCCs
243

Ian Lynagh's avatar
Ian Lynagh committed
244
initMM :: Module        -- module name, which we may consult
245 246 247
       -> MassageM a
       -> (CollectedCCs, a)

248
initMM mod_name (MassageM m) = m mod_name ([],[])
249 250 251 252

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

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

257 258 259
thenMM_ expr cont = MassageM $ \mod ccs ->
    case unMassageM expr mod ccs of { (ccs2, _) ->
    unMassageM cont mod ccs2 }
260 261 262


collectCC :: CostCentre -> MassageM ()
Ian Lynagh's avatar
Ian Lynagh committed
263
collectCC cc
264
 = MassageM $ \mod_name (local_ccs, ccss)
265
  -> if (cc `ccFromThisModule` mod_name) then
266 267 268
        ((cc : local_ccs, ccss), ())
     else
        ((local_ccs, ccss), ())
269

270 271
-- 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
Ian Lynagh's avatar
Ian Lynagh committed
272
-- module name (eg. the special :Main module) see bug #249, #1472,
273 274
-- test prof001,prof002.
collectNewCC :: CostCentre -> MassageM ()
Ian Lynagh's avatar
Ian Lynagh committed
275
collectNewCC cc
276 277
 = MassageM $ \_mod_name (local_ccs, ccss)
              -> ((cc : local_ccs, ccss), ())
278

279 280
collectCCS :: CostCentreStack -> MassageM ()

Ian Lynagh's avatar
Ian Lynagh committed
281
collectCCS ccs
282
 = MassageM $ \_mod_name (local_ccs, ccss)
Ian Lynagh's avatar
Ian Lynagh committed
283
              -> ASSERT(not (noCCSAttached ccs))
284
                       ((local_ccs, ccs : ccss), ())