{-# LANGUAGE CApiFFI                    #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE ForeignFunctionInterface   #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE TypeApplications           #-}
{- |
Module:      Test.Tasty.PAPI
Copyright:   (c) 2023 Alexey Khudyakov
Licence:     BSD3

Benchmark framework which uses CPU instruction counting instead of
time measurement. This approach is much more deterministic and not
subject to variation caused by concurrent execution of other
programs.

Hardware counters are accessedusing
[PAPI](https://icl.utk.edu/papi/). Thus OS and hardware support
inherited from that library.


=== How to use

Library uses standard approach for benchmarks. So example benchmarks
looks similar to one using @criterion@, @gauge@ or @tasty-bench@:

> module Main where
> import Test.Tasty.PAPI
>
> main :: IO ()
> main = defaultMain
>   [ bench "6" $ whnf fib 6
>   , bench "7" $ whnf fib 7
>   , bench "8" $ whnf fib 8
>   ]
>
> fib :: Integer -> Integer
> fib 0 = 0
> fib 1 = 1
> fib n = fib (n-1) + fib (n-2)

Its output is:

> All
>   6:                OK
>     ALLOC=528  TOT_INS=4768    TOT_CYC=6114    BR_INS=1128     BR_MSP=74
>   7:                OK
>     ALLOC=864  TOT_INS=7431    TOT_CYC=6631    BR_INS=1744     BR_MSP=70
>   8:                OK
>     ALLOC=1408 TOT_INS=11.75e3 TOT_CYC=8540    BR_INS=2743     BR_MSP=93


=== Command line optiosn

Use @--help@ to list command-line options. Below is list of options
provided by this package:

[@--csv@ @PATH@]

    Write benchmark results into file in CSV format.

[@--counters@ @COUNTER_SET@]

    Adjust set of hardware counters to use. Refer to 'Counter' for
    documentation on supported counters. By default 'TOT_INS', 'TOT_CYC',
    'BR_INS', 'BR_MSP' are measured. @--counters INT_INS,FP_INS@ will
    *add* 'INT_INS' and 'FP_INS' to default set. @--counters
    =INT_INS,FP_INS@ will use only list of provided counters. Note
    that counter may or may not be supported on you CPU and there
    could be limit on number of counters used simultaneously.
-}
module Test.Tasty.PAPI
  ( -- * Running benchmarks
    defaultMain
  , Benchmark
  , Benchmarkable(..)
  , bench
  , bgroup
    -- * Creation of Benchmarkable
  , nf
  , whnf
  , nfIO
  , whnfIO
    -- * Ingredients
  , benchIngredients
  , consoleBenchReporter
  , csvReporter
    -- * Data types
  , Counter(..)
  ) where

import Control.Exception
import Control.Monad
import Control.DeepSeq
import Control.Concurrent.STM
import Data.List       (nub, intercalate)
import Data.Proxy
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.Set           as Set
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable
import System.Mem
import System.Exit
import System.IO
import Text.Printf

import Test.Tasty hiding (defaultMain)
import Test.Tasty.Ingredients
import Test.Tasty.Ingredients.ConsoleReporter
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners


----------------------------------------------------------------
-- Foreign calls to PAPI
----------------------------------------------------------------

-- PAPI eventset
newtype EventSet = EventSet CInt
  deriving (Int -> EventSet -> TestName -> TestName
[EventSet] -> TestName -> TestName
EventSet -> TestName
(Int -> EventSet -> TestName -> TestName)
-> (EventSet -> TestName)
-> ([EventSet] -> TestName -> TestName)
-> Show EventSet
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> EventSet -> TestName -> TestName
showsPrec :: Int -> EventSet -> TestName -> TestName
$cshow :: EventSet -> TestName
show :: EventSet -> TestName
$cshowList :: [EventSet] -> TestName -> TestName
showList :: [EventSet] -> TestName -> TestName
Show, Ptr EventSet -> IO EventSet
Ptr EventSet -> Int -> IO EventSet
Ptr EventSet -> Int -> EventSet -> IO ()
Ptr EventSet -> EventSet -> IO ()
EventSet -> Int
(EventSet -> Int)
-> (EventSet -> Int)
-> (Ptr EventSet -> Int -> IO EventSet)
-> (Ptr EventSet -> Int -> EventSet -> IO ())
-> (forall b. Ptr b -> Int -> IO EventSet)
-> (forall b. Ptr b -> Int -> EventSet -> IO ())
-> (Ptr EventSet -> IO EventSet)
-> (Ptr EventSet -> EventSet -> IO ())
-> Storable EventSet
forall b. Ptr b -> Int -> IO EventSet
forall b. Ptr b -> Int -> EventSet -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
$csizeOf :: EventSet -> Int
sizeOf :: EventSet -> Int
$calignment :: EventSet -> Int
alignment :: EventSet -> Int
$cpeekElemOff :: Ptr EventSet -> Int -> IO EventSet
peekElemOff :: Ptr EventSet -> Int -> IO EventSet
$cpokeElemOff :: Ptr EventSet -> Int -> EventSet -> IO ()
pokeElemOff :: Ptr EventSet -> Int -> EventSet -> IO ()
$cpeekByteOff :: forall b. Ptr b -> Int -> IO EventSet
peekByteOff :: forall b. Ptr b -> Int -> IO EventSet
$cpokeByteOff :: forall b. Ptr b -> Int -> EventSet -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> EventSet -> IO ()
$cpeek :: Ptr EventSet -> IO EventSet
peek :: Ptr EventSet -> IO EventSet
$cpoke :: Ptr EventSet -> EventSet -> IO ()
poke :: Ptr EventSet -> EventSet -> IO ()
Storable)

foreign import capi "papi.h value PAPI_OK"          papi_OK          :: CInt
foreign import capi "papi.h value PAPI_NULL"        papi_NULL        :: CInt
foreign import capi "papi.h value PAPI_VER_CURRENT" papi_VER_CURRENT :: CInt

foreign import capi "papi.h value PAPI_L1_DCM"   papi_L1_DCM  :: CInt
foreign import capi "papi.h value PAPI_L1_ICM"   papi_L1_ICM  :: CInt
foreign import capi "papi.h value PAPI_L2_DCM"   papi_L2_DCM  :: CInt
foreign import capi "papi.h value PAPI_L2_ICM"   papi_L2_ICM  :: CInt
foreign import capi "papi.h value PAPI_L3_DCM"   papi_L3_DCM  :: CInt
foreign import capi "papi.h value PAPI_L3_ICM"   papi_L3_ICM  :: CInt
foreign import capi "papi.h value PAPI_L1_TCM"   papi_L1_TCM  :: CInt
foreign import capi "papi.h value PAPI_L2_TCM"   papi_L2_TCM  :: CInt
foreign import capi "papi.h value PAPI_L3_TCM"   papi_L3_TCM  :: CInt
foreign import capi "papi.h value PAPI_CA_SNP"   papi_CA_SNP  :: CInt
foreign import capi "papi.h value PAPI_CA_SHR"   papi_CA_SHR  :: CInt
foreign import capi "papi.h value PAPI_CA_CLN"   papi_CA_CLN  :: CInt
foreign import capi "papi.h value PAPI_CA_INV"   papi_CA_INV  :: CInt
foreign import capi "papi.h value PAPI_CA_ITV"   papi_CA_ITV  :: CInt
foreign import capi "papi.h value PAPI_L3_LDM"   papi_L3_LDM  :: CInt
foreign import capi "papi.h value PAPI_L3_STM"   papi_L3_STM  :: CInt
foreign import capi "papi.h value PAPI_BRU_IDL"  papi_BRU_IDL :: CInt
foreign import capi "papi.h value PAPI_FXU_IDL"  papi_FXU_IDL :: CInt
foreign import capi "papi.h value PAPI_FPU_IDL"  papi_FPU_IDL :: CInt
foreign import capi "papi.h value PAPI_LSU_IDL"  papi_LSU_IDL :: CInt
foreign import capi "papi.h value PAPI_TLB_DM"   papi_TLB_DM  :: CInt
foreign import capi "papi.h value PAPI_TLB_IM"   papi_TLB_IM  :: CInt
foreign import capi "papi.h value PAPI_TLB_TL"   papi_TLB_TL  :: CInt
foreign import capi "papi.h value PAPI_L1_LDM"   papi_L1_LDM  :: CInt
foreign import capi "papi.h value PAPI_L1_STM"   papi_L1_STM  :: CInt
foreign import capi "papi.h value PAPI_L2_LDM"   papi_L2_LDM  :: CInt
foreign import capi "papi.h value PAPI_L2_STM"   papi_L2_STM  :: CInt
foreign import capi "papi.h value PAPI_BTAC_M"   papi_BTAC_M  :: CInt
foreign import capi "papi.h value PAPI_PRF_DM"   papi_PRF_DM  :: CInt
foreign import capi "papi.h value PAPI_L3_DCH"   papi_L3_DCH  :: CInt
foreign import capi "papi.h value PAPI_TLB_SD"   papi_TLB_SD  :: CInt
foreign import capi "papi.h value PAPI_CSR_FAL"  papi_CSR_FAL :: CInt
foreign import capi "papi.h value PAPI_CSR_SUC"  papi_CSR_SUC :: CInt
foreign import capi "papi.h value PAPI_CSR_TOT"  papi_CSR_TOT :: CInt
foreign import capi "papi.h value PAPI_MEM_SCY"  papi_MEM_SCY :: CInt
foreign import capi "papi.h value PAPI_MEM_RCY"  papi_MEM_RCY :: CInt
foreign import capi "papi.h value PAPI_MEM_WCY"  papi_MEM_WCY :: CInt
foreign import capi "papi.h value PAPI_STL_ICY"  papi_STL_ICY :: CInt
foreign import capi "papi.h value PAPI_FUL_ICY"  papi_FUL_ICY :: CInt
foreign import capi "papi.h value PAPI_STL_CCY"  papi_STL_CCY :: CInt
foreign import capi "papi.h value PAPI_FUL_CCY"  papi_FUL_CCY :: CInt
foreign import capi "papi.h value PAPI_HW_INT"   papi_HW_INT  :: CInt
foreign import capi "papi.h value PAPI_BR_UCN"   papi_BR_UCN  :: CInt
foreign import capi "papi.h value PAPI_BR_CN"    papi_BR_CN   :: CInt
foreign import capi "papi.h value PAPI_BR_TKN"   papi_BR_TKN  :: CInt
foreign import capi "papi.h value PAPI_BR_NTK"   papi_BR_NTK  :: CInt
foreign import capi "papi.h value PAPI_BR_MSP"   papi_BR_MSP  :: CInt
foreign import capi "papi.h value PAPI_BR_PRC"   papi_BR_PRC  :: CInt
foreign import capi "papi.h value PAPI_FMA_INS"  papi_FMA_INS :: CInt
foreign import capi "papi.h value PAPI_TOT_IIS"  papi_TOT_IIS :: CInt
foreign import capi "papi.h value PAPI_TOT_INS"  papi_TOT_INS :: CInt
foreign import capi "papi.h value PAPI_INT_INS"  papi_INT_INS :: CInt
foreign import capi "papi.h value PAPI_FP_INS"   papi_FP_INS  :: CInt
foreign import capi "papi.h value PAPI_LD_INS"   papi_LD_INS  :: CInt
foreign import capi "papi.h value PAPI_SR_INS"   papi_SR_INS  :: CInt
foreign import capi "papi.h value PAPI_BR_INS"   papi_BR_INS  :: CInt
foreign import capi "papi.h value PAPI_VEC_INS"  papi_VEC_INS :: CInt
foreign import capi "papi.h value PAPI_RES_STL"  papi_RES_STL :: CInt
foreign import capi "papi.h value PAPI_FP_STAL"  papi_FP_STAL :: CInt
foreign import capi "papi.h value PAPI_TOT_CYC"  papi_TOT_CYC :: CInt
foreign import capi "papi.h value PAPI_LST_INS"  papi_LST_INS :: CInt
foreign import capi "papi.h value PAPI_SYC_INS"  papi_SYC_INS :: CInt
foreign import capi "papi.h value PAPI_L1_DCH"   papi_L1_DCH  :: CInt
foreign import capi "papi.h value PAPI_L2_DCH"   papi_L2_DCH  :: CInt
foreign import capi "papi.h value PAPI_L1_DCA"   papi_L1_DCA  :: CInt
foreign import capi "papi.h value PAPI_L2_DCA"   papi_L2_DCA  :: CInt
foreign import capi "papi.h value PAPI_L3_DCA"   papi_L3_DCA  :: CInt
foreign import capi "papi.h value PAPI_L1_DCR"   papi_L1_DCR  :: CInt
foreign import capi "papi.h value PAPI_L2_DCR"   papi_L2_DCR  :: CInt
foreign import capi "papi.h value PAPI_L3_DCR"   papi_L3_DCR  :: CInt
foreign import capi "papi.h value PAPI_L1_DCW"   papi_L1_DCW  :: CInt
foreign import capi "papi.h value PAPI_L2_DCW"   papi_L2_DCW  :: CInt
foreign import capi "papi.h value PAPI_L3_DCW"   papi_L3_DCW  :: CInt
foreign import capi "papi.h value PAPI_L1_ICH"   papi_L1_ICH  :: CInt
foreign import capi "papi.h value PAPI_L2_ICH"   papi_L2_ICH  :: CInt
foreign import capi "papi.h value PAPI_L3_ICH"   papi_L3_ICH  :: CInt
foreign import capi "papi.h value PAPI_L1_ICA"   papi_L1_ICA  :: CInt
foreign import capi "papi.h value PAPI_L2_ICA"   papi_L2_ICA  :: CInt
foreign import capi "papi.h value PAPI_L3_ICA"   papi_L3_ICA  :: CInt
foreign import capi "papi.h value PAPI_L1_ICR"   papi_L1_ICR  :: CInt
foreign import capi "papi.h value PAPI_L2_ICR"   papi_L2_ICR  :: CInt
foreign import capi "papi.h value PAPI_L3_ICR"   papi_L3_ICR  :: CInt
foreign import capi "papi.h value PAPI_L1_ICW"   papi_L1_ICW  :: CInt
foreign import capi "papi.h value PAPI_L2_ICW"   papi_L2_ICW  :: CInt
foreign import capi "papi.h value PAPI_L3_ICW"   papi_L3_ICW  :: CInt
foreign import capi "papi.h value PAPI_L1_TCH"   papi_L1_TCH  :: CInt
foreign import capi "papi.h value PAPI_L2_TCH"   papi_L2_TCH  :: CInt
foreign import capi "papi.h value PAPI_L3_TCH"   papi_L3_TCH  :: CInt
foreign import capi "papi.h value PAPI_L1_TCA"   papi_L1_TCA  :: CInt
foreign import capi "papi.h value PAPI_L2_TCA"   papi_L2_TCA  :: CInt
foreign import capi "papi.h value PAPI_L3_TCA"   papi_L3_TCA  :: CInt
foreign import capi "papi.h value PAPI_L1_TCR"   papi_L1_TCR  :: CInt
foreign import capi "papi.h value PAPI_L2_TCR"   papi_L2_TCR  :: CInt
foreign import capi "papi.h value PAPI_L3_TCR"   papi_L3_TCR  :: CInt
foreign import capi "papi.h value PAPI_L1_TCW"   papi_L1_TCW  :: CInt
foreign import capi "papi.h value PAPI_L2_TCW"   papi_L2_TCW  :: CInt
foreign import capi "papi.h value PAPI_L3_TCW"   papi_L3_TCW  :: CInt
foreign import capi "papi.h value PAPI_FML_INS"  papi_FML_INS :: CInt
foreign import capi "papi.h value PAPI_FAD_INS"  papi_FAD_INS :: CInt
foreign import capi "papi.h value PAPI_FDV_INS"  papi_FDV_INS :: CInt
foreign import capi "papi.h value PAPI_FSQ_INS"  papi_FSQ_INS :: CInt
foreign import capi "papi.h value PAPI_FNV_INS"  papi_FNV_INS :: CInt

foreign import capi "papi.h PAPI_library_init"
  papi_library_init :: CInt -> IO CInt

foreign import capi unsafe "papi.h PAPI_create_eventset"
  papi_create_eventset :: Ptr EventSet -> IO CInt
foreign import capi unsafe "papi.h PAPI_cleanup_eventset"
  papi_cleanup_eventset :: EventSet -> IO CInt
foreign import capi unsafe "papi.h PAPI_destroy_eventset"
  papi_destroy_eventset :: Ptr EventSet -> IO CInt

foreign import capi unsafe "papi.h PAPI_add_event"
  papi_add_event :: EventSet -> CInt -> IO CInt

foreign import capi unsafe "papi.h PAPI_start"
  papi_start :: EventSet -> IO CInt
foreign import capi unsafe "papi.h PAPI_stop"
  papi_stop :: EventSet -> Ptr CLLong -> IO CInt
-- foreign import capi unsafe "papi.h PAPI_read"
--   papi_read :: CInt -> Ptr CLLong -> IO CInt
-- foreign import capi unsafe "papi.h PAPI_reset"
--   papi_reset :: CInt -> IO CInt

foreign import capi unsafe "papi.h PAPI_strerror"
  papi_strerror :: CInt -> IO CString

-- Call PAPI function and return error code
call :: String -> IO CInt -> IO ()
call :: TestName -> IO CInt -> IO ()
call TestName
msg IO CInt
f = IO CInt
f IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  CInt
n | CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
papi_OK -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise    -> do
        CString
c_str <- CInt -> IO CString
papi_strerror CInt
n
        TestName
str   <- if | CString
c_str CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr -> TestName -> IO TestName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"UNKNOWN ERROR"
                    | Bool
otherwise        -> CString -> IO TestName
peekCString CString
c_str
        TestName -> IO ()
forall a. HasCallStack => TestName -> a
error (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> TestName -> TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"PAPI: %s: %s [%s]" TestName
msg TestName
str (CInt -> TestName
forall a. Show a => a -> TestName
show CInt
n)

-- Create event set for use with PAPI
withPapiEventSet :: (EventSet -> IO a) -> IO a
withPapiEventSet :: forall a. (EventSet -> IO a) -> IO a
withPapiEventSet EventSet -> IO a
action = do
  -- Initialize library. It seems that calling it multiple times is safe
  do CInt
n <- CInt -> IO CInt
papi_library_init CInt
papi_VER_CURRENT
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
papi_VER_CURRENT) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> IO ()
forall a. HasCallStack => TestName -> a
error TestName
"PAPI init failed"
  IO EventSet -> (EventSet -> IO ()) -> (EventSet -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO EventSet
ini EventSet -> IO ()
fini EventSet -> IO a
action
  where
    ini :: IO EventSet
ini = (Ptr EventSet -> IO EventSet) -> IO EventSet
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr EventSet -> IO EventSet) -> IO EventSet)
-> (Ptr EventSet -> IO EventSet) -> IO EventSet
forall a b. (a -> b) -> a -> b
$ \Ptr EventSet
p_evt -> do
      Ptr EventSet -> EventSet -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr EventSet
p_evt (CInt -> EventSet
EventSet CInt
papi_NULL)
      TestName -> IO CInt -> IO ()
call TestName
"Failed to create eventset" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr EventSet -> IO CInt
papi_create_eventset Ptr EventSet
p_evt
      Ptr EventSet -> IO EventSet
forall a. Storable a => Ptr a -> IO a
peek Ptr EventSet
p_evt
    fini :: EventSet -> IO ()
fini EventSet
evt = do
      TestName -> IO CInt -> IO ()
call TestName
"Failed to cleanup eventset" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSet -> IO CInt
papi_cleanup_eventset EventSet
evt
      (Ptr EventSet -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr EventSet -> IO ()) -> IO ())
