CostCentre.hs 10.5 KB
Newer Older
1
{-# LANGUAGE DeriveDataTypeable #-}
2
module CostCentre (
3
        CostCentre(..), CcName, IsCafCC(..),
4
                -- All abstract except to friend: ParseIface.y
5

6
        CostCentreStack,
7 8 9
        CollectedCCs, emptyCollectedCCs, collectCC,
        currentCCS, dontCareCCS,
        isCurrentCCS,
10
        maybeSingletonCCS,
11

12
        mkUserCC, mkAutoCC, mkAllCafsCC,
13 14
        mkSingletonCCS,
        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
15

16
        pprCostCentreCore,
17
        costCentreUserName, costCentreUserNameFS,
18
        costCentreSrcSpan,
19

20
        cmpCostCentre   -- used for removing dups in a list
21 22
    ) where

23 24
import GhcPrelude

25
import Binary
26
import Var
Simon Marlow's avatar
Simon Marlow committed
27
import Name
28
import Module
29
import Unique
30
import Outputable
31
import SrcLoc
32
import FastString
33
import Util
34 35

import Data.Data
36

37 38
-----------------------------------------------------------------------------
-- Cost Centres
39

40
-- | A Cost Centre is a single @{-# SCC #-}@ annotation.
41

42
data CostCentre
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
  = NormalCC {
                cc_key  :: {-# UNPACK #-} !Int,
                 -- ^ Two cost centres may have the same name and
                 -- module but different SrcSpans, so we need a way to
                 -- distinguish them easily and give them different
                 -- object-code labels.  So every CostCentre has a
                 -- Unique that is distinct from every other
                 -- CostCentre in the same module.
                 --
                 -- XXX: should really be using Unique here, but we
                 -- need to derive Data below and there's no Data
                 -- instance for Unique.
                cc_name :: CcName,      -- ^ Name of the cost centre itself
                cc_mod  :: Module,      -- ^ Name of module defining this CC.
                cc_loc  :: SrcSpan,
58
                cc_is_caf  :: IsCafCC   -- see below
59 60
    }

61
  | AllCafsCC {
62 63
                cc_mod  :: Module,      -- Name of module defining this CC.
                cc_loc  :: SrcSpan
64
    }
65
  deriving Data
66

67
type CcName = FastString
68

69
data IsCafCC = NotCafCC | CafCC
70
  deriving (Eq, Ord, Data)
71 72


73
instance Eq CostCentre where
74
        c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
75

76
instance Ord CostCentre where
77
        compare = cmpCostCentre
78

79
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
80

81 82
cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
  = m1 `compare` m2
83

84 85 86 87
cmpCostCentre NormalCC {cc_key = n1, cc_mod =  m1}
              NormalCC {cc_key = n2, cc_mod =  m2}
    -- first key is module name, then the integer key
  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
88

89 90
cmpCostCentre other_1 other_2
  = let
91 92
        tag1 = tag_CC other_1
        tag2 = tag_CC other_2
93
    in
94
    if tag1 < tag2 then LT else GT
95
  where
96 97 98
    tag_CC :: CostCentre -> Int
    tag_CC (NormalCC   {}) = 0
    tag_CC (AllCafsCC  {}) = 1
99 100


101 102
-----------------------------------------------------------------------------
-- Predicates on CostCentre
103

104
isCafCC :: CostCentre -> Bool
105
isCafCC (AllCafsCC {})                 = True
106
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
107
isCafCC _                              = False
sof's avatar
sof committed
108

109 110 111 112
-- | Is this a cost-centre which records scc counts
isSccCountCC :: CostCentre -> Bool
isSccCountCC cc | isCafCC cc  = False
                | otherwise   = True
113

114 115 116 117
-- | Is this a cost-centre which can be sccd ?
sccAbleCC :: CostCentre -> Bool
sccAbleCC cc | isCafCC cc = False
             | otherwise  = True
118

119 120
ccFromThisModule :: CostCentre -> Module -> Bool
ccFromThisModule cc m = cc_mod cc == m
121

122

123 124
-----------------------------------------------------------------------------
-- Building cost centres
125

126 127 128
mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
mkUserCC cc_name mod loc key
  = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
129
               cc_is_caf = NotCafCC {-might be changed-}
130
    }
131

132 133
mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
mkAutoCC id mod is_caf
134 135 136
  = NormalCC { cc_key = getKey (getUnique id),
               cc_name = str, cc_mod =  mod,
               cc_loc = nameSrcSpan (getName id),
137
               cc_is_caf = is_caf
138
    }
139
  where
Simon Marlow's avatar
Simon Marlow committed
140
        name = getName id
141 142 143 144 145
        -- beware: only external names are guaranteed to have unique
        -- Occnames.  If the name is not external, we must append its
        -- Unique.
        -- See bug #249, tests prof001, prof002,  also #2411
        str | isExternalName name = occNameFS (getOccName id)
146 147 148
            | otherwise           = occNameFS (getOccName id)
                                    `appendFS`
                                    mkFastString ('_' : show (getUnique name))
149 150
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
151

152 153
-----------------------------------------------------------------------------
-- Cost Centre Stacks
154

155 156
-- | A Cost Centre Stack is something that can be attached to a closure.
-- This is either:
157
--
158 159
--      * the current cost centre stack (CCCS)
--      * a pre-defined cost centre stack (there are several
160
--        pre-defined CCSs, see below).
161

162
data CostCentreStack
163
  = CurrentCCS          -- Pinned on a let(rec)-bound
164 165 166 167
                        -- thunk/function/constructor, this says that the
                        -- cost centre to be attached to the object, when it
                        -- is allocated, is whatever is in the
                        -- current-cost-centre-stack register.
168

169
  | DontCareCCS         -- We need a CCS to stick in static closures
170 171 172
                        -- (for data), but we *don't* expect them to
                        -- accumulate any costs.  But we still need
                        -- the placeholder.  This CCS is it.
173

174
  | SingletonCCS CostCentre
175

176
  deriving (Eq, Ord)    -- needed for Ord on CLabel
177 178


179 180 181 182 183 184
-- synonym for triple which describes the cost centre info in the generated
-- code for a module.
type CollectedCCs
  = ( [CostCentre]       -- local cost-centres that need to be decl'd
    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
    )
185

186 187 188 189 190
emptyCollectedCCs :: CollectedCCs
emptyCollectedCCs = ([], [])

collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
191

192
currentCCS, dontCareCCS :: CostCentreStack
193

194 195
currentCCS              = CurrentCCS
dontCareCCS             = DontCareCCS
196

197 198
-----------------------------------------------------------------------------
-- Predicates on Cost-Centre Stacks
199

200
isCurrentCCS :: CostCentreStack -> Bool
201 202
isCurrentCCS CurrentCCS                 = True
isCurrentCCS _                          = False
203

204 205
isCafCCS :: CostCentreStack -> Bool
isCafCCS (SingletonCCS cc)              = isCafCC cc
206
isCafCCS _                              = False
207

208 209
maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
maybeSingletonCCS (SingletonCCS cc)     = Just cc
210
maybeSingletonCCS _                     = Nothing
211

212 213
mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS cc = SingletonCCS cc
214

215

216
-----------------------------------------------------------------------------
217
-- Printing Cost Centre Stacks.
218

219 220
-- The outputable instance for CostCentreStack prints the CCS as a C
-- expression.
221

222
instance Outputable CostCentreStack where
223 224 225
  ppr CurrentCCS        = text "CCCS"
  ppr DontCareCCS       = text "CCS_DONT_CARE"
  ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
226 227


228 229
-----------------------------------------------------------------------------
-- Printing Cost Centres
230
--
231 232
-- There are several different ways in which we might want to print a
-- cost centre:
233 234 235 236 237 238
--
--      - the name of the cost centre, for profiling output (a C string)
--      - the label, i.e. C label for cost centre in .hc file.
--      - the debugging name, for output in -ddump things
--      - the interface name, for printing in _scc_ exprs in iface files.
--
239 240
-- The last 3 are derived from costCentreStr below.  The first is given
-- by costCentreName.
sof's avatar
sof committed
241

242 243
instance Outputable CostCentre where
  ppr cc = getPprStyle $ \ sty ->
244 245 246
           if codeStyle sty
           then ppCostCentreLbl cc
           else text (costCentreUserName cc)
247

248
-- Printing in Core
249
pprCostCentreCore :: CostCentre -> SDoc
250
pprCostCentreCore (AllCafsCC {cc_mod = m})
Simon Marlow's avatar
Simon Marlow committed
251
  = text "__sccC" <+> braces (ppr m)
252
pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
253
                             cc_is_caf = caf})
