{-# OPTIONS -w #-}
-- Lots of missing type sigs etc

-----------------------------------------------------------------------------
--
-- Code generation for profiling
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmmProf (
	initCostCentres, ccType, ccsType,
	mkCCostCentre, mkCCostCentreStack,

	-- Cost-centre Profiling
	dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
	enterCostCentre, enterCostCentrePAP, enterCostCentreThunk, 
	chooseDynCostCentres, 
	costCentreFrom, 
	curCCS, curCCSAddr,
	emitSetCCC, emitCCS,

	saveCurrentCostCentre, restoreCurrentCostCentre,

	-- Lag/drag/void stuff
	ldvEnter, ldvEnterClosure, ldvRecordCreate
  ) where

#include "HsVersions.h"
#include "MachDeps.h"
 -- For WORD_SIZE_IN_BITS only.
#include "../includes/Constants.h"
	-- For LDV_CREATE_MASK, LDV_STATE_USE
	-- which are StgWords
#include "../includes/DerivedConstants.h"
	-- For REP_xxx constants, which are MachReps

import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
import SMRep

import MkZipCfgCmm
import Cmm
import TyCon	( PrimRep(..) )
import CmmUtils
import CLabel

import Id
import qualified Module
import CostCentre
import StgSyn
import StaticFlags
import FastString
import Constants	-- Lots of field offsets
import Outputable

import Data.Maybe
import Data.Char
import Control.Monad

-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
--
-----------------------------------------------------------------------------

-- Expression representing the current cost centre stack
ccsType :: CmmType 	-- Type of a cost-centre stack
ccsType = bWord

ccType :: CmmType 	-- Type of a cost centre
ccType = bWord

curCCS :: CmmExpr
curCCS = CmmLoad curCCSAddr ccsType

-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))

mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)

mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)

costCentreFrom :: CmmExpr 	-- A closure pointer
	       -> CmmExpr	-- The cost centre from that closure
costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType

staticProfHdr :: CostCentreStack -> [CmmLit]
-- The profiling header words in a static closure
-- Was SET_STATIC_PROF_HDR
staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, 
			  	  staticLdvInit]

dynProfHdr :: CmmExpr -> [CmmExpr]
-- Profiling header words in a dynamic closure
dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]

initUpdFrameProf :: CmmExpr -> FCode ()
-- Initialise the profiling field of an update frame
initUpdFrameProf frame_amode 
  = ifProfiling $	-- frame->header.prof.ccs = CCCS
    emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
	-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
	-- is unnecessary because it is not used anyhow.

---------------------------------------------------------------------------
-- 	Saving and restoring the current cost centre
---------------------------------------------------------------------------

{-	Note [Saving the current cost centre]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The current cost centre is like a global register.  Like other 
global registers, it's a caller-saves one.  But consider
	case (f x) of (p,q) -> rhs
Since 'f' may set the cost centre, we must restore it 
before resuming rhs.  So we want code like this:
	local_cc = CCC  -- save
	r = f( x )
	CCC = local_cc  -- restore
That is, we explicitly "save" the current cost centre in
a LocalReg, local_cc; and restore it after the call. The
C-- infrastructure will arrange to save local_cc across the
call. 

The same goes for join points;
	let j x = join-stuff
	in blah-blah
We want this kind of code:
	local_cc = CCC  -- save
	blah-blah
     J: 
        CCC = local_cc  -- restore
-}

saveCurrentCostCentre :: FCode (Maybe LocalReg)
	-- Returns Nothing if profiling is off
saveCurrentCostCentre
  | not opt_SccProfilingOn 
  = return Nothing
  | otherwise
  = do	{ local_cc <- newTemp ccType
	; emit (mkAssign (CmmLocal local_cc) curCCS)
	; return (Just local_cc) }

restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Nothing 
  = return ()
restoreCurrentCostCentre (Just local_cc)
  = emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))


-------------------------------------------------------------------------------
-- Recording allocation in a cost centre
-------------------------------------------------------------------------------

