Use DynFlags to work out if we are doing ticky ticky profiling
authorIan Lynagh <igloo@earth.li>
Thu, 18 Dec 2008 16:19:28 +0000 (16:19 +0000)
committerIan Lynagh <igloo@earth.li>
Thu, 18 Dec 2008 16:19:28 +0000 (16:19 +0000)
We used to use StaticFlags

compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/CgTicky.hs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmTicky.hs
compiler/main/DynFlags.hs
compiler/main/StaticFlags.hs

index 18879a3..56f2847 100644 (file)
@@ -395,8 +395,10 @@ thunkWrapper closure_info thunk_code = do
 
         -- Stack and/or heap checks
   ; thunkEntryChecks closure_info $ do
 
         -- Stack and/or heap checks
   ; thunkEntryChecks closure_info $ do
-       {       -- Overwrite with black hole if necessary
-         whenC (blackHoleOnEntry closure_info && node_points)
+       {
+          dflags <- getDynFlags
+          -- Overwrite with black hole if necessary
+       ; whenC (blackHoleOnEntry dflags closure_info && node_points)
                (blackHoleIt closure_info)
        ; setupUpdate closure_info thunk_code }
                -- setupUpdate *encloses* the thunk_code
                (blackHoleIt closure_info)
        ; setupUpdate closure_info thunk_code }
                -- setupUpdate *encloses* the thunk_code
index 6f8fd04..e4f79a7 100644 (file)
@@ -108,7 +108,8 @@ performTailCall fun_info arg_amodes pending_assts
                            | otherwise                 = noStmts
        ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
 
                            | otherwise                 = noStmts
        ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
 
-       ; case (getCallMethod fun_name fun_has_cafs lf_info (length arg_amodes)) of
+       ; dflags <- getDynFlags
+       ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
 
            -- Node must always point to things we enter
            EnterIt -> do
 
            -- Node must always point to things we enter
            EnterIt -> do
index 5422127..27af446 100644 (file)
@@ -69,6 +69,8 @@ import PrelNames
 import TcType
 import TyCon
 
 import TcType
 import TyCon
 
+import DynFlags
+
 import Data.Maybe
 
 -----------------------------------------------------------------------------
 import Data.Maybe
 
 -----------------------------------------------------------------------------
@@ -298,9 +300,9 @@ tickyAllocHeap hp
 -- Ticky utils
 
 ifTicky :: Code -> Code
 -- Ticky utils
 
 ifTicky :: Code -> Code
-ifTicky code
-  | opt_DoTickyProfiling = code
-  | otherwise           = nopC
+ifTicky code = do dflags <- getDynFlags
+                  if doingTickyProfiling dflags then code
+                                                else nopC
 
 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
 
 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
index 0620099..d819873 100644 (file)
@@ -88,6 +88,7 @@ import BasicTypes
 import FastString
 import Outputable
 import Constants
 import FastString
 import Outputable
 import Constants
+import DynFlags
 \end{code}
 
 
 \end{code}
 
 
@@ -576,37 +577,38 @@ data CallMethod
        CLabel                          --   The code label
        Int                             --   Its arity
 
        CLabel                          --   The code label
        Int                             --   Its arity
 
-getCallMethod :: Name          -- Function being applied
+getCallMethod :: DynFlags
+              -> Name          -- Function being applied
               -> CafInfo        -- Can it refer to CAF's?
              -> LambdaFormInfo -- Its info
              -> Int            -- Number of available arguments
              -> CallMethod
 
               -> CafInfo        -- Can it refer to CAF's?
              -> LambdaFormInfo -- Its info
              -> Int            -- Number of available arguments
              -> CallMethod
 
-getCallMethod name _ lf_info n_args
+getCallMethod _ name _ lf_info n_args
   | nodeMustPointToIt lf_info && opt_Parallel
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
     EnterIt
 
   | nodeMustPointToIt lf_info && opt_Parallel
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
     EnterIt
 
-getCallMethod name caf (LFReEntrant _ arity _ _) n_args
+getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
   | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt   -- No args at all
   | n_args < arity = SlowCall  -- Not enough args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
   | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt   -- No args at all
   | n_args < arity = SlowCall  -- Not enough args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
-getCallMethod name _ (LFCon con) n_args
+getCallMethod _ name _ (LFCon con) n_args
   = ASSERT( n_args == 0 )
     ReturnCon con
 
   = ASSERT( n_args == 0 )
     ReturnCon con
 
-getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
   | is_fun     -- it *might* be a function, so we must "call" it (which is
                 -- always safe)
   = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
   | is_fun     -- it *might* be a function, so we must "call" it (which is
                 -- always safe)
   = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
-  | updatable || opt_DoTickyProfiling  -- to catch double entry
+  | updatable || doingTickyProfiling dflags -- to catch double entry
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
@@ -624,10 +626,10 @@ getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
   = ASSERT( n_args == 0 )
     JumpToIt (thunkEntryLabel name caf std_form_info updatable)
 
   = ASSERT( n_args == 0 )
     JumpToIt (thunkEntryLabel name caf std_form_info updatable)
 
-getCallMethod name _ (LFUnknown True) n_args
+getCallMethod _ name _ (LFUnknown True) n_args
   = SlowCall -- Might be a function
 
   = SlowCall -- Might be a function
 
-getCallMethod name _ (LFUnknown False) n_args
+getCallMethod _ name _ (LFUnknown False) n_args
   | n_args > 0 
   = WARN( True, ppr name <+> ppr n_args ) 
     SlowCall   -- Note [Unsafe coerce complications]
   | n_args > 0 
   = WARN( True, ppr name <+> ppr n_args ) 
     SlowCall   -- Note [Unsafe coerce complications]
@@ -635,27 +637,27 @@ getCallMethod name _ (LFUnknown False) n_args
   | otherwise
   = EnterIt -- Not a function
 
   | otherwise
   = EnterIt -- Not a function
 
-getCallMethod name _ (LFBlackHole _) n_args
+getCallMethod _ name _ (LFBlackHole _) n_args
   = SlowCall   -- Presumably the black hole has by now
                -- been updated, but we don't know with
                -- what, so we slow call it
 
   = SlowCall   -- Presumably the black hole has by now
                -- been updated, but we don't know with
                -- what, so we slow call it
 
-getCallMethod name _ (LFLetNoEscape 0) n_args
+getCallMethod _ name _ (LFLetNoEscape 0) n_args
   = JumpToIt (enterReturnPtLabel (nameUnique name))
 
   = JumpToIt (enterReturnPtLabel (nameUnique name))
 
-getCallMethod name _ (LFLetNoEscape arity) n_args
+getCallMethod _ name _ (LFLetNoEscape arity) n_args
   | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
   | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
 
   | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
   | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
 
-blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
 -- Static closures are never themselves black-holed.
 -- Updatable ones will be overwritten with a CAFList cell, which points to a 
 -- black hole;
 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
 -- of a loop.
 
 -- Static closures are never themselves black-holed.
 -- Updatable ones will be overwritten with a CAFList cell, which points to a 
 -- black hole;
 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
 -- of a loop.
 
-blackHoleOnEntry ConInfo{} = False
-blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+blackHoleOnEntry _ ConInfo{} = False
+blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
   | isStaticRep rep
   = False      -- Never black-hole a static closure
 
   | isStaticRep rep
   = False      -- Never black-hole a static closure
 
@@ -666,7 +668,7 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
        LFThunk _ no_fvs updatable _ _
          -> if updatable
             then not opt_OmitBlackHoling
        LFThunk _ no_fvs updatable _ _
          -> if updatable
             then not opt_OmitBlackHoling
-            else opt_DoTickyProfiling || not no_fvs
+            else doingTickyProfiling dflags || not no_fvs
                   -- the former to catch double entry,
                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 
                   -- the former to catch double entry,
                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 
