+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CostCentre]{The @CostCentre@ data type}
-
-\begin{code}
-module CostCentre (
- CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
- -- All abstract except to friend: ParseIface.y
-
- CostCentreStack,
- CollectedCCs,
- noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
- noCostCentre, noCCAttached,
- noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
- isDerivedFromCurrentCCS, maybeSingletonCCS,
- decomposeCCS,
-
- mkUserCC, mkAutoCC, mkAllCafsCC,
- mkSingletonCCS, dupifyCC, pushCCOnCCS,
- isCafCCS, isCafCC,
- isSccCountCostCentre,
- sccAbleCostCentre,
- ccFromThisModule,
-
- pprCostCentreCore,
- costCentreUserName,
-
- cmpCostCentre -- used for removing dups in a list
- ) where
-
-#include "HsVersions.h"
-
-import Var ( Id )
-import Name ( getOccName, occNameFS )
-import Module ( Module, moduleFS )
-import Outputable
-import FastTypes
-import FastString
-import Util ( thenCmp )
-\end{code}
-
-A Cost Centre Stack is something that can be attached to a closure.
-This is either:
-
- - the current cost centre stack (CCCS)
- - a pre-defined cost centre stack (there are several
- pre-defined CCSs, see below).
-
-\begin{code}
-data CostCentreStack
- = NoCCS
-
- | CurrentCCS -- Pinned on a let(rec)-bound
- -- 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.
-
- | SubsumedCCS -- Cost centre stack for top-level subsumed functions
- -- (CAFs get an AllCafsCC).
- -- Its execution costs get subsumed into the caller.
- -- This guy is *only* ever pinned on static closures,
- -- and is *never* the cost centre for an SCC construct.
-
- | OverheadCCS -- We charge costs due to the profiling-system
- -- doing its work to "overhead".
- --
- -- Objects whose CCS is "Overhead"
- -- have their *allocation* charged to "overhead",
- -- but have the current CCS put into the object
- -- itself.
-
- -- For example, if we transform "f g" to "let
- -- g' = g in f g'" (so that something about
- -- profiling works better...), then we charge
- -- the *allocation* of g' to OverheadCCS, but
- -- we put the cost-centre of the call to f
- -- (i.e., current CCS) into the g' object. When
- -- g' is entered, the CCS of the call
- -- to f will be set.
-
- | DontCareCCS -- We need a CCS to stick in static closures
- -- (for data), but we *don't* expect them to
- -- accumulate any costs. But we still need
- -- the placeholder. This CCS is it.
-
- | PushCC CostCentre CostCentreStack
- -- These are used during code generation as the CCSs
- -- attached to closures. A PushCC never appears as
- -- the argument to an _scc_.
- --
- -- The tail (2nd argument) is either NoCCS, indicating
- -- a staticly allocated CCS, or CurrentCCS indicating
- -- a dynamically created CCS. We only support
- -- statically allocated *singleton* CCSs at the
- -- moment, for the purposes of initialising the CCS
- -- field of a CAF.
-
- deriving (Eq, Ord) -- needed for Ord on CLabel
-\end{code}
-
-A Cost Centre is the argument of an _scc_ expression.
-
-\begin{code}
-data CostCentre
- = NoCostCentre -- Having this constructor avoids having
- -- to use "Maybe CostCentre" all the time.
-
- | NormalCC {
- cc_name :: CcName, -- Name of the cost centre itself
- cc_mod :: Module, -- Name of module defining this CC.
- cc_is_dupd :: IsDupdCC, -- see below
- cc_is_caf :: IsCafCC -- see below
- }
-
- | AllCafsCC {
- cc_mod :: Module -- Name of module defining this CC.
- }
-
-type CcName = FastString
-
-data IsDupdCC
- = OriginalCC -- This says how the CC is *used*. Saying that
- | DupdCC -- it is DupdCC doesn't make it a different
- -- CC, just that it a sub-expression which has
- -- been moved ("dupd") into a different scope.
- --
- -- The point about a dupd SCC is that we don't
- -- count entries to it, because it's not the
- -- "original" one.
- --
- -- In the papers, it's called "SCCsub",
- -- i.e. SCCsub CC == SCC DupdCC,
- -- but we are trying to avoid confusion between
- -- "subd" and "subsumed". So we call the former
- -- "dupd".
-
-data IsCafCC = CafCC | NotCafCC
-
--- 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
- , [CostCentre] -- "extern" cost-centres
- , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
- )
-\end{code}
-
-WILL: Would there be any merit to recording ``I am now using a
-cost-centre from another module''? I don't know if this would help a
-user; it might be interesting to us to know how much computation is
-being moved across module boundaries.
-
-SIMON: Maybe later...
-
-\begin{code}
-
-noCCS = NoCCS
-subsumedCCS = SubsumedCCS
-currentCCS = CurrentCCS
-overheadCCS = OverheadCCS
-dontCareCCS = DontCareCCS
-
-noCostCentre = NoCostCentre
-\end{code}
-
-Predicates on Cost-Centre Stacks
-
-\begin{code}
-noCCSAttached NoCCS = True
-noCCSAttached _ = False
-
-noCCAttached NoCostCentre = True
-noCCAttached _ = False
-
-isCurrentCCS CurrentCCS = True
-isCurrentCCS _ = False
-
-isSubsumedCCS SubsumedCCS = True
-isSubsumedCCS _ = False
-
-isCafCCS (PushCC cc NoCCS) = isCafCC cc
-isCafCCS _ = False
-
-isDerivedFromCurrentCCS CurrentCCS = True
-isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs
-isDerivedFromCurrentCCS _ = False
-
-currentOrSubsumedCCS SubsumedCCS = True
-currentOrSubsumedCCS CurrentCCS = True
-currentOrSubsumedCCS _ = False
-
-maybeSingletonCCS (PushCC cc NoCCS) = Just cc
-maybeSingletonCCS _ = Nothing
-\end{code}
-
-Building cost centres
-
-\begin{code}
-mkUserCC :: FastString -> Module -> CostCentre
-mkUserCC cc_name mod
- = NormalCC { cc_name = cc_name, cc_mod = mod,
- cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
- }
-
-mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
-mkAutoCC id mod is_caf
- = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = mod,
- cc_is_dupd = OriginalCC, cc_is_caf = is_caf
- }
-
-mkAllCafsCC m = AllCafsCC { cc_mod = m }
-
-
-
-mkSingletonCCS :: CostCentre -> CostCentreStack
-mkSingletonCCS cc = pushCCOnCCS cc NoCCS
-
-pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
-pushCCOnCCS = PushCC
-
-dupifyCC cc = cc {cc_is_dupd = DupdCC}
-
-isCafCC, isDupdCC :: CostCentre -> Bool
-
-isCafCC (AllCafsCC {}) = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _ = False
-
-isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
-isDupdCC _ = False
-
-isSccCountCostCentre :: CostCentre -> Bool
- -- Is this a cost-centre which records scc counts
-
-#if DEBUG
-isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
-#endif
-isSccCountCostCentre cc | isCafCC cc = False
- | isDupdCC cc = False
- | otherwise = True
-
-sccAbleCostCentre :: CostCentre -> Bool
- -- Is this a cost-centre which can be sccd ?
-
-#if DEBUG
-sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
-#endif
-sccAbleCostCentre cc | isCafCC cc = False
- | otherwise = True
-
-ccFromThisModule :: CostCentre -> Module -> Bool
-ccFromThisModule cc m = cc_mod cc == m
-\end{code}
-
-\begin{code}
-instance Eq CostCentre where
- c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
-
-instance Ord CostCentre where
- compare = cmpCostCentre
-
-cmpCostCentre :: CostCentre -> CostCentre -> Ordering
-
-cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
-
-cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
- (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
- -- first key is module name, then we use "kinds" (which include
- -- names) and finally the caf flag
- = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
-
-cmpCostCentre other_1 other_2
- = let
- tag1 = tag_CC other_1
- tag2 = tag_CC other_2
- in
- if tag1 <# tag2 then LT else GT
- where
- tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt)
- tag_CC (AllCafsCC {}) = _ILIT 2
-
-cmp_caf NotCafCC CafCC = LT
-cmp_caf NotCafCC NotCafCC = EQ
-cmp_caf CafCC CafCC = EQ
-cmp_caf CafCC NotCafCC = GT
-
-decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
-decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
- where (more,ccs') = decomposeCCS ccs
-decomposeCCS ccs = ([],ccs)
-\end{code}
-
------------------------------------------------------------------------------
-Printing Cost Centre Stacks.
-
-The outputable instance for CostCentreStack prints the CCS as a C
-expression.
-
-NOTE: Not all cost centres are suitable for using in a static
-initializer. In particular, the PushCC forms where the tail is CCCS
-may only be used in inline C code because they expand to a
-non-constant C expression.
-
-\begin{code}
-instance Outputable CostCentreStack where
- ppr NoCCS = ptext SLIT("NO_CCS")
- ppr CurrentCCS = ptext SLIT("CCCS")
- ppr OverheadCCS = ptext SLIT("CCS_OVERHEAD")
- ppr DontCareCCS = ptext SLIT("CCS_DONT_CARE")
- ppr SubsumedCCS = ptext SLIT("CCS_SUBSUMED")
- ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
- ppr (PushCC cc ccs) = ptext SLIT("PushCostCentre") <>
- parens (ppr ccs <> comma <>
- parens(ptext SLIT("void *")) <> ppr cc)
-\end{code}
-
------------------------------------------------------------------------------
-Printing Cost Centres.
-
-There are several different ways in which we might want to print a
-cost centre:
-
- - 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.
-
-The last 3 are derived from costCentreStr below. The first is given
-by costCentreName.
-
-\begin{code}
-instance Outputable CostCentre where
- ppr cc = getPprStyle $ \ sty ->
- if codeStyle sty
- then ppCostCentreLbl cc
- else text (costCentreUserName cc)
-
--- Printing in an interface file or in Core generally
-pprCostCentreCore (AllCafsCC {cc_mod = m})
- = text "__sccC" <+> braces (ppr_mod m)
-pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
- cc_is_caf = caf, cc_is_dupd = dup})
- = text "__scc" <+> braces (hsep [
- ftext (zEncodeFS n),
- ppr_mod m,
- pp_dup dup,
- pp_caf caf
- ])
-
-pp_dup DupdCC = char '!'
-pp_dup other = empty
-
-pp_caf CafCC = text "__C"
-pp_caf other = empty
-
-ppr_mod m = ftext (zEncodeFS (moduleFS m))
-
--- Printing as a C label
-ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
-ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
-ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
- = ppr_mod m <> ftext (zEncodeFS n) <>
- text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
-
--- This is the name to go in the user-displayed string,
--- recorded in the cost centre declaration
-costCentreUserName (NoCostCentre) = "NO_CC"
-costCentreUserName (AllCafsCC {}) = "CAF"
-costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
- = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ unpackFS name
-\end{code}
projects / ghc-hetmet.git / blobdiff