Refactor inline array allocation
[ghc.git] / compiler / codeGen / StgCmmProf.hs
index d5fa9d7..f858c5a 100644 (file)
@@ -6,38 +6,24 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module StgCmmProf (
-       initCostCentres, ccType, ccsType,
-       mkCCostCentre, mkCCostCentreStack,
+        initCostCentres, ccType, ccsType,
+        mkCCostCentre, mkCCostCentreStack,
 
-       -- Cost-centre Profiling
-       dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
+        -- Cost-centre Profiling
+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
         enterCostCentreThunk, enterCostCentreFun,
         costCentreFrom,
         curCCS, storeCurCCS,
         emitSetCCC,
 
-       saveCurrentCostCentre, restoreCurrentCostCentre,
+        saveCurrentCostCentre, restoreCurrentCostCentre,
 
-       -- Lag/drag/void stuff
-       ldvEnter, ldvEnterClosure, ldvRecordCreate
+        -- Lag/drag/void stuff
+        ldvEnter, ldvEnterClosure, ldvRecordCreate
   ) where
 
 #include "HsVersions.h"
-#include "../includes/MachDeps.h"
- -- For WORD_SIZE_IN_BITS only.
-#include "../includes/rts/Constants.h"
-       -- For LDV_CREATE_MASK, LDV_STATE_USE
-       -- which are StgWords
-#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
-       -- For REP_xxx constants, which are MachReps
 
 import StgCmmClosure
 import StgCmmUtils
@@ -54,7 +40,6 @@ import CostCentre
 import DynFlags
 import FastString
 import Module
-import Constants        -- Lots of field offsets
 import Outputable
 
 import Control.Monad
@@ -86,71 +71,69 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit
 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
 
 costCentreFrom :: DynFlags
-               -> CmmExpr      -- A closure pointer
-              -> CmmExpr       -- The cost centre from that closure
+               -> CmmExpr         -- A closure pointer
+               -> CmmExpr        -- The cost centre from that closure
 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
 
+-- | The profiling header words in a static closure
 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
--- The profiling header words in a static closure
--- Was SET_STATIC_PROF_HDR
 staticProfHdr dflags ccs
  = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
 
+-- | Profiling header words in a dynamic closure
 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
--- Profiling header words in a dynamic closure
 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
 
-initUpdFrameProf :: ByteOff -> FCode ()
--- Initialise the profiling field of an update frame
-initUpdFrameProf frame_off
-  = ifProfiling $      -- frame->header.prof.ccs = CCCS
+-- | Initialise the profiling field of an update frame
+initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf frame
+  = ifProfiling $        -- frame->header.prof.ccs = CCCS
     do dflags <- getDynFlags
-       emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags))
-                 curCCS
-       -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
-       -- is unnecessary because it is not used anyhow.
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) 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
+--         Saving and restoring the current cost centre
 ---------------------------------------------------------------------------
 
-{-     Note [Saving the current cost centre]
-       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The current cost centre is like a global register.  Like other 
+{-        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 
+        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
+        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. 
+call.
 
 The same goes for join points;
-       let j x = join-stuff
-       in blah-blah
+        let j x = join-stuff
+        in blah-blah
 We want this kind of code:
-       local_cc = CCC  -- save
-       blah-blah
-     J: 
+        local_cc = CCC  -- save
+        blah-blah
+     J:
         CCC = local_cc  -- restore
 -}
 
 saveCurrentCostCentre :: FCode (Maybe LocalReg)
-       -- Returns Nothing if profiling is off
+        -- Returns Nothing if profiling is off
 saveCurrentCostCentre
   = do dflags <- getDynFlags
-       if not (dopt Opt_SccProfilingOn dflags)
+       if not (gopt Opt_SccProfilingOn dflags)
            then return Nothing
            else do local_cc <- newTemp (ccType dflags)
                    emitAssign (CmmLocal local_cc) curCCS
                    return (Just local_cc)
 
 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
-restoreCurrentCostCentre Nothing 
+restoreCurrentCostCentre Nothing
   = return ()
 restoreCurrentCostCentre (Just local_cc)
   = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
@@ -166,7 +149,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode ()
 profDynAlloc rep ccs
   = ifProfiling $
     do dflags <- getDynFlags
-       profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs
+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) 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
@@ -175,6 +158,7 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode ()
 profAlloc words ccs
   = ifProfiling $
         do dflags <- getDynFlags
