{-# 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

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

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
    )

noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack

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

noCostCentre :: CostCentre
noCostCentre  		= NoCostCentre

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

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

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)

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)

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