hs_try_putmvar003.hs 2.63 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
2
3
4
5
6
7
8
9
10
11
12
{-# LANGUAGE MagicHash #-}
module Main where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign hiding (void)
import Foreign.C
import GHC.Conc
import GHC.MVar (MVar(..))
import GHC.Prim
import System.Environment
13
import System.Exit
Simon Marlow's avatar
Simon Marlow committed
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

-- Measure C to Haskell callback throughput under a workload with
-- several dimensions:
--
--  * X callback queues (each managed by an OS thread in C)
--  * each queue has Y Haskell threads, each making Z requests
--
-- And we can run the whole thing in two ways:
--  * With the callbacks calling into a foreign export
--  * With the callbacks using hs_try_putmvar()
--
-- Example results (using WAY=threaded2)
--
--  hs_try_putmvar003 1 64 16 500 +RTS -s -N4    1.10s
--  hs_try_putmvar003 2 64 16 500 +RTS -s -N4    9.88s
--
-- hs_try_putmvar() is 9x faster with these parameters.

main = do
33
34
   when (not rtsSupportsBoundThreads) $
     die "This test requires -threaded"
Simon Marlow's avatar
Simon Marlow committed
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
   args <- getArgs
   case args of
     ["1",x,y,z] -> experiment False (read x) (read y) (read z)
     ["2",x,y,z] -> experiment True (read x) (read y) (read z)

makeExternalCall :: Ptr CallbackQueue -> IO CInt
makeExternalCall q = mask_ $ do
  mvar <- newEmptyMVar
  sp <- newStablePtrPrimMVar mvar
  fp <- mallocForeignPtr
  (cap,_) <- threadCapability =<< myThreadId
  withForeignPtr fp $ \presult -> do
    scheduleCallback q sp cap presult
    takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp)
    peek presult

data CallbackQueue

foreign import ccall "mkCallbackQueue"
  mkCallbackQueue :: Int -> IO (Ptr CallbackQueue)

foreign import ccall "destroyCallbackQueue"
  destroyCallbackQueue :: Ptr CallbackQueue -> IO ()

foreign import ccall "scheduleCallback"
  scheduleCallback :: Ptr CallbackQueue
                   -> StablePtr PrimMVar
                   -> Int
                   -> Ptr CInt
                   -> IO ()

callbackPutMVar :: StablePtr PrimMVar -> IO ()
callbackPutMVar sp = do
  mvar <- deRefStablePtr sp
  void $ tryPutMVar (MVar (unsafeCoerce# mvar)) ()

foreign export ccall callbackPutMVar :: StablePtr PrimMVar -> IO ()

-- Make
--   * x callback queues, each with
--   * y threads, doing
--   * z requests each
experiment :: Bool -> Int -> Int -> Int -> IO ()
experiment use_foreign_export x y z = do
  mvars <- replicateM x $ async $ do
    bracket (mkCallbackQueue (fromEnum use_foreign_export))
            destroyCallbackQueue $ \q -> do
      mvars <- replicateM y $ async $
        replicateM_ z $ void $ makeExternalCall q
      mapM_ takeMVar mvars
  mapM_ takeMVar mvars

async :: IO () -> IO (MVar ())
async io = do
  m <- newEmptyMVar
  forkFinally io (\_ -> putMVar m ())
  return m