tasty-papi (empty) → 0.1

raw patch · 6 files changed

+854/−0 lines, 6 filesdep +basedep +containersdep +deepseq

Dependencies added: base, containers, deepseq, stm, tasty, tasty-papi

Files

Changelog.md +0/−0
LICENSE +30/−0
README.md +13/−0
Test/Tasty/PAPI.hs +722/−0
tasty-papi.cabal +51/−0
tests/Main.hs +38/−0

+ Changelog.md view

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) Alexey Khudyakov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,13 @@+# tasti-papi++This is another approach to benchmarking which uses counting of CPU instructions+instead of time measurements. Underlying hardware counters are accessed using+[PAPI](https://icl.utk.edu/papi/) library so all hardware and OS support is+inherited from there.++This approach is suitable for benchmarking CPU bound code. Instruction count is+only proxy for code performance but it has advantage of being+deterministic. Timing measurements are affected by concurrent workloads and require+dedicated hardware in order to get precise measurements. Instruction counting is+not affected by this so it could be run as part of CI and used to detect+performance regressions.

+ Test/Tasty/PAPI.hs view

@@ -0,0 +1,722 @@+{-# LANGUAGE CApiFFI                    #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE ForeignFunctionInterface   #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# 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 @test-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+    Test.Tasty.PAPI.defaultMain+  , Benchmark+  , Benchmarkable(..)+  , bench+  , bgroup+    -- * Creation of Benchmarkable+  , nf+  , whnf+  , nfIO+  , whnfIO+    -- * 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+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 (Show, 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++-- Call PAPI function and return error code+call :: IO CInt -> IO ()+call f = f >>= \case+  n | n == papi_OK -> pure ()+    | otherwise    -> error $ "PAPI call failed: " ++ show n++-- Create event set for use with PAPI+withPapiEventSet :: (EventSet -> IO a) -> IO a+withPapiEventSet action = do+  -- Initialize library. It seems that calling it multiple times is safe+  do n <- papi_library_init papi_VER_CURRENT+     when (n /= papi_VER_CURRENT) $ error "PAPI init failed"+  bracket ini fini action+  where+    ini = alloca $ \p_evt -> do+      poke p_evt (EventSet papi_NULL)+      call $ papi_create_eventset p_evt+      peek p_evt+    fini evt = do+      call $ papi_cleanup_eventset evt+      alloca $ \p_evt -> do+        poke p_evt evt+        call $ papi_destroy_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 (Show,Read,Eq,Ord)+++toCounter :: Counter -> CInt+toCounter = \case+  L1_DCM  -> papi_L1_DCM+  L1_ICM  -> papi_L1_ICM+  L2_DCM  -> papi_L2_DCM+  L2_ICM  -> papi_L2_ICM+  L3_DCM  -> papi_L3_DCM+  L3_ICM  -> papi_L3_ICM+  L1_TCM  -> papi_L1_TCM+  L2_TCM  -> papi_L2_TCM+  L3_TCM  -> papi_L3_TCM+  CA_SNP  -> papi_CA_SNP+  CA_SHR  -> papi_CA_SHR+  CA_CLN  -> papi_CA_CLN+  CA_INV  -> papi_CA_INV+  CA_ITV  -> papi_CA_ITV+  L3_LDM  -> papi_L3_LDM+  L3_STM  -> papi_L3_STM+  BRU_IDL -> papi_BRU_IDL+  FXU_IDL -> papi_FXU_IDL+  FPU_IDL -> papi_FPU_IDL+  LSU_IDL -> papi_LSU_IDL+  TLB_DM  -> papi_TLB_DM+  TLB_IM  -> papi_TLB_IM+  TLB_TL  -> papi_TLB_TL+  L1_LDM  -> papi_L1_LDM+  L1_STM  -> papi_L1_STM+  L2_LDM  -> papi_L2_LDM+  L2_STM  -> papi_L2_STM+  BTAC_M  -> papi_BTAC_M+  PRF_DM  -> papi_PRF_DM+  L3_DCH  -> papi_L3_DCH+  TLB_SD  -> papi_TLB_SD+  CSR_FAL -> papi_CSR_FAL+  CSR_SUC -> papi_CSR_SUC+  CSR_TOT -> papi_CSR_TOT+  MEM_SCY -> papi_MEM_SCY+  MEM_RCY -> papi_MEM_RCY+  MEM_WCY -> papi_MEM_WCY+  STL_ICY -> papi_STL_ICY+  FUL_ICY -> papi_FUL_ICY+  STL_CCY -> papi_STL_CCY+  FUL_CCY -> papi_FUL_CCY+  HW_INT  -> papi_HW_INT+  BR_UCN  -> papi_BR_UCN+  BR_CN   -> papi_BR_CN+  BR_TKN  -> papi_BR_TKN+  BR_NTK  -> papi_BR_NTK+  BR_MSP  -> papi_BR_MSP+  BR_PRC  -> papi_BR_PRC+  FMA_INS -> papi_FMA_INS+  TOT_IIS -> papi_TOT_IIS+  TOT_INS -> papi_TOT_INS+  INT_INS -> papi_INT_INS+  FP_INS  -> papi_FP_INS+  LD_INS  -> papi_LD_INS+  SR_INS  -> papi_SR_INS+  BR_INS  -> papi_BR_INS+  VEC_INS -> papi_VEC_INS+  RES_STL -> papi_RES_STL+  FP_STAL -> papi_FP_STAL+  TOT_CYC -> papi_TOT_CYC+  LST_INS -> papi_LST_INS+  SYC_INS -> papi_SYC_INS+  L1_DCH  -> papi_L1_DCH+  L2_DCH  -> papi_L2_DCH+  L1_DCA  -> papi_L1_DCA+  L2_DCA  -> papi_L2_DCA+  L3_DCA  -> papi_L3_DCA+  L1_DCR  -> papi_L1_DCR+  L2_DCR  -> papi_L2_DCR+  L3_DCR  -> papi_L3_DCR+  L1_DCW  -> papi_L1_DCW+  L2_DCW  -> papi_L2_DCW+  L3_DCW  -> papi_L3_DCW+  L1_ICH  -> papi_L1_ICH+  L2_ICH  -> papi_L2_ICH+  L3_ICH  -> papi_L3_ICH+  L1_ICA  -> papi_L1_ICA+  L2_ICA  -> papi_L2_ICA+  L3_ICA  -> papi_L3_ICA+  L1_ICR  -> papi_L1_ICR+  L2_ICR  -> papi_L2_ICR+  L3_ICR  -> papi_L3_ICR+  L1_ICW  -> papi_L1_ICW+  L2_ICW  -> papi_L2_ICW+  L3_ICW  -> papi_L3_ICW+  L1_TCH  -> papi_L1_TCH+  L2_TCH  -> papi_L2_TCH+  L3_TCH  -> papi_L3_TCH+  L1_TCA  -> papi_L1_TCA+  L2_TCA  -> papi_L2_TCA+  L3_TCA  -> papi_L3_TCA+  L1_TCR  -> papi_L1_TCR+  L2_TCR  -> papi_L2_TCR+  L3_TCR  -> papi_L3_TCR+  L1_TCW  -> papi_L1_TCW+  L2_TCW  -> papi_L2_TCW+  L3_TCW  -> papi_L3_TCW+  FML_INS -> papi_FML_INS+  FAD_INS -> papi_FAD_INS+  FDV_INS -> papi_FDV_INS+  FSQ_INS -> papi_FSQ_INS+  FNV_INS -> papi_FNV_INS+++----------------------------------------------------------------+--+----------------------------------------------------------------++++newtype CsvPath = CsvPath FilePath++instance IsOption (Maybe CsvPath) where+  defaultValue = Nothing+  parseValue = Just . Just . CsvPath+  optionName = pure "csv"+  optionHelp = pure "File to write results in CSV format"++-- Set of counters to use+newtype CounterSet = CounterSet { getCounterSet :: [Counter] }++instance IsOption CounterSet where+  defaultValue = CounterSet [TOT_INS, TOT_CYC, BR_INS, BR_MSP]+  optionName = pure "counters"+  optionHelp = pure "Adjust set of counters to use"+  parseValue = \case+    ('=':s) -> CounterSet <$> parser s+    s       -> CounterSet . nub . (def++) <$> parser s+    where+      CounterSet def = defaultValue+      parser s = case reads s of+        [(c,"")]     -> Just [c]+        [(c,',':s')] -> (c:) <$> parser s'+        _            -> 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 = pure []+  run opts (Benchmarkable io) _+    | 1 == n_threads = do+        withPapiEventSet $ \evt -> do+          forM_ counters $ call . papi_add_event evt . toCounter+          allocaArray (length counters) $ \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+            -- 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+            performMajorGC+            n1 <- getAllocationCounter+            -- Perform measurement+            call $ papi_start evt+            io+            call $ papi_stop evt vals+            n2 <- getAllocationCounter+            let n_alloc = fromIntegral $ n1-n2+            -- Read data+            measurements <- traverse (peekElemOff vals . fst) $ [0..] `zip` counters+            pure $ testPassed+                 $ show (n_alloc:measurements)+                ++ intercalate "\t"+                     ( ("ALLOC="++showN n_alloc)+                     : [ show c ++ ('=':showN n)+                       | (c,n) <- zip counters measurements])+++    | otherwise = pure $ testFailed+        "Benchmarks must not be run concurrently. Please pass -j1 or use single threaded runtime."+    where+      n_threads = getNumThreads $ lookupOption opts+      counters  = getCounterSet $ lookupOption opts++showN :: CLLong -> String+showN n+  | x < 1e4 = show n+  --+  | x < 1e5 = printf "%.2fe3" (x/1e3)+  | x < 1e6 = printf "%.1fe3" (x/1e3)+  --+  | x < 1e7 = printf "%.3fe6" (x/1e6)+  | x < 1e8 = printf "%.2fe6" (x/1e6)+  | x < 1e9 = printf "%.1fe6" (x/1e6)+  --+  | x < 1e10 = printf "%.3fe9" (x/1e9)+  | x < 1e11 = printf "%.2fe9" (x/1e9)+  | x < 1e12 = printf "%.1fe9" (x/1e9)+  | otherwise = printf "%.3e" x+  where x = fromIntegral 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 = 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 = 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 f a = Benchmarkable $ do _ <- evaluate $ force (f 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 f a = Benchmarkable $ do _ <- evaluate (f 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 io = Benchmarkable $ do _ <- evaluate =<< io+                               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 io = Benchmarkable $ do a <- io+                             _ <- evaluate (force a)+                             return ()++-- | Run benchmark suite. It provides API compatible with @criterion@ and @gauge@.+--+-- @since 0.1+defaultMain :: [TestTree] -> IO ()+defaultMain+  = defaultMainWithIngredients [ listingTests+                               , consoleBenchReporter `composeReporters` csvReporter+                               ]+  . testGroup "All"+++----------------------------------------------------------------+-- Reporters+----------------------------------------------------------------++consoleBenchReporter :: Ingredient+consoleBenchReporter = consoleTestReporterWithHook $ \_ r -> do+  case reads @[CLLong] $ resultDescription r of+    [(_,s)] -> pure r { resultDescription = s }+    _       -> pure r++csvReporter :: Ingredient+csvReporter = TestReporter [Option (Proxy @(Maybe CsvPath)), Option (Proxy @CounterSet)] $+  \opts tree -> do+    CsvPath path <- lookupOption opts+    let CounterSet counters = lookupOption opts+    let names    = testsNames opts tree+        namesMap = IM.fromDistinctAscList $ zip [0..] names+    pure $ \smap -> do+      case findNonUniqueElement names of+        Nothing -> pure ()+        Just name -> die $ "CSV report cannot proceed, because name '" ++ name+                        ++ "' corresponds to two or more benchmarks. Please disambiguate them."+      withFile path WriteMode $ \h -> do+        hSetBuffering h LineBuffering+        hPutStrLn h $ intercalate "," $ "ALLOC" : (show <$> counters)+        csvOutput h $ IM.intersectionWith (,) namesMap smap+      pure $ \_ -> isSuccessful smap++isSuccessful :: StatusMap -> IO Bool+isSuccessful = go . IM.elems+  where+    go [] = pure True+    go (tv : tvs) = do+      b <- atomically $ readTVar tv >>= \s -> case s of Done r -> pure (resultSuccessful r); _ -> retry+      if b then go tvs else pure False++findNonUniqueElement :: Ord a => [a] -> Maybe a+findNonUniqueElement = go mempty+  where+    go _   [] = Nothing+    go acc (x : xs)+      | x `Set.member` acc = Just x+      | otherwise          = go (Set.insert x acc) xs++csvOutput :: Handle -> IM.IntMap (TestName, TVar Status) -> IO ()+csvOutput h = traverse_ $ \(name, tv) -> do+  r <- atomically $ readTVar tv >>= \case+    Done r -> pure r+    _      -> retry+  case reads @[CLLong] $ resultDescription r of+    [(meas,_)] -> hPutStrLn h $ intercalate "," $ encodeCsv name : (show <$> meas)+    _          -> pure ()++encodeCsv :: String -> String+encodeCsv xs+  | any (`elem` xs) ",\"\n\r" = '"' : go xs+  | otherwise                 = xs+  where+    go []         = '"' : []+    go ('"' : ys) = '"' : '"' : go ys+    go (y   : ys) = y   : go ys

+ tasty-papi.cabal view

@@ -0,0 +1,51 @@+name:          tasty-papi+version:       0.1+cabal-version: 1.18+license:       BSD3+license-file:  LICENSE+copyright:     2023, Alexey Khudyakov+author:        Alexey Khudyakov <alexey.skladnoy@gmail.com>+maintainer:    Alexey Khudyakov <alexey.skladnoy@gmail.com>+homepage:      https://github.com/Shimuuar/tasty-bench+bug-reports:   https://github.com/Bodigrim/tasty-bench/issues+category:      Development, Performance, Testing, Benchmarking+build-type:    Simple++Synopsis:+  Bencmarking using instruction counting+description:+  Benchmarking framework which uses instruction counters intead of+  time measurements. Instruction count is only proxy for code+  performance but unlike time could be measured deterministically.+  PAPI is used in order to access hardware counters. ++extra-source-files:+  README.md+  Changelog.md++source-repository head+  type:     git+  location: http://github.com/Shimuuar/tasty-papi++Library+  default-language: Haskell2010+  ghc-options:      -Wall+  --+  Build-Depends:    base            >=4.10 && <5+                  , tasty           >=0.11.3+                  , containers      >=0.5+                  , deepseq+                  , stm+  extra-libraries: papi+  Exposed-modules: Test.Tasty.PAPI++test-suite tasty-papi-run+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  ghc-options:      -Wall+  main-is:          Main.hs+  hs-source-dirs:   tests+  --+  Build-Depends:    base        -any+                  , tasty       -any+                  , tasty-papi  -any

+ tests/Main.hs view

@@ -0,0 +1,38 @@+-- |+module Main where++import Control.Monad+import Data.IORef+import Data.Function+import Test.Tasty.PAPI++main :: IO ()+main = defaultMain+  [ bgroup "Fib"+    [ bench (show n) $ whnf fib n+    | n <- [6..10]+    ]+  , bgroup "Parameter evaluation"+    [ bench "Eval1" $ whnf sum constant+    , bench "Eval2" $ whnf sum constant+    ]+  , bgroup "Misc"+    [ -- Show performance regression between 9.2 and 9.4+      bench "IORef regression" $ whnfIO $ do+        ref <- newIORef (1000 :: Int)+        fix $ \loop -> do+          x <- readIORef ref+          unless (x == 0) $ do+            writeIORef ref $ x - 1+            loop+        readIORef ref+    ]+  ]++fib :: Integer -> Integer+fib 0 = 0+fib 1 = 1+fib n = fib (n-1) + fib (n-2)++constant :: [Int]+constant = [1 .. 1000]