+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
            emit (addToMemE alloc_rep
                        (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
                        (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
@@ -182,14 +166,12 @@ profAlloc words ccs
                                                          mkIntExpr dflags (profHdrSize dflags)]]))
                        -- subtract the "profiling overhead", which is the
                        -- profiling header in a closure.
- where 
-        alloc_rep =  REP_CostCentreStack_mem_alloc
 
 -- -----------------------------------------------------------------------
 -- Setting the current cost centre on entry to a closure
 
 enterCostCentreThunk :: CmmExpr -> FCode ()
-enterCostCentreThunk closure = 
+enterCostCentreThunk closure =
   ifProfiling $ do
       dflags <- getDynFlags
       emit $ storeCurCCS (costCentreFrom dflags closure)
@@ -207,31 +189,31 @@ enterCostCentreFun ccs closure =
 ifProfiling :: FCode () -> FCode ()
 ifProfiling code
   = do dflags <- getDynFlags
-       if dopt Opt_SccProfilingOn dflags
+       if gopt Opt_SccProfilingOn dflags
            then code
-           else nopC
+           else return ()
 
 ifProfilingL :: DynFlags -> [a] -> [a]
 ifProfilingL dflags xs
-  | dopt Opt_SccProfilingOn dflags = xs
+  | gopt Opt_SccProfilingOn dflags = xs
   | otherwise                      = []
 
 
 ---------------------------------------------------------------
---     Initialising Cost Centres & CCSs
+--        Initialising Cost Centres & CCSs
 ---------------------------------------------------------------
 
 initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
   = do dflags <- getDynFlags
-       whenC (dopt Opt_SccProfilingOn dflags) $
+       when (gopt Opt_SccProfilingOn dflags) $
            do mapM_ emitCostCentreDecl local_CCs
               mapM_ emitCostCentreStackDecl singleton_CCSs
 
 
 emitCostCentreDecl :: CostCentre -> FCode ()
-emitCostCentreDecl cc = do 
+emitCostCentreDecl cc = do
   { dflags <- getDynFlags
   ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
                | otherwise  = zero dflags
@@ -244,26 +226,26 @@ emitCostCentreDecl cc = do
                    showPpr dflags (costCentreSrcSpan cc)
            -- XXX going via FastString to get UTF-8 encoding is silly
   ; let
-     lits = [ zero dflags,     -- StgInt ccID,
-             label,    -- char *label,
-             modl,     -- char *module,
+     lits = [ zero dflags,           -- StgInt ccID,
+              label,        -- char *label,
+              modl,        -- char *module,
               loc,      -- char *srcloc,
               zero64,   -- StgWord64 mem_alloc
               zero dflags,     -- StgWord time_ticks
               is_caf,   -- StgInt is_caf
               zero dflags      -- struct _CostCentre *link
-           ] 
+            ]
   ; emitDataLits (mkCCLabel cc) lits
   }
 
 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
-emitCostCentreStackDecl ccs 
+emitCostCentreStackDecl ccs
   = case maybeSingletonCCS ccs of
     Just cc ->
         do dflags <- getDynFlags
            let mk_lits cc = zero dflags :
                             mkCCostCentre cc :
-                            replicate (sizeof_ccs_words - 2) (zero dflags)
+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)
                 -- 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
@@ -277,13 +259,13 @@ zero dflags = mkIntCLit dflags 0
 zero64 :: CmmLit
 zero64 = CmmInt 0 W64
 
-sizeof_ccs_words :: Int
-sizeof_ccs_words 
+sizeof_ccs_words :: DynFlags -> Int
+sizeof_ccs_words dflags
     -- round up to the next word.
   | ms == 0   = ws
   | otherwise = ws + 1
   where
-   (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
 
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
@@ -291,8 +273,8 @@ sizeof_ccs_words
 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
 emitSetCCC cc tick push
  = do dflags <- getDynFlags
-      if not (dopt Opt_SccProfilingOn dflags)
-          then nopC
+      if not (gopt Opt_SccProfilingOn dflags)
+          then return ()
           else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
                   pushCostCentre tmp curCCS cc
                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
@@ -301,19 +283,19 @@ emitSetCCC cc tick push
 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
 pushCostCentre result ccs cc
   = emitRtsCallWithResult result AddrHint
-       rtsPackageId
+        rtsPackageId
         (fsLit "pushCostCentre") [(ccs,AddrHint),
-                               (CmmLit (mkCCostCentre cc), AddrHint)]
+                                (CmmLit (mkCCostCentre cc), AddrHint)]
         False
 
 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
 bumpSccCount dflags ccs
-  = addToMem REP_CostCentreStack_scc_count
-        (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
+  = addToMem (rEP_CostCentreStack_scc_count dflags)
+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
 
 -----------------------------------------------------------------------------
 --
---             Lag/drag/void stuff
+--                Lag/drag/void stuff
 --
 -----------------------------------------------------------------------------
 
@@ -327,12 +309,12 @@ staticLdvInit = zeroCLit
 -- Initial value of the LDV field in a dynamic closure
 --
 dynLdvInit :: DynFlags -> CmmExpr
-dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE  
+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
   CmmMachOp (mo_wordOr dflags) [
-      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ],
-      CmmLit (mkWordCLit dflags lDV_STATE_CREATE)
+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
   ]
-        
+
 --
 -- Initialise the LDV word of a new closure
 --
@@ -346,12 +328,13 @@ ldvRecordCreate closure = do dflags <- getDynFlags
 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 -- profiling.
 --
-ldvEnterClosure :: ClosureInfo -> FCode ()
-ldvEnterClosure closure_info = do dflags <- getDynFlags
-                                  ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
-  where tag = funTag closure_info
-        -- don't forget to substract node's tag
-  
+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
+ldvEnterClosure closure_info node_reg = do
+    dflags <- getDynFlags
+    let tag = funTag dflags closure_info
+    -- don't forget to substract node's tag
+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
+
 ldvEnter :: CmmExpr -> FCode ()
 -- Argument is a closure pointer
 ldvEnter cl_ptr = do
@@ -359,8 +342,8 @@ ldvEnter cl_ptr = do
     let -- don't forget to substract node's tag
         ldv_wd = ldvWord dflags cl_ptr
         new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                         (CmmLit (mkWordCLit dflags lDV_CREATE_MASK)))
-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE)))
+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
     ifProfiling $
          -- if (era > 0) {
          --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -370,26 +353,12 @@ ldvEnter cl_ptr = do
                      mkNop
 
 loadEra :: DynFlags -> CmmExpr
-loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
-         [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era")))
+             (cInt dflags)]
 
 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
--- Takes the address of a closure, and returns 
+-- Takes the address of a closure, and returns
 -- the address of the LDV word in the closure
 ldvWord dflags closure_ptr
     = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
-
--- LDV constants, from ghc/includes/Constants.h
-lDV_SHIFT :: Int
-lDV_SHIFT = LDV_SHIFT
---lDV_STATE_MASK :: StgWord
---lDV_STATE_MASK   = LDV_STATE_MASK
-lDV_CREATE_MASK :: StgWord
-lDV_CREATE_MASK  = LDV_CREATE_MASK
---lDV_LAST_MASK :: StgWord
---lDV_LAST_MASK    = LDV_LAST_MASK
-lDV_STATE_CREATE :: StgWord
-lDV_STATE_CREATE = LDV_STATE_CREATE
-lDV_STATE_USE :: StgWord
-lDV_STATE_USE    = LDV_STATE_USE
-