index b4415eb..ee033b1 100644 (file)
@@ -462,7 +462,8 @@ thunkCode cl_info fv_details cc node arity body
        ; entryHeapCheck node arity [] $ do
        {       -- Overwrite with black hole if necessary
                -- but *after* the heap-overflow check
        ; entryHeapCheck node arity [] $ do
        {       -- Overwrite with black hole if necessary
                -- but *after* the heap-overflow check
-         whenC (blackHoleOnEntry cl_info && node_points)
+         dflags <- getDynFlags
+       ; whenC (blackHoleOnEntry dflags cl_info && node_points)
                (blackHoleIt cl_info)
 
                -- Push update frame
                (blackHoleIt cl_info)
 
                -- Push update frame
index 7e8f02c..d4789be 100644 (file)
@@ -90,7 +90,7 @@ import TyCon
 import BasicTypes
 import Outputable
 import Constants
 import BasicTypes
 import Outputable
 import Constants
-
+import DynFlags
 
 -----------------------------------------------------------------------------
 --             Representations
 
 -----------------------------------------------------------------------------
 --             Representations
@@ -491,38 +491,39 @@ data CallMethod
        CLabel          --   The code label
        Int             --   Its arity
 
        CLabel          --   The code label
        Int             --   Its arity
 
-getCallMethod :: Name          -- Function being applied
+getCallMethod :: DynFlags
+              -> Name           -- Function being applied
               -> CafInfo        -- Can it refer to CAF's?
              -> LambdaFormInfo -- Its info
              -> Int            -- Number of available arguments
              -> CallMethod
 
               -> CafInfo        -- Can it refer to CAF's?
              -> LambdaFormInfo -- Its info
              -> Int            -- Number of available arguments
              -> CallMethod
 
-getCallMethod _name _ lf_info _n_args
+getCallMethod _ _name _ lf_info _n_args
   | nodeMustPointToIt lf_info && opt_Parallel
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
     EnterIt
 
   | nodeMustPointToIt lf_info && opt_Parallel
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
     EnterIt
 
-getCallMethod name caf (LFReEntrant _ arity _ _) n_args
+getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
   | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt   -- No args at all
   | n_args < arity = SlowCall  -- Not enough args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
   | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt   -- No args at all
   | n_args < arity = SlowCall  -- Not enough args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
-getCallMethod _name _ LFUnLifted n_args
+getCallMethod _ _name _ LFUnLifted n_args
   = ASSERT( n_args == 0 ) ReturnIt
 
   = ASSERT( n_args == 0 ) ReturnIt
 
-getCallMethod _name _ (LFCon _) n_args
+getCallMethod _ _name _ (LFCon _) n_args
   = ASSERT( n_args == 0 ) ReturnIt
 
   = ASSERT( n_args == 0 ) ReturnIt
 
-getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
   | is_fun     -- it *might* be a function, so we must "call" it (which is always safe)
   = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
   | is_fun     -- it *might* be a function, so we must "call" it (which is always safe)
   = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
-  | updatable || opt_DoTickyProfiling  -- to catch double entry
+  | updatable || doingTickyProfiling dflags -- to catch double entry
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
       {- OLD: || opt_SMP
         I decided to remove this, because in SMP mode it doesn't matter
         if we enter the same thunk multiple times, so the optimisation
@@ -540,19 +541,19 @@ getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
   = ASSERT( n_args == 0 )
     DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
 
   = ASSERT( n_args == 0 )
     DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
 
-getCallMethod _name _ (LFUnknown True) _n_args
+getCallMethod _ _name _ (LFUnknown True) _n_args
   = SlowCall -- might be a function
 
   = SlowCall -- might be a function
 
-getCallMethod name _ (LFUnknown False) n_args
+getCallMethod _ name _ (LFUnknown False) n_args
   = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) 
     EnterIt -- Not a function
 
   = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) 
     EnterIt -- Not a function
 
-getCallMethod _name _ (LFBlackHole _) _n_args
+getCallMethod _ _name _ (LFBlackHole _) _n_args
   = SlowCall   -- Presumably the black hole has by now
                -- been updated, but we don't know with
                -- what, so we slow call it
 
   = SlowCall   -- Presumably the black hole has by now
                -- been updated, but we don't know with
                -- what, so we slow call it
 
-getCallMethod _name _ LFLetNoEscape _n_args
+getCallMethod _ _name _ LFLetNoEscape _n_args
   = JumpToIt
 
 isStandardFormThunk :: LambdaFormInfo -> Bool
   = JumpToIt
 
 isStandardFormThunk :: LambdaFormInfo -> Bool
@@ -887,15 +888,15 @@ minPayloadSize smrep updatable
 --   Other functions over ClosureInfo
 --------------------------------------
 
 --   Other functions over ClosureInfo
 --------------------------------------
 
-blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
 -- Static closures are never themselves black-holed.
 -- Updatable ones will be overwritten with a CAFList cell, which points to a 
 -- black hole;
 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
 -- of a loop.
 
 -- Static closures are never themselves black-holed.
 -- Updatable ones will be overwritten with a CAFList cell, which points to a 
 -- black hole;
 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
 -- of a loop.
 
-blackHoleOnEntry ConInfo{} = False
-blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+blackHoleOnEntry _ ConInfo{} = False
+blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
   | isStaticRep rep
   = False      -- Never black-hole a static closure
 
   | isStaticRep rep
   = False      -- Never black-hole a static closure
 
@@ -906,7 +907,7 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
        LFThunk _ no_fvs updatable _ _
          -> if updatable
             then not opt_OmitBlackHoling
        LFThunk _ no_fvs updatable _ _
          -> if updatable
             then not opt_OmitBlackHoling
-            else opt_DoTickyProfiling || not no_fvs
+            else doingTickyProfiling dflags || not no_fvs
                   -- the former to catch double entry,
                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 
                   -- the former to catch double entry,
                   -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
 
index 47bf6c4..369564c 100644 (file)
@@ -442,8 +442,9 @@ cgLneJump blk_id lne_regs args      -- Join point; discard sequel
                <*> mkBranch blk_id) }
     
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
                <*> mkBranch blk_id) }
     
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
-cgTailCall fun_id fun_info args
-  = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
+cgTailCall fun_id fun_info args = do
+    dflags <- getDynFlags
+    case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
 
            -- A value in WHNF, so we can just return it.
        ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
 
            -- A value in WHNF, so we can just return it.
        ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
