Make report flags a bitmask instead of sequential numbers

Summary:
Make report flags a bitmask instead of sequential numbers. The reporting
behavior may not be strictly ordered, some reporting behavior can be enabled
independently. By not using magic numbers, it will also be easier to introduce
new reporting behavior.

We plan to add a new `ReportExceptionStack` flag include label stack in
`HaxlException` in the future, which can be enabled independently with
`ReportFetchStack`.

Reviewed By: simonmar

Differential Revision: D32933603

fbshipit-source-id: 4028aa91b68caa738684a77392c916970b4605c9

Haxl/Core.hs

@@ -63,7 +63,16 @@ module Haxl.Core (
   , AllocCount
   , LabelHitCount
 
-    -- ** Tracing flags
+    -- * Report flags
+  , ReportFlag(..)
+  , ReportFlags
+  , defaultReportFlags
+  , profilingReportFlags
+  , setReportFlag
+  , clearReportFlag
+  , testReportFlag
+
+    -- ** Flags
   , Flags(..)
   , defaultFlags
   , ifTrace

Haxl/Core/Fetch.hs

@@ -156,7 +156,7 @@ stdResultVar Env{..} ivar p =
     -- Decrement the counter as request has finished. Do this after updating the
     -- completions TVar so that if the scheduler is tracking what was being
     -- waited on it gets a consistent view.
-    ifReport flags 1 $
+    ifReport flags ReportOutgoneFetches $
       atomicModifyIORef' submittedReqsRef (\m -> (subFromCountMap p 1 m, ()))
 {-# INLINE stdResultVar #-}
 
@@ -166,7 +166,7 @@ stdResultVar Env{..} ivar p =
 logFetch :: Env u w -> (r a -> String) -> r a -> CallId -> IO ()
 #ifdef PROFILING
 logFetch env showFn req fid = do
-  ifReport (flags env) 5 $ do
+  ifReport (flags env) ReportFetchStack $ do
     stack <- currentCallStack
     modifyIORef' (statsRef env) $ \(Stats s) ->
       Stats (FetchCall (showFn req) stack fid : s)
@@ -281,7 +281,7 @@ dataFetchWithInsert showFn insertFn req =
             Nothing -> submitFetch
             Just fallbackRes -> do
               addFallbackResult env fallbackRes ivar
-              when (report flags >= 2) $ addFallbackFetchStats
+              ifReport flags ReportFetchStats $ addFallbackFetchStats
                 env
                 fid
                 req
@@ -457,7 +457,7 @@ performFetches env@Env{flags=f, statsRef=sref, statsBatchIdRef=sbref} jobs = do
                   <> Text.pack (showp req)
         Just state ->
           return $ FetchToDo reqs
-            $ (if report f >= 2
+            $ (if testReportFlag ReportFetchStats $ report f
                 then wrapFetchInStats
                         (userEnv env)
                         sref
@@ -703,7 +703,7 @@ time io = do
 scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO ()
 scheduleFetches fetches ref flags = do
   -- update ReqCountmap for these fetches
-  ifReport flags 1 $ sequence_
+  ifReport flags ReportOutgoneFetches $ sequence_
     [ atomicModifyIORef' ref $
         \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ())
     | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches

Haxl/Core/Flags.hs

@@ -4,6 +4,8 @@
 -- This source code is distributed under the terms of a BSD license,
 -- found in the LICENSE file.
 
+{-# LANGUAGE BangPatterns #-}
+
 -- |
 -- The 'Flags' type and related functions.  This module is provided
 -- for access to Haxl internals only; most users should import
@@ -11,8 +13,16 @@
 --
 module Haxl.Core.Flags
   (
-    -- * Tracing flags
-    Flags(..)
+    -- * Report flags
+    ReportFlag(..)
+  , ReportFlags
+  , defaultReportFlags
+  , profilingReportFlags
+  , setReportFlag
+  , clearReportFlag
+  , testReportFlag
+    -- * Flags
+  , Flags(..)
   , defaultFlags
   , ifTrace
   , ifReport
@@ -20,6 +30,54 @@ module Haxl.Core.Flags
   ) where
 
 import Control.Monad
+import Data.Bits
+import Data.List (foldl')
+
+-- ---------------------------------------------------------------------------
+-- ReportFlags
+data ReportFlag
+  = ReportOutgoneFetches  -- ^ outgone fetches, for debugging eg: timeouts
+  | ReportFetchStats  -- ^ data fetch stats & errors
+  | ReportProfiling   -- ^ enabling label stack and profiling
+  | ReportFetchStack  -- ^ log stack traces of dataFetch calls
+  deriving (Bounded, Enum, Eq, Show)
+
+profilingDependents :: [ReportFlag]
+profilingDependents =
+  [ ReportFetchStack
+  ]
+
+newtype ReportFlags = ReportFlags Int
+
+defaultReportFlags :: ReportFlags
+defaultReportFlags = ReportFlags 0
+
+profilingReportFlags :: ReportFlags
+profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags
+  [ ReportOutgoneFetches
+  , ReportFetchStats
+  , ReportProfiling
+  ]
+
+setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags
+setReportFlag f (ReportFlags fs) =
+  ReportFlags $ setDependencies $ setBit fs $ fromEnum f
+  where
+    setDependencies
+      | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling
+      | otherwise = id
+
+clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags
+clearReportFlag f (ReportFlags fs) =
+  ReportFlags $ clearDependents $ clearBit fs $ fromEnum f
+  where
+    clearDependents z = case f of
+      ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents
+      _ -> z
+
+{-# INLINE testReportFlag #-}
+testReportFlag :: ReportFlag -> ReportFlags -> Bool
+testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f
 
 -- ---------------------------------------------------------------------------
 -- Flags
@@ -28,14 +86,8 @@ import Control.Monad
 data Flags = Flags
   { trace :: {-# UNPACK #-} !Int
     -- ^ Tracing level (0 = quiet, 3 = very verbose).
-  , report :: {-# UNPACK #-} !Int
-    -- ^ Report level:
-    --    * 0 = quiet
-    --    * 1 = outgone fetches, for debugging eg: timeouts
-    --    * 2 = data fetch stats & errors
-    --    * 3 = (same as 2, this used to enable errors)
-    --    * 4 = profiling
-    --    * 5 = log stack traces of dataFetch calls
+  , report :: {-# UNPACK #-} !ReportFlags
+    -- ^ Report flags
   , caching :: {-# UNPACK #-} !Int
     -- ^ Non-zero if caching is enabled.  If caching is disabled, then
     -- we still do batching and de-duplication, but do not cache
@@ -48,7 +100,7 @@ data Flags = Flags
 defaultFlags :: Flags
 defaultFlags = Flags
   { trace = 0
-  , report = 0
+  , report = defaultReportFlags
   , caching = 1
   , recording = 0
   }
@@ -57,9 +109,9 @@ defaultFlags = Flags
 ifTrace :: Monad m => Flags -> Int -> m a -> m ()
 ifTrace flags i = when (trace flags >= i) . void
 
--- | Runs an action if the report level is above the given threshold.
-ifReport :: Monad m => Flags -> Int -> m a -> m ()
-ifReport flags i = when (report flags >= i) . void
+-- | Runs an action if the ReportFlag is set.
+ifReport :: Monad m => Flags -> ReportFlag -> m a -> m ()
+ifReport flags i = when (testReportFlag i $ report flags) . void
 
 ifProfiling :: Monad m => Flags -> m a -> m ()
-ifProfiling flags = when (report flags >= 4) . void
+ifProfiling flags = ifReport flags ReportProfiling

Haxl/Core/Memo.hs

@@ -220,7 +220,8 @@ execMemoNowProfiled
   -> IVar u w a
   -> CallId
   -> IO (Result u w a)
-execMemoNowProfiled envOuter cont ivar cid = if report (flags envOuter) < 4
+execMemoNowProfiled envOuter cont ivar cid =
+  if not $ testReportFlag ReportProfiling $ report $ flags envOuter
   then execMemoNow envOuter cont ivar
   else do
     incrementMemoHitCounterFor envOuter cid False

Haxl/Core/Profile.hs

@@ -45,7 +45,7 @@ import Haxl.Core.Monad
 -- | Label a computation so profiling data is attributed to the label.
 withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a
 withLabel l (GenHaxl m) = GenHaxl $ \env ->
-  if report (flags env) < 4
+  if not $ testReportFlag ReportProfiling $ report $ flags env
      then m env
      else collectProfileData l m env
 
@@ -53,7 +53,7 @@ withLabel l (GenHaxl m) = GenHaxl $ \env ->
 -- Intended only for internal use by 'memoFingerprint'.
 withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a
 withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->
-  if report (flags env) < 4
+  if not $ testReportFlag ReportProfiling $ report $ flags env
      then m env
      else collectProfileData
             (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)

Haxl/Core/Run.hs

@@ -96,7 +96,7 @@ runHaxlWithWrites env@Env{..} haxl = do
                        _ -> modifyIORef' runQueueRef (appendJobList rq)
                    else reschedule env (appendJobList haxls rq)
       r <-
-        if report flags >= 4          -- withLabel unfolded
+        if testReportFlag ReportProfiling $ report flags  -- withLabel unfolded
           then Exception.try $ profileCont run env
           else Exception.try $ run env
       case r of
@@ -229,7 +229,7 @@ runHaxlWithWrites env@Env{..} haxl = do
                         , fetchWaitDuration = (end-start)
                         }
               modifyIORef' statsRef $ \(Stats s) -> Stats (fw:s)
-      if report flags >= 2
+      if testReportFlag ReportFetchStats $ report flags
         then doWaitProfiled
         else doWait
       emptyRunQueue env

changelog.md

@@ -3,6 +3,7 @@
   * Profiling now tracks full stacks and links each label to memos/fetches
   * Adds FetchDataSourceStats used to log stats/profiling data returned
     from datasources. This is stored in statsRef like any other Stats.
+  * Report flag was changed from sequential numbers to bitmask.
 
 # Changes in version 2.3.0.0
   * Removed `FutureFetch`

tests/DataCacheTest.hs

@@ -161,7 +161,7 @@ dcFallbackTest = TestLabel "DataCache fallback" $ TestList
 
     addLookup :: Env () Int -> Env () Int
     addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup)
-                    , flags = (flags e) { report = 4 }
+                    , flags = (flags e) { report = profilingReportFlags }
                     }
     lookup
       :: forall req a . Typeable (req a)

tests/DataSourceDispatchTests.hs

@@ -54,7 +54,8 @@ makeTestEnv :: UserEnv -> IO (Env UserEnv ())
 makeTestEnv testUsrEnv = do
   st <- initDataSource
   e <- initEnv (stateSet st stateEmpty) testUsrEnv
-  return e { flags = (flags e) { report = 2 } }
+  return e { flags = (flags e) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 schedulerTest:: Test
 schedulerTest = TestCase $ do

tests/FullyAsyncTest.hs

@@ -23,7 +23,8 @@ tests = sleepTest
 testEnv = do
   st <- mkConcurrentIOState
   env <- initEnv (stateSet st stateEmpty) ()
-  return env { flags = (flags env) { report = 2 } }
+  return env { flags = (flags env) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 sleepTest :: Test
 sleepTest = TestCase $ do

tests/MonadBench.hs

@@ -28,7 +28,7 @@ import ExampleDataSource
 
 newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show)
 
-testEnv :: Int -> IO (Env () SimpleWrite)
+testEnv :: ReportFlags -> IO (Env () SimpleWrite)
 testEnv report = do
   exstate <- ExampleDataSource.initGlobalState
   let st = stateSet exstate stateEmpty
@@ -110,7 +110,7 @@ allTests =
 data Options = Options
   { test :: String
   , nOverride :: Maybe Int
-  , reportFlag :: Int
+  , reportFlag :: ReportFlags
   }
 
 runTest :: Options -> Test -> IO ()
@@ -126,9 +126,14 @@ runTest Options{..} (t, nDef, act) = do
 optionsParser :: Parser Options
 optionsParser = do
   test <- argument str (metavar "TEST")
-  reportFlag <- option auto (long "report" <> value 0 <> metavar "REPORT")
+  reportFlag <- reportFlagParser
   nOverride <- optional $ argument auto (metavar "NUM")
   return Options{..}
+  where
+    reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA
+      [ flag id (setReportFlag i) $ long $ show i
+      | i <- enumFrom minBound
+      ]
 
 main :: IO ()
 main = do

tests/OutgoneFetchesTests.hs

@@ -29,7 +29,8 @@ testEnv = do
   sleepState <- mkConcurrentIOState
   let st = stateSet exstate $ stateSet sleepState stateEmpty
   e <- initEnv st ()
-  return e { flags = (flags e) {report = 1} }
+  return e { flags = (flags e) {
+    report = setReportFlag ReportOutgoneFetches defaultReportFlags } }
     -- report=1 to enable fetches tracking
 
 -- A cheap haxl computation we interleave b/w the @sleep@ fetches.

tests/ProfileTests.hs

@@ -31,7 +31,7 @@ import SleepDataSource
 
 mkProfilingEnv = do
   env <- makeTestEnv False
-  return env { flags = (flags env) { report = 4 } }
+  return env { flags = (flags env) { report = profilingReportFlags } }
 
 -- expects only one label to be shown
 labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData
@@ -132,7 +132,8 @@ exceptions = do
 threadAlloc :: Integer -> Assertion
 threadAlloc batches = do
   env' <- initEnv (stateSet mkWorkState stateEmpty) ()
-  let env = env'  { flags = (flags env') { report = 2 } }
+  let env = env'  { flags = (flags env') {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
   a0 <- getAllocationCounter
   let
     wsize = 100000

tests/StatsTests.hs

@@ -77,7 +77,8 @@ testEnv = do
 
   -- Create the Env:
   env <- initEnv st ()
-  return env{ flags = (flags env){ report = 5 } }
+  return env{ flags = (flags env){
+    report = setReportFlag ReportFetchStack profilingReportFlags } }
 
 
 fetchIdsSync :: Test

tests/TestExampleDataSource.hs

@@ -33,7 +33,8 @@ testEnv = do
 
   -- Create the Env:
   env <- initEnv st ()
-  return env{ flags = (flags env){ report = 2 } }
+  return env{ flags = (flags env){
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 
 tests = TestList [

tests/TestUtils.hs

@@ -53,7 +53,8 @@ makeTestEnv future = do
   stio <- mkConcurrentIOState
   let st = stateSet stio $ stateSet tao stateEmpty
   env <- initEnv st testinput
-  return env { flags = (flags env) { report = 2 } }
+  return env { flags = (flags env) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 expectResultWithEnv
   :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion