Add some SMP and threading benchmarks I have lying around
authorSimon Marlow <simonmar@microsoft.com>
Mon, 27 Mar 2006 13:02:30 +0000 (13:02 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Mon, 27 Mar 2006 13:02:30 +0000 (13:02 +0000)
23 files changed:
smp/Makefile [new file with mode: 0644]
smp/callback001/Main.hs [new file with mode: 0644]
smp/callback001/Makefile [new file with mode: 0644]
smp/callback001/callback001.stdout [new file with mode: 0644]
smp/callback001/cbits.c [new file with mode: 0644]
smp/callback001/cbits.h [new file with mode: 0644]
smp/sieve/Makefile [new file with mode: 0644]
smp/sieve/README [new file with mode: 0644]
smp/sieve/sieve.hs [new file with mode: 0644]
smp/smpbench.sh [new file with mode: 0644]
smp/stm001/Makefile [new file with mode: 0644]
smp/stm001/StmTest.hs [new file with mode: 0644]
smp/stm002/StmTest2.hs [new file with mode: 0644]
smp/systolic/Main.hs [new file with mode: 0644]
smp/threads001/Main.hs [new file with mode: 0644]
smp/threads001/Makefile [new file with mode: 0644]
smp/threads001/threads001.stdout [new file with mode: 0644]
smp/threads002/Main.hs [new file with mode: 0644]
smp/threads002/Makefile [new file with mode: 0644]
smp/threads003/Main.hs [new file with mode: 0644]
smp/threads003/Makefile [new file with mode: 0644]
smp/threads004/Main.hs [new file with mode: 0644]
smp/threads004/Makefile [new file with mode: 0644]

diff --git a/smp/Makefile b/smp/Makefile
new file mode 100644 (file)
index 0000000..06c9bf6
--- /dev/null
@@ -0,0 +1,18 @@
+TOP = ..
+include $(TOP)/mk/boilerplate.mk
+
+SUBDIRS = \
+       sieve \
+       stm001 \
+       callback001 \
+       threads001 \
+       threads003
+
+# later:
+#  stm02
+
+# Not a good benchmark, can go really slowly for random reasons:
+#  threads002
+
+include $(TOP)/mk/target.mk
+
diff --git a/smp/callback001/Main.hs b/smp/callback001/Main.hs
new file mode 100644 (file)
index 0000000..8aa5f62
--- /dev/null
@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -fffi #-}\r
+-- This benchmark is also ffi014 in the test suite.\r
+\r
+module Main where\r
+\r
+import Control.Concurrent\r
+import Control.Monad\r
+import Foreign.Ptr\r
+import Data.IORef\r
+import System.Environment\r
+import System.IO\r
+\r
+main = do\r
+  [s] <- getArgs\r
+  let n = read s :: Int\r
+  sem <- newQSemN 0\r
+  replicateM n (putStr "." >> hFlush stdout >> forkOS (thread sem) >> thread sem)\r
+  waitQSemN sem (n*2)\r
+\r
+thread sem = do\r
+  var <- newIORef 0\r
+  let f = modifyIORef var (1+)\r
+  callC =<< mkFunc f\r
+  signalQSemN sem 1\r
+\r
+type FUNC  =  IO ()\r
+\r
+foreign import ccall unsafe "wrapper"\r
+   mkFunc :: FUNC -> IO (FunPtr FUNC)\r
+\r
+foreign import ccall threadsafe "cbits.h callC"\r
+   callC:: FunPtr FUNC -> IO ()\r
+\r
diff --git a/smp/callback001/Makefile b/smp/callback001/Makefile
new file mode 100644 (file)
index 0000000..0e7491f
--- /dev/null
@@ -0,0 +1,10 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 100
+NORM_OPTS = 200
+SLOW_OPTS = 500
+
+OBJS += Main_stub.o
+
+include $(TOP)/mk/target.mk
diff --git a/smp/callback001/callback001.stdout b/smp/callback001/callback001.stdout
new file mode 100644 (file)
index 0000000..e003cf1
--- /dev/null
@@ -0,0 +1 @@
+........................................................................................................................................................................................................
\ No newline at end of file
diff --git a/smp/callback001/cbits.c b/smp/callback001/cbits.c
new file mode 100644 (file)
index 0000000..ef96c23
--- /dev/null
@@ -0,0 +1,6 @@
+#include "cbits.h"\r
+\r
+void callC( FUNC* f) {\r
+   int i;\r
+   for(i=0;i<1000;i++) f();\r
+}\r
diff --git a/smp/callback001/cbits.h b/smp/callback001/cbits.h
new file mode 100644 (file)
index 0000000..d0d8517
--- /dev/null
@@ -0,0 +1,3 @@
+typedef void FUNC();\r
+\r
+void callC( FUNC* f);\r
diff --git a/smp/sieve/Makefile b/smp/sieve/Makefile
new file mode 100644 (file)
index 0000000..c18f2f1
--- /dev/null
@@ -0,0 +1,8 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 10
+NORM_OPTS = 100
+SLOW_OPTS = 500
+
+include $(TOP)/mk/target.mk
diff --git a/smp/sieve/README b/smp/sieve/README
new file mode 100644 (file)
index 0000000..7ad01af
--- /dev/null
@@ -0,0 +1,34 @@
+We get very poor speedup with -N2 on this example:
+
+~/builds/64smp/nofib/smp/sieve > time ./sieve 100 +RTS -N1
+1,422,224,616 bytes allocated in the heap
+ 45,371,544 bytes copied during GC (scavenged)
+  1,644,576 bytes copied during GC (not scavenged)
+     85,608 bytes maximum residency (8 sample(s))
+...
+2.16s real   2.16s user   0.00s system   99% ./sieve 100 +RTS -N1 -sstderr
+
+~/builds/64smp/nofib/smp/sieve > time ./sieve 100 +RTS -N2
+1,422,223,024 bytes allocated in the heap
+936,650,456 bytes copied during GC (scavenged)
+ 52,740,464 bytes copied during GC (not scavenged)
+  4,002,560 bytes maximum residency (154 sample(s))
+...
+6.48s real   7.58s user   0.03s system   117% ./sieve 100 +RTS -N2 -sstderr
+
+A lot more bytes shifted during GC.  If we up the heap size:
+
+~/builds/64smp/nofib/smp/sieve > time ./sieve 100 +RTS -N2 -sstderr -H32m
+./sieve 100 +RTS -N2 -sstderr -H32m 
+1,422,261,808 bytes allocated in the heap
+ 47,046,320 bytes copied during GC (scavenged)
+  1,277,408 bytes copied during GC (not scavenged)
+    657,848 bytes maximum residency (12 sample(s))
+...
+1.68s real   2.90s user   0.06s system   175% ./sieve 100 +RTS -N2 -sstderr -H32m
+
+A lot of stuff moving into the old generation, perhaps?  
+
+This is not due to old-gen updates, because we have lock-free old-gen
+updates now.
+
diff --git a/smp/sieve/sieve.hs b/smp/sieve/sieve.hs
new file mode 100644 (file)
index 0000000..42582cb
--- /dev/null
@@ -0,0 +1,29 @@
+-------------------------------------------------------------------------------
+-- $Id: Primes.hs#1 2005/06/13 15:48:09 REDMOND\\satnams $
+-------------------------------------------------------------------------------
+-- Satnam reported that this didn't show any speedup up from -N1 to -N4
+
+module Main where
+import System.Time
+import Control.Concurrent
+import System.Environment
+-- how many primes to calculate in each thread
+n_primes :: Int
+n_primes = 500
+
+primes1 n done
+  = do --putStrLn (show ((sieve [n..])!!n_primes))
+       show ((sieve [n..])!!n_primes) `seq` return ()
+       putMVar done ()
+sieve (p:xs) = p : sieve [x | x <- xs, not (x `mod` p == 0)]
+main
+  = do 
+       [str] <- getArgs
+       let instances = read str :: Int
+       dones <- sequence (replicate instances newEmptyMVar)
+       sequence_ [forkIO (primes1 (i+2) (dones!!i)) | i <- [0..instances-1]]
+       sequence_ [takeMVar (dones!!i) | i <- [0..instances-1]]
diff --git a/smp/smpbench.sh b/smp/smpbench.sh
new file mode 100644 (file)
index 0000000..d4a9705
--- /dev/null
@@ -0,0 +1,11 @@
+#! /bin/sh
+
+make clean boot
+make -k |& tee log-normal
+make clean boot
+make -k EXTRA_HC_OPTS=-threaded |& tee log-threaded
+make clean boot
+make -k EXTRA_HC_OPTS=-smp |& tee log-smp-N1
+make -k EXTRA_HC_OPTS=-smp EXTRA_RUNTEST_OPTS='+RTS -N2 -RTS' |& tee log-smp-N2
+make -k EXTRA_HC_OPTS=-smp EXTRA_RUNTEST_OPTS='+RTS -N8 -RTS' |& tee log-smp-N8
+make -k EXTRA_HC_OPTS=-smp EXTRA_RUNTEST_OPTS='+RTS -N16 -RTS' |& tee log-smp-N16
diff --git a/smp/stm001/Makefile b/smp/stm001/Makefile
new file mode 100644 (file)
index 0000000..0f5e0c7
--- /dev/null
@@ -0,0 +1,6 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_HC_OPTS += -package stm
+
+include $(TOP)/mk/target.mk
diff --git a/smp/stm001/StmTest.hs b/smp/stm001/StmTest.hs
new file mode 100644 (file)
index 0000000..81014d0
--- /dev/null
@@ -0,0 +1,62 @@
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO
+
+data State = State {
+  vt :: TVar Int,
+  vm :: MVar Int,
+  chan :: TChan (),
+  count :: TVar Int
+  }
+
+loopmax = 100000
+numthreads = 50
+
+main
+  = do t <- atomically (newTVar 0)
+       m <- newEmptyMVar
+       putMVar m 0
+       c <- atomically (newTChan)
+       cnt <- atomically (newTVar 0)
+       let st = State t m c cnt
+       forkIter numthreads (proc st domv loopmax)
+       atomically (readTChan c)
+       return ()
+
+proc :: State -> (State -> IO ()) -> Int -> IO ()
+proc st w 0 = do c <- atomically (do cnt <- readTVar (count st)
+                                     writeTVar (count st) (cnt+1)
+                                     if cnt+1 >= numthreads
+                                        then writeTChan (chan st) ()
+                                        else return ()
+                                     return cnt)
+                 return ()
+proc st w i
+  = do w st
+       proc st w (i-1)
+
+dotv :: State -> IO ()
+dotv st
+  = do n <- atomically (do n <- readTVar (vt st)
+                           writeTVar (vt st) (n+1)
+                           return n)
+       return ()
+
+domv :: State -> IO ()
+domv st
+  = do n <- takeMVar (vm st)
+       putMVar (vm st) (n+1)
+       return ()
+
+forkIter :: Int -> IO () -> IO ()
+forkIter n p
+  = iter n (do forkIO p
+               return ())
+
+iter :: Int -> IO () -> IO ()
+iter 0 _ = return ()
+iter n f
+  = do f
+       iter (n-1) f
diff --git a/smp/stm002/StmTest2.hs b/smp/stm002/StmTest2.hs
new file mode 100644 (file)
index 0000000..5ed8f7e
--- /dev/null
@@ -0,0 +1,164 @@
+module Main where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO
+
+data StateM = StateM {
+  i :: Int,
+  s :: String,
+  b :: Bool
+  }
+
+data State = State {
+  ti :: TVar Int,
+  ts :: TVar String,
+  tb :: TVar Bool,
+
+  mv :: MVar StateM,
+
+  chan :: TChan (),
+  count :: TVar Int
+  }
+
+loopmax = 100000
+numthreads = 10
+
+main
+  = do i <- atomically (newTVar 0)
+       s <- atomically (newTVar "1")
+       b <- atomically (newTVar False)
+       m <- newEmptyMVar
+       let sm = StateM 0 "1" False
+       putMVar m sm
+       c <- atomically (newTChan)
+       cnt <- atomically (newTVar 0)
+       let st = State i s b m c cnt
+{-
+       forkIter numthreads (proc st tvir loopmax)
+       forkIter numthreads (proc st tvirw loopmax)
+       forkIter numthreads (proc st tvsr loopmax)
+       forkIter numthreads (proc st tvsrw loopmax)
+       forkIter numthreads (proc st tvbr loopmax)
+       forkIter numthreads (proc st tvbrw loopmax)
+-}
+       forkIter numthreads (proc st mvir loopmax)
+       forkIter numthreads (proc st mvirw loopmax)
+       forkIter numthreads (proc st mvsr loopmax)
+       forkIter numthreads (proc st mvsrw loopmax)
+       forkIter numthreads (proc st mvbr loopmax)
+       forkIter numthreads (proc st mvbrw loopmax)
+
+       atomically (readTChan c)
+       return ()
+
+proc :: State -> (State -> IO ()) -> Int -> IO ()
+proc st w 0 = do c <- atomically (do cnt <- readTVar (count st)
+                                     writeTVar (count st) (cnt+1)
+                                     if cnt+1 >= (numthreads*6)
+                                        then writeTChan (chan st) ()
+                                        else return ()
+                                     return cnt)
+                 return ()
+proc st w i
+  = do w st
+       proc st w (i-1)
+
+tvir :: State -> IO ()
+tvir st
+  = do n <- atomically (readTVar (ti st))
+       return ()
+
+tvirw :: State -> IO ()
+tvirw st
+  = do n <- atomically (do n <- readTVar (ti st)
+                           writeTVar (ti st) (n+1)
+                           return n)
+       return ()
+
+tvsr :: State -> IO ()
+tvsr st
+  = do s <- atomically (readTVar (ts st))
+       return ()
+
+tvsrw :: State -> IO ()
+tvsrw st
+  = do s <- atomically (do s <- readTVar (ts st)
+                           writeTVar (ts st) (randomString s)
+                           return s)
+       return ()
+
+tvbr :: State -> IO ()
+tvbr st
+  = do b <- atomically (readTVar (tb st))
+       return ()
+
+tvbrw :: State -> IO ()
+tvbrw st
+  = do b <- atomically (do b <- readTVar (tb st)
+                           writeTVar (tb st) (not b)
+                           return b)
+       return ()
+
+mvir :: State -> IO ()
+mvir st
+  = do m <- takeMVar (mv st)
+       let i2 = (i m)
+       putMVar (mv st) m
+       return ()
+
+mvirw :: State -> IO ()
+mvirw st
+  = do m <- takeMVar (mv st)
+       let i2 = (i m)
+           m2 = StateM (i2+1) (s m) (b m)
+       putMVar (mv st) m2
+       return ()
+
+mvsr :: State -> IO ()
+mvsr st
+  = do m <- takeMVar (mv st)
+       let s2 = (s m)
+       putMVar (mv st) m
+       return ()
+
+mvsrw :: State -> IO ()
+mvsrw st
+  = do m <- takeMVar (mv st)
+       let s2 = (s m)
+           m2 = StateM (i m) (randomString s2) (b m)
+       putMVar (mv st) m2
+       return ()
+
+mvbr :: State -> IO ()
+mvbr st
+  = do m <- takeMVar (mv st)
+       let b2 = (b m)
+       putMVar (mv st) m
+       return ()
+
+mvbrw :: State -> IO ()
+mvbrw st
+  = do m <- takeMVar (mv st)
+       let b2 = (b m)
+           m2 = StateM (i m) (s m) (not b2)
+       putMVar (mv st) m2
+       return ()
+
+forkIter :: Int -> IO () -> IO ()
+forkIter n p
+  = iter n (do forkIO p
+               return ())
+
+iter :: Int -> IO () -> IO ()
+iter 0 _ = return ()
+iter n f
+  = do f
+       iter (n-1) f
+
+randomString :: String -> String
+randomString str
+  = case str of 
+      "1" -> "2"
+      "2" -> "3"
+      "3" -> "1"
diff --git a/smp/systolic/Main.hs b/smp/systolic/Main.hs
new file mode 100644 (file)
index 0000000..03a9504
--- /dev/null
@@ -0,0 +1,45 @@
+-------------------------------------------------------------------------------\r
+--- $Id: Bench1.hs#4 2005/06/14 01:10:17 REDMOND\\satnams $\r
+-------------------------------------------------------------------------------\r
+\r
+module Main\r
+where\r
+import System.Time\r
+import System.Random\r
+import Control.Concurrent\r
+\r
+systolicFilter :: [Double] -> [Double] -> [Double]\r
+systolicFilter weights inputStream\r
+  = [sum [a*x | (a,x) <- zip weights xs]\r
+              | xs <- staggerBy (length weights) inputStream]\r
+\r
+staggerBy n list | length list <= n = []\r
+staggerBy n list\r
+  = take n list : staggerBy n (tail list)\r
+\r
+applyFilter rgen resultMV\r
+  = do let weights = take 10 (randomRs (0.0, 10.0) rgen)\r
+       let inputStream = take 2000 (randomRs (0.0, 100.0) rgen)\r
+       let result = last (systolicFilter weights inputStream)\r
+       putMVar resultMV result\r
\r
+rgens 0 _ = []\r
+rgens n rgen\r
+  = nextGen : rgens (n-1) nextGen\r
+    where\r
+    (_, nextGen) = split rgen\r
+\r
+instances = 1000\r
+\r
+main  \r
+  = do putStrLn "SMP Systolic Filter Benchmarks"\r
+       dones <- sequence (replicate instances newEmptyMVar)\r
+       rgen1 <- getStdGen\r
+       let gens = rgens instances rgen1\r
+       t1 <- getClockTime\r
+       sequence [forkIO (applyFilter (gens!!i) (dones!!i)) |\r
+                 i <- [0..instances-1]]\r
+       rs <- sequence [takeMVar (dones!!i) | i <- [0..instances-1]]\r
+       sequence [putStrLn (show (rs!!i)) | i <- [0..instances-1]]\r
+       t2 <- getClockTime\r
+       putStrLn ("Time: " ++ (timeDiffToString (diffClockTimes t2 t1)))
\ No newline at end of file
diff --git a/smp/threads001/Main.hs b/smp/threads001/Main.hs
new file mode 100644 (file)
index 0000000..821f0ac
--- /dev/null
@@ -0,0 +1,26 @@
+module Main where
+
+-- Test thread creation.
+-- (from: Einar Wolfgang Karlsen <ewk@Informatik.Uni-Bremen.DE>)
+
+-- This test is essentially single-threaded, there is no parallelism
+-- available.  It just tests how quickly we can create a new thread
+-- and context switch to it, many times.
+
+import Control.Concurrent
+import System.Environment
+
+main :: IO ()
+main = do
+   [n] <- getArgs
+
+   mvar <- newEmptyMVar
+
+   let 
+       spawner :: (IO () -> IO ThreadId) -> Int -> IO ()
+       spawner c 0 = putMVar mvar ()
+       spawner c n = do { c (spawner c (n-1)); return ()}
+
+   spawner forkIO (read n :: Int)
+   takeMVar mvar
+   putStr "done"
diff --git a/smp/threads001/Makefile b/smp/threads001/Makefile
new file mode 100644 (file)
index 0000000..117ffad
--- /dev/null
@@ -0,0 +1,8 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 100000
+NORM_OPTS = 1000000
+SLOW_OPTS = 10000000
+
+include $(TOP)/mk/target.mk
diff --git a/smp/threads001/threads001.stdout b/smp/threads001/threads001.stdout
new file mode 100644 (file)
index 0000000..348ebd9
--- /dev/null
@@ -0,0 +1 @@
+done
\ No newline at end of file
diff --git a/smp/threads002/Main.hs b/smp/threads002/Main.hs
new file mode 100644 (file)
index 0000000..cf45b8c
--- /dev/null
@@ -0,0 +1,36 @@
+module Main where
+
+-- a variant of thread001, this one creates N threads as fast as
+-- possible.  The threads all signal a single QSemN, which the
+-- main thread waits for.
+
+-- If we are unlucky, the program can take a *long* time.  This is
+-- because if a thread yields while holding the semaphore, it will
+-- prevent all other threads from finishing, and we get into a
+-- situation where there are a lot of blocked threads, and the number
+-- of threads being created outnumbers those being retired.  The run
+-- queue has two threads at any one time: the main thread, busy
+-- creating new threads, and a single thread that has been unblocked.
+-- Each pass over the run queue creates a bunch of new threads which
+-- will all immediately block, and unblocks a single thread.  Having
+-- two processors helps, because it means we can unblock threads more
+-- quickly.
+
+import Control.Concurrent
+import System.Environment
+
+main :: IO ()
+main = do
+   [s] <- getArgs
+   let n =  read s :: Int
+
+   sem <- newQSemN 0
+
+   let 
+       spawner :: (IO () -> IO ThreadId) -> Int -> IO ()
+       spawner c 0 = return ()
+       spawner c n = do { c (signalQSemN sem 1); spawner c (n-1); }
+
+   spawner forkIO n
+
+   waitQSemN sem n
diff --git a/smp/threads002/Makefile b/smp/threads002/Makefile
new file mode 100644 (file)
index 0000000..117ffad
--- /dev/null
@@ -0,0 +1,8 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 100000
+NORM_OPTS = 1000000
+SLOW_OPTS = 10000000
+
+include $(TOP)/mk/target.mk
diff --git a/smp/threads003/Main.hs b/smp/threads003/Main.hs
new file mode 100644 (file)
index 0000000..be9c41b
--- /dev/null
@@ -0,0 +1,37 @@
+-- $Id: message-ghc-2.code,v 1.3 2005/09/17 04:36:26 bfulgham Exp $
+-- The Great Computer Language Shootout
+-- http://shootout.alioth.debian.org/
+-- Contributed by Einar Karttunen
+-- Modified by Simon Marlow
+
+-- This is the shootout "cheap concurrency" benchmark, modified
+-- slightly.  Modification noted below (***) to add more concurrency
+-- and make a speedup on multiple processors available.
+
+-- Creates 500 threads arranged in a sequence where each takes a value
+-- from the left, adds 1, and passes it to the right (via MVars).
+-- N more threads pump zeros in at the left.  A sub-thread
+-- takes N values from the right and sums them.
+-- 
+
+import Control.Concurrent
+import Control.Monad
+import System
+
+thread :: MVar Int -> MVar Int -> IO ()
+thread inp out = do x <- takeMVar inp; putMVar out $! x+1; thread inp out
+
+spawn cur n = do next <- newEmptyMVar
+                 forkIO $ thread cur next
+                 return next
+
+main = do n <- getArgs >>= readIO.head
+          s <- newEmptyMVar
+          e <- foldM spawn s [1..500]
+          f <- newEmptyMVar
+          forkIO $ replicateM n (takeMVar e) >>= putMVar f . sum
+          replicateM n (forkIO $ putMVar s 0)
+-- ***    replicateM n (putMVar s 0)
+          takeMVar f
+
+-- vim: ts=4 ft=haskell
diff --git a/smp/threads003/Makefile b/smp/threads003/Makefile
new file mode 100644 (file)
index 0000000..cc7c378
--- /dev/null
@@ -0,0 +1,8 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 5000
+NORM_OPTS = 10000
+SLOW_OPTS = 20000
+
+include $(TOP)/mk/target.mk
diff --git a/smp/threads004/Main.hs b/smp/threads004/Main.hs
new file mode 100644 (file)
index 0000000..c359bcd
--- /dev/null
@@ -0,0 +1,32 @@
+-- $Id: message-ghc-2.code,v 1.3 2005/09/17 04:36:26 bfulgham Exp $
+-- The Great Computer Language Shootout
+-- http://shootout.alioth.debian.org/
+-- Contributed by Einar Karttunen
+-- Modified by Simon Marlow
+
+-- A Modification of threads003, using explicit assigning of threads to CPUs
+-- (assumes 2 CPUs).  This version can go faster with -N2 than -N1.
+-- 
+-- NB. don't forget to run it with +RTS -qm, to disable automatic migration.
+
+import Control.Concurrent
+import Control.Monad
+import System
+import GHC.Conc (forkOnIO)
+
+thread :: MVar Int -> MVar Int -> IO ()
+thread inp out = do x <- takeMVar inp; putMVar out $! x+1; thread inp out
+
+spawn cur n = do next <- newEmptyMVar
+                 forkOnIO (if (n <= 1000) then 0 else 1) $ thread cur next
+                 return next
+
+main = do n <- getArgs >>= readIO.head
+          s <- newEmptyMVar
+          e <- foldM spawn s [1..2000]
+          f <- newEmptyMVar
+          forkOnIO 1 $ replicateM n (takeMVar e) >>= putMVar f . sum
+          replicateM n (putMVar s 0)
+          takeMVar f
+
+-- vim: ts=4 ft=haskell
diff --git a/smp/threads004/Makefile b/smp/threads004/Makefile
new file mode 100644 (file)
index 0000000..cc7c378
--- /dev/null
@@ -0,0 +1,8 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+FAST_OPTS = 5000
+NORM_OPTS = 10000
+SLOW_OPTS = 20000
+
+include $(TOP)/mk/target.mk