-- | Record the allocation of a closure.  The CmmExpr is the cost
-- centre stack to which to attribute the allocation.
profDynAlloc :: ClosureInfo -> CmmExpr -> FCode ()
profDynAlloc cl_info ccs
  = ifProfiling $
    profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs

-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
-- in words.
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc words ccs
  = ifProfiling $
    emit (addToMemE alloc_rep
		(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
	  	(CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
		  [CmmMachOp mo_wordSub [words, 
					 CmmLit (mkIntCLit profHdrSize)]]))
		-- subtract the "profiling overhead", which is the
		-- profiling header in a closure.
 where 
	alloc_rep =  REP_CostCentreStack_mem_alloc

-- ----------------------------------------------------------------------
-- Setting the cost centre in a new closure

chooseDynCostCentres :: CostCentreStack
		     -> [Id] 	 	-- Args
		     -> StgExpr		-- Body
		     -> FCode (CmmExpr, CmmExpr)
-- Called when alllcating a closure
-- Tells which cost centre to put in the object, and which
-- to blame the cost of allocation on
chooseDynCostCentres ccs args body = do
  -- Cost-centre we record in the object
  use_ccs <- emitCCS ccs

  -- Cost-centre on whom we blame the allocation
  let blame_ccs
	| null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
	| otherwise		  = use_ccs

  return (use_ccs, blame_ccs)


-- Some CostCentreStacks are a sequence of pushes on top of CCCS.
-- These pushes must be performed before we can refer to the stack in
-- an expression.
emitCCS :: CostCentreStack -> FCode CmmExpr
emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
  where
	(cc's, ccs') = decomposeCCS ccs

	push_em ccs [] = return ccs
	push_em ccs (cc:rest) = do
  	  tmp <- newTemp ccsType	
	  pushCostCentre tmp ccs cc
	  push_em (CmmReg (CmmLocal tmp)) rest

ccsExpr :: CostCentreStack -> CmmExpr
ccsExpr ccs
  | isCurrentCCS ccs = curCCS
  | otherwise        = CmmLit (mkCCostCentreStack ccs)


isBox :: StgExpr -> Bool
-- If it's an utterly trivial RHS, then it must be
-- one introduced by boxHigherOrderArgs for profiling,
-- so we charge it to "OVERHEAD".
-- This looks like a GROSS HACK to me --SDM
isBox (StgApp fun []) = True
isBox other	      = False


-- -----------------------------------------------------------------------
-- Setting the current cost centre on entry to a closure

-- For lexically scoped profiling we have to load the cost centre from
-- the closure entered, if the costs are not supposed to be inherited.
-- This is done immediately on entering the fast entry point.

-- Load current cost centre from closure, if not inherited.
-- Node is guaranteed to point to it, if profiling and not inherited.

enterCostCentre
   :: ClosureInfo 
   -> CostCentreStack
   -> StgExpr	-- The RHS of the closure
   -> FCode ()

-- We used to have a special case for bindings of form
--	f = g True
-- where g has arity 2.  The RHS is a thunk, but we don't
-- need to update it; and we want to subsume costs.
-- We don't have these sort of PAPs any more, so the special
-- case has gone away.

enterCostCentre closure_info ccs body
  = ifProfiling $
    ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
    enter_cost_centre closure_info ccs body

enter_cost_centre closure_info ccs body
  | isSubsumedCCS ccs
  = ASSERT(isToplevClosure closure_info)
    ASSERT(re_entrant)
    enter_ccs_fsub
	
  | isDerivedFromCurrentCCS ccs
  = do {
	if re_entrant && not is_box
    	  then
		enter_ccs_fun node_ccs
    	  else
	  	emit (mkStore curCCSAddr node_ccs)

	-- don't forget to bump the scc count.  This closure might have been
	-- of the form   let x = _scc_ "x" e in ...x..., which the SCCfinal
	-- pass has turned into simply  let x = e in ...x... and attached
	-- the _scc_ as PushCostCentre(x,CCCS) on the x closure.  So that
	-- we don't lose the scc counter, bump it in the entry code for x.
	-- ToDo: for a multi-push we should really bump the counter for
	-- each of the intervening CCSs, not just the top one.
       ; when (not (isCurrentCCS ccs)) $
		emit (bumpSccCount curCCS)
       }

  | isCafCCS ccs
  = ASSERT(isToplevClosure closure_info)
    ASSERT(not re_entrant)
    do	{ 	-- This is just a special case of the isDerivedFromCurrentCCS
		-- case above.  We could delete this, but it's a micro
		-- optimisation and saves a bit of code.
	  emit (mkStore curCCSAddr enc_ccs)
	; emit (bumpSccCount node_ccs)
	}

  | otherwise
  = panic "enterCostCentre"
  where
    enc_ccs    = CmmLit (mkCCostCentreStack ccs)
    re_entrant = closureReEntrant closure_info
    node_ccs   = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
    is_box     = isBox body

    -- if this is a function, then node will be tagged; we must subract the tag
    node_tag = funTag closure_info

-- set the current CCS when entering a PAP
enterCostCentrePAP :: CmmExpr -> FCode ()
enterCostCentrePAP closure = 
  ifProfiling $ do 
    enter_ccs_fun (costCentreFrom closure)
    enteringPAP 1
  
enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk closure = 
  ifProfiling $ do 
    emit $ mkStore curCCSAddr (costCentreFrom closure)

enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [(stack,AddrHint)] False
			-- ToDo: vols

enter_ccs_fsub = enteringPAP 0

-- When entering a PAP, EnterFunCCS is called by both the PAP entry
-- code and the function entry code; we don't want the function's
-- entry code to also update CCCS in the event that it was called via
-- a PAP, so we set the flag entering_PAP to indicate that we are
-- entering via a PAP.
enteringPAP :: Integer -> FCode ()
enteringPAP n
  = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
		  (CmmLit (CmmInt n cIntWidth)))