-> (Ptr EventSet -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr EventSet
p_evt -> do
        Ptr EventSet -> EventSet -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr EventSet
p_evt EventSet
evt
        TestName -> IO CInt -> IO ()
call TestName
"Failed to destroy eventset" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr EventSet -> IO CInt
papi_destroy_eventset Ptr EventSet
p_evt

-- | Supported hardware counters
--
-- Documentation is taken from rather outdated manual:
-- https://icl.utk.edu/projects/papi/files/documentation/PAPI_USER_GUIDE_23.htm
data Counter
  = L1_DCM  -- ^ Level 1 data cache misses
  | L1_ICM  -- ^ Level 1 instruction cache misses
  | L2_DCM  -- ^ Level 2 data cache misses
  | L2_ICM  -- ^ Level 2 instruction cache misses
  | L3_DCM  -- ^ Level 3 data cache misses
  | L3_ICM  -- ^ Level 3 instruction cache misses
  | L1_TCM  -- ^ Level 1 total cache misses
  | L2_TCM  -- ^ Level 2 total cache misses
  | L3_TCM  -- ^ Level 3 total cache misses
  | CA_SNP  -- ^ Requests for a Snoop
  | CA_SHR  -- ^ Requests for access to shared cache line (SMP)
  | CA_CLN  -- ^ Requests for access to clean cache line (SMP)
  | CA_INV  -- ^ Cache Line Invalidation (SMP)
  | CA_ITV  -- ^ Cache Line Intervention (SMP)
  | L3_LDM  -- ^ Level 3 load misses
  | L3_STM  -- ^ Level 3 store misses
  | BRU_IDL -- ^ Cycles branch units are idle
  | FXU_IDL -- ^ Cycles integer units are idle
  | FPU_IDL -- ^ Cycles floating point units are idle
  | LSU_IDL -- ^ Cycles load/store units are idle
  | TLB_DM  -- ^ Data translation lookaside buffer misses
  | TLB_IM  -- ^ Instruction translation lookaside buffer misses
  | TLB_TL  -- ^ Total translation lookaside buffer misses
  | L1_LDM  -- ^ Level 1 load misses
  | L1_STM  -- ^ Level 1 store misses
  | L2_LDM  -- ^ Level 2 load misses
  | L2_STM  -- ^ Level 2 store misses
  | BTAC_M  -- ^ Branch target address cache (BTAC) misses
  | PRF_DM  -- ^ Pre-fetch data instruction caused a miss
  | L3_DCH  -- ^ Level 3 Data Cache Hit
  | TLB_SD  -- ^ Translation lookaside buffer shootdowns (SMP)
  | CSR_FAL -- ^ Failed store conditional instructions
  | CSR_SUC -- ^ Successful store conditional instructions
  | CSR_TOT -- ^ Total store conditional instructions
  | MEM_SCY -- ^ Cycles Stalled Waiting for Memory Access
  | MEM_RCY -- ^ Cycles Stalled Waiting for Memory Read
  | MEM_WCY -- ^ Cycles Stalled Waiting for Memory Write
  | STL_ICY -- ^ Cycles with No Instruction Issue
  | FUL_ICY -- ^ Cycles with Maximum Instruction Issue
  | STL_CCY -- ^ Cycles with No Instruction Completion
  | FUL_CCY -- ^ Cycles with Maximum Instruction Completion
  | HW_INT  -- ^ Hardware interrupts
  | BR_UCN  -- ^ Unconditional branch instructions executed
  | BR_CN   -- ^ Conditional branch instructions executed
  | BR_TKN  -- ^ Conditional branch instructions taken
  | BR_NTK  -- ^ Conditional branch instructions not taken
  | BR_MSP  -- ^ Conditional branch instructions mispredicted
  | BR_PRC  -- ^ Conditional branch instructions correctly predicted
  | FMA_INS -- ^ FMA instructions completed
  | TOT_IIS -- ^ Total instructions issued
  | TOT_INS -- ^ Total instructions executed
  | INT_INS -- ^ Integer instructions executed
  | FP_INS  -- ^ Floating point instructions executed
  | LD_INS  -- ^ Load instructions executed
  | SR_INS  -- ^ Store instructions executed
  | BR_INS  -- ^ Total branch instructions executed
  | VEC_INS -- ^ Vector/SIMD instructions executed
  | RES_STL -- ^ Cycles processor is stalled on resource
  | FP_STAL -- ^ Cycles any FP units are stalled
  | TOT_CYC -- ^ Total cycles
  | LST_INS -- ^ Total load/store instructions executed
  | SYC_INS -- ^ Synchronization instructions executed
  | L1_DCH  -- ^ L1 data cache hits
  | L2_DCH  -- ^ L2 data cache hits
  | L1_DCA  -- ^ L1 data cache accesses
  | L2_DCA  -- ^ L2 data cache accesses
  | L3_DCA  -- ^ L3 data cache accesses
  | L1_DCR  -- ^ L1 data cache reads
  | L2_DCR  -- ^ L2 data cache reads
  | L3_DCR  -- ^ L3 data cache reads
  | L1_DCW  -- ^ L1 data cache writes
  | L2_DCW  -- ^ L2 data cache writes
  | L3_DCW  -- ^ L3 data cache writes
  | L1_ICH  -- ^ L1 instruction cache hits
  | L2_ICH  -- ^ L2 instruction cache hits
  | L3_ICH  -- ^ L3 instruction cache hits
  | L1_ICA  -- ^ L1 instruction cache accesses
  | L2_ICA  -- ^ L2 instruction cache accesses
  | L3_ICA  -- ^ L3 instruction cache accesses
  | L1_ICR  -- ^ L1 instruction cache reads
  | L2_ICR  -- ^ L2 instruction cache reads
  | L3_ICR  -- ^ L3 instruction cache reads
  | L1_ICW  -- ^ L1 instruction cache writes
  | L2_ICW  -- ^ L2 instruction cache writes
  | L3_ICW  -- ^ L3 instruction cache writes
  | L1_TCH  -- ^ L1 total cache hits
  | L2_TCH  -- ^ L2 total cache hits
  | L3_TCH  -- ^ L3 total cache hits
  | L1_TCA  -- ^ L1 total cache accesses
  | L2_TCA  -- ^ L2 total cache accesses
  | L3_TCA  -- ^ L3 total cache accesses
  | L1_TCR  -- ^ L1 total cache reads
  | L2_TCR  -- ^ L2 total cache reads
  | L3_TCR  -- ^ L3 total cache reads
  | L1_TCW  -- ^ L1 total cache writes
  | L2_TCW  -- ^ L2 total cache writes
  | L3_TCW  -- ^ L3 total cache writes
  | FML_INS -- ^ Floating Multiply instructions
  | FAD_INS -- ^ Floating Add instructions
  | FDV_INS -- ^ Floating Divide instructions
  | FSQ_INS -- ^ Floating Square Root instructions
  | FNV_INS -- ^ Floating Inverse instructions
  deriving (Int -> Counter -> TestName -> TestName
[Counter] -> TestName -> TestName
Counter -> TestName
(Int -> Counter -> TestName -> TestName)
-> (Counter -> TestName)
-> ([Counter] -> TestName -> TestName)
-> Show Counter
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> Counter -> TestName -> TestName
showsPrec :: Int -> Counter -> TestName -> TestName
$cshow :: Counter -> TestName
show :: Counter -> TestName
$cshowList :: [Counter] -> TestName -> TestName
showList :: [Counter] -> TestName -> TestName
Show,ReadPrec [Counter]
ReadPrec Counter
Int -> ReadS Counter
ReadS [Counter]
(Int -> ReadS Counter)
-> ReadS [Counter]
-> ReadPrec Counter
-> ReadPrec [Counter]
-> Read Counter
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Counter
readsPrec :: Int -> ReadS Counter
$creadList :: ReadS [Counter]
readList :: ReadS [Counter]
$creadPrec :: ReadPrec Counter
readPrec :: ReadPrec Counter
$creadListPrec :: ReadPrec [Counter]
readListPrec :: ReadPrec [Counter]
Read,Counter -> Counter -> Bool
(Counter -> Counter -> Bool)
-> (Counter -> Counter -> Bool) -> Eq Counter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Counter -> Counter -> Bool
== :: Counter -> Counter -> Bool
$c/= :: Counter -> Counter -> Bool
/= :: Counter -> Counter -> Bool
Eq,Eq Counter
Eq Counter
-> (Counter -> Counter -> Ordering)
-> (Counter -> Counter -> Bool)
-> (Counter -> Counter -> Bool)
-> (Counter -> Counter -> Bool)
-> (Counter -> Counter -> Bool)
-> (Counter -> Counter -> Counter)
-> (Counter -> Counter -> Counter)
-> Ord Counter
Counter -> Counter -> Bool
Counter -> Counter -> Ordering
Counter -> Counter -> Counter
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Counter -> Counter -> Ordering
compare :: Counter -> Counter -> Ordering
$c< :: Counter -> Counter -> Bool
< :: Counter -> Counter -> Bool
$c<= :: Counter -> Counter -> Bool
<= :: Counter -> Counter -> Bool
$c> :: Counter -> Counter -> Bool
> :: Counter -> Counter -> Bool
$c>= :: Counter -> Counter -> Bool
>= :: Counter -> Counter -> Bool
$cmax :: Counter -> Counter -> Counter
max :: Counter -> Counter -> Counter
$cmin :: Counter -> Counter -> Counter
min :: Counter -> Counter -> Counter
Ord)


toCounter :: Counter -> CInt
toCounter :: Counter -> CInt
toCounter = \case
  Counter
L1_DCM  -> CInt
papi_L1_DCM
  Counter
L1_ICM  -> CInt
papi_L1_ICM
  Counter
L2_DCM  -> CInt
papi_L2_DCM
  Counter
L2_ICM  -> CInt
papi_L2_ICM
  Counter
L3_DCM  -> CInt
papi_L3_DCM
  Counter
L3_ICM  -> CInt
papi_L3_ICM
  Counter
L1_TCM  -> CInt
papi_L1_TCM
  Counter
L2_TCM  -> CInt
papi_L2_TCM
  Counter
L3_TCM  -> CInt
papi_L3_TCM
  Counter
CA_SNP  -> CInt
papi_CA_SNP
  Counter
CA_SHR  -> CInt
papi_CA_SHR
  Counter
CA_CLN  -> CInt
papi_CA_CLN
  Counter
CA_INV  -> CInt
papi_CA_INV
  Counter
CA_ITV  -> CInt
papi_CA_ITV
  Counter
L3_LDM  -> CInt
papi_L3_LDM
  Counter
L3_STM  -> CInt
papi_L3_STM
  Counter
BRU_IDL -> CInt
papi_BRU_IDL
  Counter
FXU_IDL -> CInt
papi_FXU_IDL
  Counter
FPU_IDL -> CInt
papi_FPU_IDL
  Counter
LSU_IDL -> CInt
papi_LSU_IDL
  Counter
TLB_DM  -> CInt
papi_TLB_DM
  Counter
TLB_IM  -> CInt
papi_TLB_IM
  Counter
TLB_TL  -> CInt
papi_TLB_TL
  Counter
L1_LDM  -> CInt
papi_L1_LDM
  Counter
L1_STM  -> CInt
papi_L1_STM
  Counter
L2_LDM  -> CInt
papi_L2_LDM
  Counter
L2_STM  -> CInt
papi_L2_STM
  Counter
BTAC_M  -> CInt
papi_BTAC_M
  Counter
PRF_DM  -> CInt
papi_PRF_DM
  Counter
L3_DCH  -> CInt
papi_L3_DCH
  Counter
TLB_SD  -> CInt
papi_TLB_SD
  Counter
CSR_FAL -> CInt
papi_CSR_FAL
  Counter
CSR_SUC -> CInt
papi_CSR_SUC
  Counter
CSR_TOT -> CInt
papi_CSR_TOT
  Counter
MEM_SCY -> CInt
papi_MEM_SCY
  Counter
MEM_RCY -> CInt
papi_MEM_RCY
  Counter
MEM_WCY -> CInt
papi_MEM_WCY
  Counter
STL_ICY -> CInt
papi_STL_ICY
  Counter
FUL_ICY -> CInt
papi_FUL_ICY
  Counter
STL_CCY -> CInt
papi_STL_CCY
  Counter
FUL_CCY -> CInt
papi_FUL_CCY
  Counter
HW_INT  -> CInt
papi_HW_INT
  Counter
BR_UCN  -> CInt
papi_BR_UCN
  Counter
BR_CN   -> CInt
papi_BR_CN
  Counter
BR_TKN  -> CInt
papi_BR_TKN
  Counter
BR_NTK  -> CInt
papi_BR_NTK
  Counter
BR_MSP  -> CInt
papi_BR_MSP
  Counter
BR_PRC  -> CInt
papi_BR_PRC
  Counter
FMA_INS -> CInt
papi_FMA_INS
  Counter
TOT_IIS -> CInt
papi_TOT_IIS
  Counter
TOT_INS -> CInt
papi_TOT_INS
  Counter
INT_INS -> CInt
papi_INT_INS
  Counter
FP_INS  -> CInt
papi_FP_INS
  Counter
LD_INS  -> CInt
papi_LD_INS
  Counter
SR_INS  -> CInt
papi_SR_INS
  Counter
BR_INS  -> CInt
papi_BR_INS
  Counter
VEC_INS -> CInt
papi_VEC_INS
  Counter
RES_STL -> CInt
papi_RES_STL
  Counter
FP_STAL -> CInt
papi_FP_STAL
  Counter
TOT_CYC -> CInt
papi_TOT_CYC
  Counter
LST_INS -> CInt
papi_LST_INS
  Counter
SYC_INS -> CInt
papi_SYC_INS
  Counter
L1_DCH  -> CInt
papi_L1_DCH
  Counter
L2_DCH  -> CInt
papi_L2_DCH
  Counter
L1_DCA  -> CInt
papi_L1_DCA
  Counter
L2_DCA  -> CInt
papi_L2_DCA
  Counter
L3_DCA  -> CInt
papi_L3_DCA
  Counter
L1_DCR  -> CInt
papi_L1_DCR
  Counter
L2_DCR  -> CInt
papi_L2_DCR
  Counter
L3_DCR  -> CInt
papi_L3_DCR
  Counter
L1_DCW  -> CInt
papi_L1_DCW
  Counter
L2_DCW  -> CInt
papi_L2_DCW
  Counter
L3_DCW  -> CInt
papi_L3_DCW
  Counter
L1_ICH  -> CInt
papi_L1_ICH
  Counter
L2_ICH  -> CInt
papi_L2_ICH
  Counter
L3_ICH  -> CInt
papi_L3_ICH
  Counter
L1_ICA  -> CInt
papi_L1_ICA
  Counter
L2_ICA  -> CInt
papi_L2_ICA
  Counter
L3_ICA  -> CInt
papi_L3_ICA
  Counter
L1_ICR  -> CInt
papi_L1_ICR
  Counter
L2_ICR  -> CInt
papi_L2_ICR
  Counter
L3_ICR  -> CInt
papi_L3_ICR
  Counter
L1_ICW  -> CInt
papi_L1_ICW
  Counter
L2_ICW  -> CInt
papi_L2_ICW
  Counter
L3_ICW  -> CInt
papi_L3_ICW
  Counter
L1_TCH  -> CInt
papi_L1_TCH
  Counter
L2_TCH  -> CInt
papi_L2_TCH
  Counter
L3_TCH  -> CInt
papi_L3_TCH
  Counter
L1_TCA  -> CInt
papi_L1_TCA
  Counter
L2_TCA  -> CInt
papi_L2_TCA
  Counter
L3_TCA  -> CInt
papi_L3_TCA
  Counter
L1_TCR  -> CInt
papi_L1_TCR
  Counter
L2_TCR  -> CInt
papi_L2_TCR
  Counter
L3_TCR  -> CInt
papi_L3_TCR
  Counter
L1_TCW  -> CInt
papi_L1_TCW
  Counter
L2_TCW  -> CInt
papi_L2_TCW
  Counter
L3_TCW  -> CInt
papi_L3_TCW
  Counter
FML_INS -> CInt
papi_FML_INS
  Counter
FAD_INS -> CInt
papi_FAD_INS
  Counter
FDV_INS -> CInt
papi_FDV_INS
  Counter
FSQ_INS -> CInt
papi_FSQ_INS
  Counter
FNV_INS -> CInt
papi_FNV_INS


----------------------------------------------------------------
--
----------------------------------------------------------------



newtype CsvPath = CsvPath FilePath

instance IsOption (Maybe CsvPath) where
  defaultValue :: Maybe CsvPath
defaultValue = Maybe CsvPath
forall a. Maybe a
Nothing
  parseValue :: TestName -> Maybe (Maybe CsvPath)
parseValue = Maybe CsvPath -> Maybe (Maybe CsvPath)
forall a. a -> Maybe a
Just (Maybe CsvPath -> Maybe (Maybe CsvPath))
-> (TestName -> Maybe CsvPath) -> TestName -> Maybe (Maybe CsvPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsvPath -> Maybe CsvPath
forall a. a -> Maybe a
Just (CsvPath -> Maybe CsvPath)
-> (TestName -> CsvPath) -> TestName -> Maybe CsvPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> CsvPath
CsvPath
  optionName :: Tagged (Maybe CsvPath) TestName
optionName = TestName -> Tagged (Maybe CsvPath) TestName
forall a. a -> Tagged (Maybe CsvPath) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"csv"
  optionHelp :: Tagged (Maybe CsvPath) TestName
optionHelp = TestName -> Tagged (Maybe CsvPath) TestName
forall a. a -> Tagged (Maybe CsvPath) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"File to write results in CSV format"

-- Set of counters to use
newtype CounterSet = CounterSet { CounterSet -> [Counter]
getCounterSet :: [Counter] }

instance IsOption CounterSet where
  defaultValue :: CounterSet
defaultValue = [Counter] -> CounterSet
CounterSet [Counter
TOT_INS, Counter
TOT_CYC, Counter
BR_INS, Counter
BR_MSP]
  optionName :: Tagged CounterSet TestName
optionName = TestName -> Tagged CounterSet TestName
forall a. a -> Tagged CounterSet a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"counters"
  optionHelp :: Tagged CounterSet TestName
optionHelp = TestName -> Tagged CounterSet TestName
forall a. a -> Tagged CounterSet a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"Adjust set of counters to use"
  parseValue :: TestName -> Maybe CounterSet
parseValue = \case
    (Char
'=':TestName
s) -> [Counter] -> CounterSet
CounterSet ([Counter] -> CounterSet) -> Maybe [Counter] -> Maybe CounterSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> Maybe [Counter]
forall {a}. Read a => TestName -> Maybe [a]
parser TestName
s
    TestName
s       -> [Counter] -> CounterSet
CounterSet ([Counter] -> CounterSet)
-> ([Counter] -> [Counter]) -> [Counter] -> CounterSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Counter] -> [Counter]
forall a. Eq a => [a] -> [a]
nub ([Counter] -> [Counter])
-> ([Counter] -> [Counter]) -> [Counter] -> [Counter]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Counter]
def[Counter] -> [Counter] -> [Counter]
forall a. [a] -> [a] -> [a]
++) ([Counter] -> CounterSet) -> Maybe [Counter] -> Maybe CounterSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> Maybe [Counter]
forall {a}. Read a => TestName -> Maybe [a]
parser TestName
s
    where
      CounterSet [Counter]