254
  = text "__scc" <+> braces (hsep [
255
        ppr m <> char '.' <> ftext n,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
256
        whenPprDebug (ppr key),
257
        pp_caf caf,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
258
        whenPprDebug (ppr loc)
259 260
    ])

261
pp_caf :: IsCafCC -> SDoc
262
pp_caf CafCC = text "__C"
263
pp_caf _     = empty
264 265

-- Printing as a C label
266
ppCostCentreLbl :: CostCentre -> SDoc
267
ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
268 269
ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
                           cc_is_caf = is_caf})
Ian Lynagh's avatar
Ian Lynagh committed
270
  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
271
        case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
272

273
-- This is the name to go in the user-displayed string,
274
-- recorded in the cost centre declaration
275
costCentreUserName :: CostCentre -> String
276 277 278 279 280 281 282 283
costCentreUserName = unpackFS . costCentreUserNameFS

costCentreUserNameFS :: CostCentre -> FastString
costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
  =  case is_caf of
      CafCC -> mkFastString "CAF:" `appendFS` name
      _     -> name
284 285 286

costCentreSrcSpan :: CostCentre -> SrcSpan
costCentreSrcSpan = cc_loc
287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324

instance Binary IsCafCC where
    put_ bh CafCC = do
            putByte bh 0
    put_ bh NotCafCC = do
            putByte bh 1
    get bh = do
            h <- getByte bh
            case h of
              0 -> do return CafCC
              _ -> do return NotCafCC

instance Binary CostCentre where
    put_ bh (NormalCC aa ab ac _ad ae) = do
            putByte bh 0
            put_ bh aa
            put_ bh ab
            put_ bh ac
            put_ bh ae
    put_ bh (AllCafsCC ae _af) = do
            putByte bh 1
            put_ bh ae
    get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
                      ab <- get bh
                      ac <- get bh
                      ae <- get bh
                      return (NormalCC aa ab ac noSrcSpan ae)
              _ -> do ae <- get bh
                      return (AllCafsCC ae noSrcSpan)

    -- We ignore the SrcSpans in CostCentres when we serialise them,
    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
    -- ok, because we only need the SrcSpan when declaring the
    -- CostCentre in the original module, it is not used by importing
    -- modules.