ifProfiling :: FCode () -> FCode ()
ifProfiling code
  | opt_SccProfilingOn = code
  | otherwise	       = nopC

ifProfilingL :: [a] -> [a]
ifProfilingL xs
  | opt_SccProfilingOn = xs
  | otherwise	       = []


---------------------------------------------------------------
--	Initialising Cost Centres & CCSs
---------------------------------------------------------------

initCostCentres :: CollectedCCs -> FCode CmmAGraph
-- Emit the declarations, and return code to register them
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
  = getCode $ whenC opt_SccProfilingOn $
    do	{ mapM_ emitCostCentreDecl local_CCs
  	; mapM_ emitCostCentreStackDecl  singleton_CCSs 
	; emit $ catAGraphs $ map mkRegisterCC local_CCs
	; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }


emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc = do 
  { label <- mkStringCLit (costCentreUserName cc)
  ; modl  <- mkStringCLit (Module.moduleNameString 
               	               (Module.moduleName (cc_mod cc)))
                -- All cost centres will be in the main package, since we
                -- don't normally use -auto-all or add SCCs to other packages.
                -- Hence don't emit the package name in the module here.
  ; let lits = [ zero,   	-- StgInt ccID,
	      	 label,	-- char *label,
	      	 modl,	-- char *module,
              	 zero,	-- StgWord time_ticks
              	 zero64,	-- StgWord64 mem_alloc
	      	 subsumed, -- StgInt is_caf
	      	 zero	-- struct _CostCentre *link
	       ] 
  ; emitDataLits (mkCCLabel cc) lits
  }
  where
	subsumed | isCafCC cc = mkIntCLit (ord 'c')  -- 'c' == is a CAF
		 | otherwise  = mkIntCLit (ord 'B')  -- 'B' == is boring

emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs 
  = case maybeSingletonCCS ccs of
	Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
	Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
  where
     mk_lits cc = zero : 
		  mkCCostCentre cc : 
		  replicate (sizeof_ccs_words - 2) zero
	-- Note: to avoid making any assumptions about how the
	-- C compiler (that compiles the RTS, in particular) does
	-- layouts of structs containing long-longs, simply
	-- pad out the struct with zero words until we hit the
	-- size of the overall struct (which we get via DerivedConstants.h)