def = CounterSet
forall v. IsOption v => v
defaultValue
      parser :: TestName -> Maybe [a]
parser TestName
s = case ReadS a
forall a. Read a => ReadS a
reads TestName
s of
        [(a
c,TestName
"")]     -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
c]
        [(a
c,Char
',':TestName
s')] -> (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> Maybe [a]
parser TestName
s'
        [(a, TestName)]
_            -> Maybe [a]
forall a. Maybe a
Nothing


----------------------------------------------------------------
-- Running benchmarks
----------------------------------------------------------------

-- | Just a 'TestTree'. This type synonym is provided for source compatibility with
--   @criterion@ and @gauge@.
--
-- @since 0.1
type Benchmark = TestTree

-- | IO action which could be benchmarked. It's created by 'whnf',
--   'nf', 'whnfIO', 'nfIO'.
--
-- @since 0.1
newtype Benchmarkable = Benchmarkable (IO ())

instance IsTest Benchmarkable where
  testOptions :: Tagged Benchmarkable [OptionDescription]
testOptions = [OptionDescription] -> Tagged Benchmarkable [OptionDescription]
forall a. a -> Tagged Benchmarkable a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  run :: OptionSet -> Benchmarkable -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (Benchmarkable IO ()
io) Progress -> IO ()
_
    | Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_threads = do
        (EventSet -> IO Result) -> IO Result
forall a. (EventSet -> IO a) -> IO a
withPapiEventSet ((EventSet -> IO Result) -> IO Result)
-> (EventSet -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \EventSet
evt -> do
          [Counter] -> (Counter -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Counter]
counters ((Counter -> IO ()) -> IO ()) -> (Counter -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Counter
c -> do
            TestName -> IO CInt -> IO ()
call (TestName
"Failed to add counter " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Counter -> TestName
forall a. Show a => a -> TestName
show Counter
c) (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSet -> CInt -> IO CInt
papi_add_event EventSet
evt (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Counter -> CInt
toCounter Counter
c
          Int -> (Ptr CLLong -> IO Result) -> IO Result
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray ([Counter] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Counter]
counters) ((Ptr CLLong -> IO Result) -> IO Result)
-> (Ptr CLLong -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \Ptr CLLong
vals -> do
            -- Evaluate benchmark once in order to ensure that all
            -- parameters are evaluated. Consider benchmarks
            --
            -- > bench "A" $ nf funA xs
            -- > bench "B" $ nf funB xs
            --
            -- Without calling `io' we'll count instruction needed to
            -- evaluate xs as well!
            IO ()
io
            -- We don't want to GC happen in the middle of benchmark
            -- just because previous benchmarks allocated enough to
            -- trigger it. This could bias measurement a lot since we
            -- run bencmark only once
            IO ()
performMajorGC
            Int64
n1 <- IO Int64
getAllocationCounter
            -- Perform measurement
            TestName -> IO CInt -> IO ()
call TestName
"Failed to start measurements" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSet -> IO CInt
papi_start EventSet
evt
            IO ()
io
            TestName -> IO CInt -> IO ()
call TestName
"Failed to stop measurements" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ EventSet -> Ptr CLLong -> IO CInt
papi_stop EventSet
evt Ptr CLLong
vals
            Int64
n2 <- IO Int64
getAllocationCounter
            let n_alloc :: CLLong
n_alloc = Int64 -> CLLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> CLLong) -> Int64 -> CLLong
forall a b. (a -> b) -> a -> b
$ Int64
n1Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-Int64
n2
            -- Read data
            [CLLong]
measurements <- ((Int, Counter) -> IO CLLong) -> [(Int, Counter)] -> IO [CLLong]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Ptr CLLong -> Int -> IO CLLong
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CLLong
vals (Int -> IO CLLong)
-> ((Int, Counter) -> Int) -> (Int, Counter) -> IO CLLong
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Counter) -> Int
forall a b. (a, b) -> a
fst) ([(Int, Counter)] -> IO [CLLong])
-> [(Int, Counter)] -> IO [CLLong]
forall a b. (a -> b) -> a -> b
$ [Int
0..] [Int] -> [Counter] -> [(Int, Counter)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Counter]
counters
            Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TestName -> Result
testPassed
                 (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ [CLLong] -> TestName
forall a. Show a => a -> TestName
show (CLLong
n_allocCLLong -> [CLLong] -> [CLLong]
forall a. a -> [a] -> [a]
:[CLLong]
measurements)
                TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"\t"
                     ( (TestName
"ALLOC="TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++CLLong -> TestName
showN CLLong
n_alloc)
                     TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: [ Counter -> TestName
forall a. Show a => a -> TestName
show Counter
c TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ (Char
'='Char -> TestName -> TestName
forall a. a -> [a] -> [a]
:CLLong -> TestName
showN CLLong
n)
                       | (Counter
c,CLLong
n) <- [Counter] -> [CLLong] -> [(Counter, CLLong)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Counter]
counters [CLLong]
measurements])


    | Bool
otherwise = Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TestName -> Result
testFailed
        TestName
"Benchmarks must not be run concurrently. Please pass -j1 or use single threaded runtime."
    where
      n_threads :: Int
n_threads = NumThreads -> Int
getNumThreads (NumThreads -> Int) -> NumThreads -> Int
forall a b. (a -> b) -> a -> b
$ OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
      counters :: [Counter]
counters  = CounterSet -> [Counter]
getCounterSet (CounterSet -> [Counter]) -> CounterSet -> [Counter]
forall a b. (a -> b) -> a -> b
$ OptionSet -> CounterSet
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

showN :: CLLong -> String
showN :: CLLong -> TestName
showN CLLong
n
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e4 = CLLong -> TestName
forall a. Show a => a -> TestName
show CLLong
n
  --
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e5 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.2fe3" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e3)
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e6 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.1fe3" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e3)
  --
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e7 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.3fe6" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e6)
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e8 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.2fe6" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e6)
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e9 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.1fe6" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e6)
  --
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e10 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.3fe9" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e9)
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e11 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.2fe9" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e9)
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e12 = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.1fe9" (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1e9)
  | Bool
otherwise = TestName -> Double -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%.3e" Double
x
  where x :: Double
x = CLLong -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLLong
n :: Double

-- | Create single benchmark. This is just a monomorphization of
--   'singleTest' which provides API compatibility with @criterion@
--   and @gauge@.
--
-- @since 0.1
bench :: String -> Benchmarkable -> TestTree
bench :: TestName -> Benchmarkable -> TestTree
bench = TestName -> Benchmarkable -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest

-- | Create single benchmark. This is just a 'testGroup' and it exists
--   to provide API compatibility with @criterion@ and @gauge@.
--
-- @since 0.1
bgroup :: String -> [Benchmark] -> Benchmark
bgroup :: TestName -> [TestTree] -> TestTree
bgroup = TestName -> [TestTree] -> TestTree
testGroup

-- | @nf f x@ measures number of instructions needed to compute normal
--   form of and application of @f@ to @x@.
--
-- @since 0.1
nf :: NFData b => (a -> b) -> a -> Benchmarkable
{-# NOINLINE nf #-}
nf :: forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf a -> b
f a
a = IO () -> Benchmarkable
Benchmarkable (IO () -> Benchmarkable) -> IO () -> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do b
_ <- b -> IO b
forall a. a -> IO a
evaluate (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ b -> b
forall a. NFData a => a -> a
force (a -> b
f a
a)
                            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | @nf f x@ measures number of instructions needed to compute weak
--   head normal form of and application of @f@ to @x@.
--
-- @since 0.1
whnf :: (a -> b) -> a -> Benchmarkable
{-# NOINLINE whnf #-}
whnf :: forall a b. (a -> b) -> a -> Benchmarkable
whnf a -> b
f a
a = IO () -> Benchmarkable
Benchmarkable (IO () -> Benchmarkable) -> IO () -> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do b
_ <- b -> IO b
forall a. a -> IO a
evaluate (a -> b
f a
a)
                              () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | @whnfIO a@ measures number of instructions needed to evaluate IO
--   action and reduce value returned by it to weak head normal form.
--
-- @since 0.1
whnfIO :: IO a -> Benchmarkable
{-# NOINLINE whnfIO #-}
whnfIO :: forall a. IO a -> Benchmarkable
whnfIO IO a
io = IO () -> Benchmarkable
Benchmarkable (IO () -> Benchmarkable) -> IO () -> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do a
_ <- a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
io
                               () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
-- | @nfIO a@ measures number of instructions needed to evaluate IO
--   action and reduce value returned by it to normal form.
--
-- @since 0.1
nfIO :: NFData a => IO a -> Benchmarkable
{-# NOINLINE nfIO #-}
nfIO :: forall a. NFData a => IO a -> Benchmarkable
nfIO IO a
io = IO () -> Benchmarkable
Benchmarkable (IO () -> Benchmarkable) -> IO () -> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do a
a <- IO a
io
                             a
_ <- a -> IO a
forall a. a -> IO a
evaluate (a -> a
forall a. NFData a => a -> a
force a
a)
                             () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Run benchmark suite. It provides API compatible with @criterion@ and @gauge@.
--
-- @since 0.1
defaultMain :: [TestTree] -> IO ()
defaultMain :: [TestTree] -> IO ()
defaultMain
  = [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
benchIngredients
  (TestTree -> IO ())
-> ([TestTree] -> TestTree) -> [TestTree] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestTree] -> TestTree
testGroup TestName
"All"


----------------------------------------------------------------
-- Reporters
----------------------------------------------------------------

-- | Standard set of ingredients which are used by 'defaultMain'
--
-- @since 0.1.2.0
benchIngredients :: [Ingredient]
benchIngredients :: [Ingredient]
benchIngredients =
  [ Ingredient
listingTests
  , Ingredient
consoleBenchReporter Ingredient -> Ingredient -> Ingredient
`composeReporters` Ingredient
csvReporter
  ]

-- | Reporter which prints results on benchmarks to stdout.
--
-- @since 0.1.2.0
consoleBenchReporter :: Ingredient
consoleBenchReporter :: Ingredient
consoleBenchReporter = ([TestName] -> Result -> IO Result) -> Ingredient
consoleTestReporterWithHook (([TestName] -> Result -> IO Result) -> Ingredient)
-> ([TestName] -> Result -> IO Result) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \[TestName]
_ Result
r -> do
  case forall a. Read a => ReadS a
reads @[CLLong] ReadS [CLLong] -> ReadS [CLLong]
forall a b. (a -> b) -> a -> b
$ Result -> TestName
resultDescription Result
r of
    [([CLLong]
_,TestName
s)] -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r { resultDescription :: TestName
resultDescription = TestName
s }
    [([CLLong], TestName)]
_       -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r

-- | Run benchmarks and save results in CSV format. It activates when
--   @--csv@ FILE command line option is specified.
--
-- @since 0.1.2.0
csvReporter :: Ingredient
csvReporter :: Ingredient
csvReporter = [OptionDescription]
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
TestReporter [Proxy (Maybe CsvPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Maybe CsvPath)), Proxy CounterSet -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @CounterSet)] ((OptionSet
  -> TestTree -> Maybe (StatusMap -> IO (Double -> IO Bool)))
 -> Ingredient)
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$
  \OptionSet
opts TestTree
tree -> do
    CsvPath TestName
path <- OptionSet -> Maybe CsvPath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    let CounterSet [Counter]
counters = OptionSet -> CounterSet
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    let names :: [TestName]
names    = OptionSet -> TestTree -> [TestName]
testsNames OptionSet
opts TestTree
tree
        namesMap :: IntMap TestName
namesMap = [(Int, TestName)] -> IntMap TestName
forall a. [(Int, a)] -> IntMap a
IM.fromDistinctAscList ([(Int, TestName)] -> IntMap TestName)
-> [(Int, TestName)] -> IntMap TestName
forall a b. (a -> b) -> a -> b
$ [Int] -> [TestName] -> [(Int, TestName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [TestName]
names
    (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StatusMap -> IO (Double -> IO Bool))
 -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
smap -> do
      case [TestName] -> Maybe TestName
forall a. Ord a => [a] -> Maybe a
findNonUniqueElement [TestName]
names of
        Maybe TestName
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just TestName
name -> TestName -> IO ()
forall a. TestName -> IO a
die (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName
"CSV report cannot proceed, because name '" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
name
                        TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"' corresponds to two or more benchmarks. Please disambiguate them."
      TestName -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. TestName -> IOMode -> (Handle -> IO r) -> IO r
withFile TestName
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
        Handle -> TestName -> IO ()
hPutStrLn Handle
h (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"," ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ TestName
"benchmark" TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: TestName
"ALLOC" TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: (Counter -> TestName
forall a. Show a => a -> TestName
show (Counter -> TestName) -> [Counter] -> [TestName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Counter]
counters)
        Handle -> IntMap (TestName, TVar Status) -> IO ()
csvOutput Handle
h (IntMap (TestName, TVar Status) -> IO ())
-> IntMap (TestName, TVar Status) -> IO ()
forall a b. (a -> b) -> a -> b
$ (TestName -> TVar Status -> (TestName, TVar Status))
-> IntMap TestName -> StatusMap -> IntMap (TestName, TVar Status)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
IM.intersectionWith (,) IntMap TestName
namesMap StatusMap
smap
      (Double -> IO Bool) -> IO (Double -> IO Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Double -> IO Bool) -> IO (Double -> IO Bool))
-> (Double -> IO Bool) -> IO (Double -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Double
_ -> StatusMap -> IO Bool
isSuccessful StatusMap
smap

isSuccessful :: StatusMap -> IO Bool
isSuccessful :: StatusMap -> IO Bool
isSuccessful = [TVar Status] -> IO Bool
go ([TVar Status] -> IO Bool)
-> (StatusMap -> [TVar Status]) -> StatusMap -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusMap -> [TVar Status]
forall a. IntMap a -> [a]
IM.elems
  where
    go :: [TVar Status] -> IO Bool
go [] = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    go (TVar Status
tv : [TVar Status]
tvs) = do
      Bool
b <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tv STM Status -> (Status -> STM Bool) -> STM Bool
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Status
s -> case Status
s of Done Result
r -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> Bool
resultSuccessful Result
r); Status
_ -> STM Bool
forall a. STM a
retry
      if Bool
b then [TVar Status] -> IO Bool
go [TVar Status]
tvs else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

findNonUniqueElement :: Ord a => [a] -> Maybe a
findNonUniqueElement :: forall a. Ord a => [a] -> Maybe a
findNonUniqueElement = Set a -> [a] -> Maybe a
forall {a}. Ord a => Set a -> [a] -> Maybe a
go Set a
forall a. Monoid a => a
mempty
  where
    go :: Set a -> [a] -> Maybe a
go Set a
_   [] = Maybe a
forall a. Maybe a
Nothing
    go Set a
acc (a
x : [a]
xs)
      | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
acc = a -> Maybe a
forall a. a -> Maybe a
Just a
x
      | Bool
otherwise          = Set a -> [a] -> Maybe a
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
acc) [a]
xs

csvOutput :: Handle -> IM.IntMap (TestName, TVar Status) -> IO ()
csvOutput :: Handle -> IntMap (TestName, TVar Status) -> IO ()
csvOutput Handle
h = ((TestName, TVar Status) -> IO ())
-> IntMap (TestName, TVar Status) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((TestName, TVar Status) -> IO ())
 -> IntMap (TestName, TVar Status) -> IO ())
-> ((TestName, TVar Status) -> IO ())
-> IntMap (TestName, TVar Status)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(TestName
name, TVar Status
tv) -> do
  Result
r <- STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tv STM Status -> (Status -> STM Result) -> STM Result
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Done Result
r -> Result -> STM Result
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
    Status
_      -> STM Result
forall a. STM a
retry
  case forall a. Read a => ReadS a
reads @[CLLong] ReadS [CLLong] -> ReadS [CLLong]
forall a b. (a -> b) -> a -> b
$ Result -> TestName
resultDescription Result
r of
    [([CLLong]
meas,TestName
_)] -> Handle -> TestName -> IO ()
hPutStrLn Handle
h (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"," ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ TestName -> TestName
encodeCsv TestName
name TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: (CLLong -> TestName
forall a. Show a => a -> TestName
show (CLLong -> TestName) -> [CLLong] -> [TestName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CLLong]
meas)
    [([CLLong], TestName)]
_          -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

encodeCsv :: String -> String
encodeCsv :: TestName -> TestName
encodeCsv TestName
xs
  | (Char -> Bool) -> TestName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> TestName -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestName
xs) TestName
",\"\n\r" = Char
'"' Char -> TestName -> TestName
forall a. a -> [a] -> [a]
: TestName -> TestName
go TestName
xs
  | Bool
otherwise                 = TestName
xs
  where
    go :: TestName -> TestName
go []         = Char
'"' Char -> TestName -> TestName
forall a. a -> [a] -> [a]
: []
    go (Char
'"' : TestName
ys) = Char
'"' Char -> TestName -> TestName
forall a. a -> [a] -> [a]
: Char
'"' Char -> TestName -> TestName
forall a. a -> [a] -> [a]
: TestName -> TestName
go TestName
ys
    go (Char
y   : TestName
ys) = Char
y   Char -> TestName -> TestName
forall a. a -> [a] -> [a]
: TestName -> TestName
go TestName
ys