SCCfinal.lhs 8.71 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
%
4 5 6
\begin{code}
-----------------------------------------------------------------------------
-- Modify and collect code generation for final STG program
7

8 9 10 11 12 13 14 15 16 17 18 19
{-
 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.
-}
20 21 22

module SCCfinal ( stgMassageForProfiling ) where

23
#include "HsVersions.h"
24 25

import StgSyn
26

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

38

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

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

        (fixed_ccs, fixed_cc_stacks)
Ian Lynagh's avatar
Ian Lynagh committed
53
          = if dopt Opt_AutoSccsOnIndividualCafs dflags
Ian Lynagh's avatar
Ian Lynagh committed
54 55 56 57 58
            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)
59
    in
Ian Lynagh's avatar
Ian Lynagh committed
60 61
    ((fixed_ccs ++ local_ccs_no_dups,
      extern_ccs_no_dups,
62
      fixed_cc_stacks ++ cc_stacks), stg_binds2)
63 64
  where

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

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

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

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

    ----------
89
    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
90

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

Ian Lynagh's avatar
Ian Lynagh committed
97
        -- isDllConApp checks for LitLit args too
twanvl's avatar
twanvl committed
98
      = return (StgRhsCon dontCareCCS con args)
99

100 101
    do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
      = do
twanvl's avatar
twanvl committed
102 103
        -- Top level CAF without a cost centre attached
        -- Attach CAF cc (collect if individual CAF ccs)
Ian Lynagh's avatar
Ian Lynagh committed
104
        caf_ccs <- if dopt Opt_AutoSccsOnIndividualCafs dflags
twanvl's avatar
twanvl committed
105 106 107 108 109 110 111 112 113 114 115 116 117
                   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
118
        body' <- do_expr body
twanvl's avatar
twanvl committed
119
        return (StgRhsClosure caf_ccs bi fv u srt [] body')
120

121 122 123
    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
      = do body' <- do_expr body
           return (StgRhsClosure dontCareCCS bi fv u srt args body')
124

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

    ------
132
    do_expr :: StgExpr -> MassageM StgExpr
133

twanvl's avatar
twanvl committed
134
    do_expr (StgLit l) = return (StgLit l)
135

136
    do_expr (StgApp fn args)
137
      = return (StgApp fn args)
138

139
    do_expr (StgConApp con args)
140
      = return (StgConApp con args)
141

142
    do_expr (StgOpApp con args res_ty)
143
      = return (StgOpApp con args res_ty)
144

145
    do_expr (StgSCC cc tick push expr) = do -- Ha, we found a cost centre!
twanvl's avatar
twanvl committed
146 147
        collectCC cc
        expr' <- do_expr expr
148
        return (StgSCC cc tick push expr')
149

twanvl's avatar
twanvl committed
150 151 152 153
    do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
        expr' <- do_expr expr
        alts' <- mapM do_alt alts
        return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
154
      where
twanvl's avatar
twanvl committed
155 156 157
        do_alt (id, bs, use_mask, e) = do
            e' <- do_expr e
            return (id, bs, use_mask, e')
158

twanvl's avatar
twanvl committed
159 160 161
    do_expr (StgLet b e) = do
          (b,e) <- do_let b e
          return (StgLet b e)
162

twanvl's avatar
twanvl committed
163 164 165
    do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
          (b,e) <- do_let b e
          return (StgLetNoEscape lvs1 lvs2 b e)
166

twanvl's avatar
twanvl committed
167 168 169
    do_expr (StgTick m n expr) = do
          expr' <- do_expr expr
          return (StgTick m n expr')
andy@galois.com's avatar
andy@galois.com committed
170

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

173 174
    ----------------------------------

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

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

194 195 196 197 198 199 200
        -- 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 _srt []
               (StgSCC cc False{-not tick-} _push (StgConApp con args)))
twanvl's avatar
twanvl committed
201
      = do collectCC cc
202
           return (StgRhsCon currentCCS con args)
203

twanvl's avatar
twanvl committed
204
    do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
205 206
        expr' <- do_expr expr
        return (StgRhsClosure currentCCS bi fv u srt args expr')
207

Ian Lynagh's avatar
Ian Lynagh committed
208
    do_rhs (StgRhsCon _ con args)
twanvl's avatar
twanvl committed
209
      = return (StgRhsCon currentCCS con args)
210 211


212 213
-- -----------------------------------------------------------------------------
-- Boring monad stuff for this
214

twanvl's avatar
twanvl committed
215 216 217 218 219 220 221 222
newtype MassageM result
  = MassageM {
      unMassageM :: Module              -- module name
                 -> CollectedCCs
                 -> (CollectedCCs, result)
    }

instance Monad MassageM where
223
    return x = MassageM (\_ ccs -> (ccs, x))
twanvl's avatar
twanvl committed
224 225
    (>>=) = thenMM
    (>>)  = thenMM_
226

227
-- the initMM function also returns the final CollectedCCs
228

Ian Lynagh's avatar
Ian Lynagh committed
229
initMM :: Module        -- module name, which we may consult
230 231 232
       -> MassageM a
       -> (CollectedCCs, a)

233
initMM mod_name (MassageM m) = m mod_name ([],[],[])
234 235 236 237

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

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

242 243 244
thenMM_ expr cont = MassageM $ \mod ccs ->
    case unMassageM expr mod ccs of { (ccs2, _) ->
    unMassageM cont mod ccs2 }
245 246 247


collectCC :: CostCentre -> MassageM ()
Ian Lynagh's avatar
Ian Lynagh committed
248
collectCC cc
249
 = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
250
  -> if (cc `ccFromThisModule` mod_name) then
Ian Lynagh's avatar
Ian Lynagh committed
251
        ((cc : local_ccs, extern_ccs, ccss), ())
twanvl's avatar
twanvl committed
252
     else -- must declare it "extern"
Ian Lynagh's avatar
Ian Lynagh committed
253
        ((local_ccs, cc : extern_ccs, ccss), ())
254

255 256
-- 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
257
-- module name (eg. the special :Main module) see bug #249, #1472,
258 259
-- test prof001,prof002.
collectNewCC :: CostCentre -> MassageM ()
Ian Lynagh's avatar
Ian Lynagh committed
260
collectNewCC cc
261
 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
Ian Lynagh's avatar
Ian Lynagh committed
262
              -> ((cc : local_ccs, extern_ccs, ccss), ())
263

264 265
collectCCS :: CostCentreStack -> MassageM ()

Ian Lynagh's avatar
Ian Lynagh committed
266
collectCCS ccs
267
 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
Ian Lynagh's avatar
Ian Lynagh committed
268 269
              -> ASSERT(not (noCCSAttached ccs))
                       ((local_ccs, extern_ccs, ccs : ccss), ())
270
\end{code}