zero = mkIntCLit 0
zero64 = CmmInt 0 W64

sizeof_ccs_words :: Int
sizeof_ccs_words 
    -- round up to the next word.
  | ms == 0   = ws
  | otherwise = ws + 1
  where
   (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE

-- ---------------------------------------------------------------------------
-- Registering CCs and CCSs

--   (cc)->link = CC_LIST;
--   CC_LIST = (cc);
--   (cc)->ccID = CC_ID++;

mkRegisterCC :: CostCentre -> CmmAGraph
mkRegisterCC cc
  = withTemp cInt $ \tmp -> 
    catAGraphs [
     mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
		 (CmmLoad cC_LIST bWord),
     mkStore cC_LIST cc_lit,
     mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
     mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
     mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
   ]
  where
	cc_lit = CmmLit (CmmLabel (mkCCLabel cc))

--  (ccs)->prevStack = CCS_LIST;
--  CCS_LIST = (ccs);
--  (ccs)->ccsID = CCS_ID++;

mkRegisterCCS :: CostCentreStack -> CmmAGraph
mkRegisterCCS ccs
  = withTemp cInt $ \ tmp ->
    catAGraphs [
     mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) 
			(CmmLoad cCS_LIST bWord),
     mkStore cCS_LIST ccs_lit,
     mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
     mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
     mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
   ]
  where
    ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))


cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))

cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))

-- ---------------------------------------------------------------------------
-- Set the current cost centre stack

emitSetCCC :: CostCentre -> FCode ()
emitSetCCC cc
  | not opt_SccProfilingOn = nopC
  | otherwise = do 
    tmp <- newTemp ccsType -- TODO FIXME NOW
    ASSERT( sccAbleCostCentre cc )
      pushCostCentre tmp curCCS cc
    emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
    when (isSccCountCostCentre cc) $ 
	 emit (bumpSccCount curCCS)

pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
  = emitRtsCallWithResult result AddrHint
	(sLit "PushCostCentre") [(ccs,AddrHint), 
				(CmmLit (mkCCostCentre cc), AddrHint)]
        False

bumpSccCount :: CmmExpr -> CmmAGraph
bumpSccCount ccs
  = addToMem REP_CostCentreStack_scc_count
	 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1

-----------------------------------------------------------------------------
--
--		Lag/drag/void stuff
--
-----------------------------------------------------------------------------

--
-- Initial value for the LDV field in a static closure
--
staticLdvInit :: CmmLit
staticLdvInit = zeroCLit

--
-- Initial value of the LDV field in a dynamic closure
--
dynLdvInit :: CmmExpr
dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE  
  CmmMachOp mo_wordOr [
      CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
      CmmLit (mkWordCLit lDV_STATE_CREATE)
  ]
        
--
-- Initialise the LDV word of a new closure
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit

--
-- Called when a closure is entered, marks the closure as having been "used".
-- The closure is not an 'inherently used' one.
-- The closure is not IND or IND_OLDGEN because neither is considered for LDV
-- profiling.
--
ldvEnterClosure :: ClosureInfo -> FCode ()
ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
  where tag = funTag closure_info
        -- don't forget to substract node's tag
  
ldvEnter :: CmmExpr -> FCode ()
-- Argument is a closure pointer
ldvEnter cl_ptr
  = ifProfiling $
     -- if (era > 0) {
     --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
     --                era | LDV_STATE_USE }
    emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
		(mkStore ldv_wd new_ldv_wd)
		mkNop)
  where
        -- don't forget to substract node's tag
    ldv_wd = ldvWord cl_ptr
    new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
				       (CmmLit (mkWordCLit lDV_CREATE_MASK)))
		 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))

loadEra :: CmmExpr 
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
	  [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cInt]

ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns 
-- the address of the LDV word in the closure
ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw

-- LDV constants, from ghc/includes/Constants.h
lDV_SHIFT	 = (LDV_SHIFT :: Int)
--lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
--lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)