index 544f863..2e4b29e 100644 (file)
@@ -56,12 +56,13 @@ import CLabel
 import Module
 import Name
 import Id
 import Module
 import Name
 import Id
-import StaticFlags
 import BasicTypes
 import FastString
 import Constants
 import Outputable
 
 import BasicTypes
 import FastString
 import Constants
 import Outputable
 
+import DynFlags
+
 -- Turgid imports for showTypeCategory
 import PrelNames
 import TcType
 -- Turgid imports for showTypeCategory
 import PrelNames
 import TcType
@@ -321,9 +322,9 @@ tickyAllocHeap hp
 -- Ticky utils
 
 ifTicky :: FCode () -> FCode ()
 -- Ticky utils
 
 ifTicky :: FCode () -> FCode ()
-ifTicky code
-  | opt_DoTickyProfiling = code
-  | otherwise           = nopC
+ifTicky code = do dflags <- getDynFlags
+                  if doingTickyProfiling dflags then code
+                                                else nopC
 
 -- All the ticky-ticky counters are declared "unsigned long" in C
 bumpTickyCounter :: LitString -> FCode ()
 
 -- All the ticky-ticky counters are declared "unsigned long" in C
 bumpTickyCounter :: LitString -> FCode ()
index b5cfb23..3f975cd 100644 (file)
@@ -35,6 +35,7 @@ module DynFlags (
         updOptLevel,
         setTmpDir,
         setPackageName,
         updOptLevel,
         setTmpDir,
         setPackageName,
+        doingTickyProfiling,
 
         -- ** Parsing DynFlags
         parseDynamicFlags,
 
         -- ** Parsing DynFlags
         parseDynamicFlags,
@@ -517,6 +518,11 @@ isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True
 isNoLink _      = False
 
 isNoLink NoLink = True
 isNoLink _      = False
 
+-- Is it worth evaluating this Bool and caching it in the DynFlags value
+-- during initDynFlags?
+doingTickyProfiling :: DynFlags -> Bool
+doingTickyProfiling dflags = WayTicky `elem` wayNames dflags
+
 data PackageFlag
   = ExposePackage  String
   | HidePackage    String
 data PackageFlag
   = ExposePackage  String
   | HidePackage    String
index 456f620..d88a33d 100644 (file)
@@ -27,7 +27,6 @@ module StaticFlags (
 
        -- profiling opts
        opt_SccProfilingOn,
 
        -- profiling opts
        opt_SccProfilingOn,
-       opt_DoTickyProfiling,
 
         -- Hpc opts
        opt_Hpc,
 
         -- Hpc opts
        opt_Hpc,
@@ -196,8 +195,6 @@ opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")
 -- profiling opts
 opt_SccProfilingOn :: Bool
 opt_SccProfilingOn             = lookUp  (fsLit "-fscc-profiling")
 -- profiling opts
 opt_SccProfilingOn :: Bool
 opt_SccProfilingOn             = lookUp  (fsLit "-fscc-profiling")
-opt_DoTickyProfiling :: Bool
-opt_DoTickyProfiling            = WayTicky `elem` (unsafePerformIO $ readIORef v_Ways)
 
 -- Hpc opts
 opt_Hpc :: Bool
 
 -- Hpc opts
 opt_Hpc :: Bool