SCCfinal.hs 9 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

import StgSyn
25

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

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

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

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

        (fixed_ccs, fixed_cc_stacks)
ian@well-typed.com's avatar
ian@well-typed.com committed
55
          = if gopt Opt_AutoSccsOnIndividualCafs dflags
Ian Lynagh's avatar
Ian Lynagh committed
56 57 58 59 60
            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)
61
    in
Ian Lynagh's avatar
Ian Lynagh committed
62 63
    ((fixed_ccs ++ local_ccs_no_dups,
      extern_ccs_no_dups,
64
      fixed_cc_stacks ++ cc_stacks), stg_binds2)
65 66
  where

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

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

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

twanvl's avatar
twanvl committed
76 77
    do_top_bindings (StgNonRec b rhs : bs) = do
        rhs' <- do_top_rhs b rhs
78 79 80 81 82 83 84
        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')
85
      where
twanvl's avatar
twanvl committed
86 87 88
        do_pair (b, rhs) = do
             rhs2 <- do_top_rhs b rhs
             return (b, rhs2)
89 90

    ----------
91
    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
92

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

Ian Lynagh's avatar
Ian Lynagh committed
100
        -- isDllConApp checks for LitLit args too
twanvl's avatar
twanvl committed
101
      = return (StgRhsCon dontCareCCS con args)
102

103
    do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
104
      = do
twanvl's avatar
twanvl committed
105 106
        -- 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
107
        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
twanvl's avatar
twanvl committed
108 109 110 111 112 113 114 115 116 117 118 119 120
                   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
121
        body' <- do_expr body
122
        return (StgRhsClosure caf_ccs bi fv u srt [] body')
123

124
    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
125
      = do body' <- do_expr body
126
           return (StgRhsClosure dontCareCCS bi fv u srt args body')
127

Ian Lynagh's avatar
Ian Lynagh committed
128
    do_top_rhs _ (StgRhsCon _ con args)
Ian Lynagh's avatar
Ian Lynagh committed
129 130 131
        -- 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
132
      = return (StgRhsCon dontCareCCS con args)
133 134

    ------
135
    do_expr :: StgExpr -> MassageM StgExpr
136

twanvl's avatar
twanvl committed
137
    do_expr (StgLit l) = return (StgLit l)
138

139
    do_expr (StgApp fn args)
140
      = return (StgApp fn args)
141

142
    do_expr (StgConApp con args)
143
      = return (StgConApp con args)
144

145
    do_expr (StgOpApp con args res_ty)
146
      = return (StgOpApp con args res_ty)
147

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

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

158
    do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
twanvl's avatar
twanvl committed
159 160
        expr' <- do_expr expr
        alts' <- mapM do_alt alts
161
        return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
162
      where
twanvl's avatar
twanvl committed
163 164 165
        do_alt (id, bs, use_mask, e) = do
            e' <- do_expr e
            return (id, bs, use_mask, e')
166

twanvl's avatar
twanvl committed
167 168 169
    do_expr (StgLet b e) = do
          (b,e) <- do_let b e
          return (StgLet b e)
170

171
    do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
twanvl's avatar
twanvl committed
172
          (b,e) <- do_let b e
173
          return (StgLetNoEscape lvs1 lvs2 b e)
174

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

177 178
    ----------------------------------

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

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

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

209
    do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
210
        expr' <- do_expr expr
211
        return (StgRhsClosure currentCCS bi fv u srt args expr')
212

Ian Lynagh's avatar
Ian Lynagh committed
213
    do_rhs (StgRhsCon _ con args)
twanvl's avatar
twanvl committed
214
      = return (StgRhsCon currentCCS con args)
215 216


217 218
-- -----------------------------------------------------------------------------
-- Boring monad stuff for this
219

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

Austin Seipp's avatar
Austin Seipp committed
227 228 229 230
instance Functor MassageM where
      fmap = liftM

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

twanvl's avatar
twanvl committed
235 236
instance Monad MassageM where
    (>>=) = thenMM
237
    (>>)  = (*>)
238

239
-- the initMM function also returns the final CollectedCCs
240

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

245
initMM mod_name (MassageM m) = m mod_name ([],[],[])
246 247 248 249

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

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

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


collectCC :: CostCentre -> MassageM ()
Ian Lynagh's avatar
Ian Lynagh committed
260
collectCC cc
261
 = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
262
  -> if (cc `ccFromThisModule` mod_name) then
Ian Lynagh's avatar
Ian Lynagh committed
263
        ((cc : local_ccs, extern_ccs, ccss), ())
twanvl's avatar
twanvl committed
264
     else -- must declare it "extern"
Ian Lynagh's avatar
Ian Lynagh committed
265
        ((local_ccs, cc : extern_ccs, ccss), ())
266

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

276 277
collectCCS :: CostCentreStack -> MassageM ()

Ian Lynagh's avatar
Ian Lynagh committed
278
collectCCS ccs
279
 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
Ian Lynagh's avatar
Ian Lynagh committed
280 281
              -> ASSERT(not (noCCSAttached ccs))
                       ((local_ccs, extern_ccs, ccs : ccss), ())