% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CostCentre]{The @CostCentre@ data type} \begin{code}

    {-# OPTIONS -fno-warn-incomplete-patterns #-}
    -- The above warning supression flag is a temporary kludge.
    -- While working on this module you are encouraged to remove it and fix
    -- any warnings in the module. See
    --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
    -- for details
    {-# LANGUAGE DeriveDataTypeable #-}

    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, pushCCisNop,

    	mkUserCC, mkAutoCC, mkAllCafsCC,
    	mkSingletonCCS, dupifyCC, pushCCOnCCS,
    	isCafCCS, isCafCC,
    	isSccCountCostCentre,
    	sccAbleCostCentre,
    	ccFromThisModule,

    	pprCostCentreCore,
    	costCentreUserName,

    	cmpCostCentre	-- used for removing dups in a list
        ) where

    import Var		( Id )
    import Name
    import Module		( Module )
    import Unique
    import Outputable
    import FastTypes
    import FastString
    import Util	        ( thenCmp )

    import Data.Data

\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.
        }
      deriving (Data, Typeable)

    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".
      deriving (Data, Typeable)

    data IsCafCC = CafCC | NotCafCC
      deriving (Data, Typeable)

    -- 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, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack

    noCCS 			= NoCCS
    subsumedCCS 		= SubsumedCCS
    currentCCS	 	= CurrentCCS
    overheadCCS	 	= OverheadCCS
    dontCareCCS	 	= DontCareCCS

    noCostCentre :: CostCentre
    noCostCentre  		= NoCostCentre

\end{code} Predicates on Cost-Centre Stacks \begin{code}

    noCCSAttached :: CostCentreStack -> Bool
    noCCSAttached NoCCS			= True
    noCCSAttached _				= False

    noCCAttached :: CostCentre -> Bool
    noCCAttached NoCostCentre		= True
    noCCAttached _				= False

    isCurrentCCS :: CostCentreStack -> Bool
    isCurrentCCS CurrentCCS			= True
    isCurrentCCS _	      			= False

    isSubsumedCCS :: CostCentreStack -> Bool
    isSubsumedCCS SubsumedCCS 		= True
    isSubsumedCCS _		     		= False

    isCafCCS :: CostCentreStack -> Bool
    isCafCCS (PushCC cc NoCCS)		= isCafCC cc
    isCafCCS _				= False

    isDerivedFromCurrentCCS :: CostCentreStack -> Bool
    isDerivedFromCurrentCCS CurrentCCS	= True
    isDerivedFromCurrentCCS (PushCC _ ccs)	= isDerivedFromCurrentCCS ccs
    isDerivedFromCurrentCCS _		= False

    currentOrSubsumedCCS :: CostCentreStack -> Bool
    currentOrSubsumedCCS SubsumedCCS	= True
    currentOrSubsumedCCS CurrentCCS		= True
    currentOrSubsumedCCS _			= False

    maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
    maybeSingletonCCS (PushCC cc NoCCS)	= Just cc
    maybeSingletonCCS _			= Nothing

    pushCCisNop :: CostCentre -> CostCentreStack -> Bool
    -- (pushCCisNop cc ccs) = True => pushing cc on ccs is a no-op
    -- It's safe to return False, but the optimiser can remove
    -- redundant pushes if this function returns True.
    pushCCisNop cc (PushCC cc' _) = cc == cc'
    pushCCisNop _ _ = False

\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 = str, cc_mod =  mod,
    	       cc_is_dupd = OriginalCC, cc_is_caf = is_caf
        }
      where
            name = getName id
            -- 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)
                | otherwise           = mkFastString $ showSDoc $
                                          ftext (occNameFS (getOccName id))
                                          <> char '_' <> pprUnique (getUnique name)
    mkAllCafsCC :: Module -> CostCentre
    mkAllCafsCC m = AllCafsCC  { cc_mod = m }

    mkSingletonCCS :: CostCentre -> CostCentreStack
    mkSingletonCCS cc = pushCCOnCCS cc NoCCS

    pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
    pushCCOnCCS = PushCC

    dupifyCC :: CostCentre -> CostCentre
    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)
        tag_CC (AllCafsCC  {}) = _ILIT(2)

    -- TODO: swap order of IsCafCC, add deriving Ord
    cmp_caf :: IsCafCC -> IsCafCC -> Ordering
    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 :: CostCentre -> SDoc
    pprCostCentreCore (AllCafsCC {cc_mod = m})
      = text "__sccC" <+> braces (ppr 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 m,
    	pp_dup dup,
    	pp_caf caf
        ])

    pp_dup :: IsDupdCC -> SDoc
    pp_dup DupdCC = char '!'
    pp_dup _      = empty

    pp_caf :: IsCafCC -> SDoc
    pp_caf CafCC = text "__C"
    pp_caf _     = empty

    -- Printing as a C label
    ppCostCentreLbl :: CostCentre -> SDoc
    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 m <> char '_' <> 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 :: CostCentre -> String
    costCentreUserName (NoCostCentre)  = "NO_CC"
    costCentreUserName (AllCafsCC {})  = "CAF"
    costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
      =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name

\end{code}