summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDonaldStewart <>2008-02-15 19:11:50 (GMT)
committerLuite Stegeman <luite@luite.com>2008-02-15 19:11:50 (GMT)
commit8c22abc254932a3aaa35c8e4a56569c1bfa4dee8 (patch)
treecb62af690abafdaa3212cf9456715f6fc8805572
parent554bb86b6efb492403dff8a1ede1395e0150d6db (diff)
version 0.20.2
-rw-r--r--Control/Concurrent/Chan/Strict.hs22
-rw-r--r--Control/Concurrent/MVar/Strict.hs22
-rw-r--r--strict-concurrency.cabal21
-rw-r--r--tests/chan-test.hs13
-rw-r--r--tests/run-tests24
5 files changed, 58 insertions, 44 deletions
diff --git a/Control/Concurrent/Chan/Strict.hs b/Control/Concurrent/Chan/Strict.hs
index 52e4102..5aa184e 100644
--- a/Control/Concurrent/Chan/Strict.hs
+++ b/Control/Concurrent/Chan/Strict.hs
@@ -41,6 +41,7 @@ import Prelude
import System.IO.Unsafe ( unsafeInterleaveIO )
import Control.Concurrent.MVar.Strict
+import Control.Parallel.Strategies
-- A channel is represented by two @MVar@s keeping track of the two ends
-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
@@ -55,11 +56,16 @@ type Stream a = MVar (ChItem a)
data ChItem a = ChItem !a (Stream a)
+instance NFData (MVar a)
+
+instance NFData a => NFData (ChItem a) where
+ rnf (ChItem a s) = rnf a `seq` rnf s
+
-- @newChan@ sets up the read and write end of a channel by initialising
-- these two @MVar@s with an empty @MVar@.
-- |Build and returns a new instance of 'Chan'.
-newChan :: IO (Chan a)
+newChan :: NFData a => IO (Chan a)
newChan = do
hole <- newEmptyMVar
readm <- newMVar hole
@@ -72,7 +78,7 @@ newChan = do
-- new hole.
-- |Write a value to a 'Chan'.
-writeChan :: Chan a -> a -> IO ()
+writeChan :: NFData a => Chan a -> a -> IO ()
writeChan (Chan _read write) val = do
new_hole <- newEmptyMVar
modifyMVar_ write $ \old_hole -> do
@@ -80,7 +86,7 @@ writeChan (Chan _read write) val = do
return new_hole
-- |Read the next value from the 'Chan'.
-readChan :: Chan a -> IO a
+readChan :: NFData a => Chan a -> IO a
readChan (Chan readm _write) = do
modifyMVar readm $ \read_end -> do
(ChItem val new_read_end) <- readMVar read_end
@@ -92,14 +98,14 @@ readChan (Chan readm _write) = do
-- either channel from then on will be available from both. Hence this creates
-- a kind of broadcast channel, where data written by anyone is seen by
-- everyone else.
-dupChan :: Chan a -> IO (Chan a)
+dupChan :: NFData a => Chan a -> IO (Chan a)
dupChan (Chan _read write) = do
hole <- readMVar write
new_read <- newMVar hole
return (Chan new_read write)
-- |Put a data item back onto a channel, where it will be the next item read.
-unGetChan :: Chan a -> a -> IO ()
+unGetChan :: NFData a => Chan a -> a -> IO ()
unGetChan (Chan readm _write) val = do
new_read_end <- newEmptyMVar
modifyMVar_ readm $ \read_end -> do
@@ -107,7 +113,7 @@ unGetChan (Chan readm _write) val = do
return new_read_end
-- |Returns 'True' if the supplied 'Chan' is empty.
-isEmptyChan :: Chan a -> IO Bool
+isEmptyChan ::NFData a => Chan a -> IO Bool
isEmptyChan (Chan readm write) = do
withMVar readm $ \r -> do
w <- readMVar write
@@ -118,12 +124,12 @@ isEmptyChan (Chan readm write) = do
-- |Return a lazy list representing the contents of the supplied
-- 'Chan', much like 'System.IO.hGetContents'.
-getChanContents :: Chan a -> IO [a]
+getChanContents ::NFData a => Chan a -> IO [a]
getChanContents ch = unsafeInterleaveIO $ do
x <- readChan ch
xs <- getChanContents ch
return (x:xs)
-- |Write an entire list of items to a 'Chan'.
-writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ::NFData a => Chan a -> [a] -> IO ()
writeList2Chan = mapM_ . writeChan
diff --git a/Control/Concurrent/MVar/Strict.hs b/Control/Concurrent/MVar/Strict.hs
index 84e1e3e..3802a19 100644
--- a/Control/Concurrent/MVar/Strict.hs
+++ b/Control/Concurrent/MVar/Strict.hs
@@ -11,7 +11,7 @@
--
-- Synchronising, strict variables
--
--- Values placed in an MVar are evaluated to weak-head normal form
+-- Values placed in an MVar are evaluated to head normal form
-- before being placed in the MVar, preventing a common source of
-- space-leaks involving synchronising variables.
--
@@ -44,6 +44,7 @@ import GHC.IOBase
import Prelude
import Control.Exception as Exception
+import Control.Parallel.Strategies
-- |Put a value into an 'MVar'. If the 'MVar' is currently full,
-- 'putMVar' will wait until it becomes empty.
@@ -59,9 +60,9 @@ import Control.Exception as Exception
-- woken up in FIFO order. This is useful for providing
-- fairness properties of abstractions built using 'MVar's.
--
-putMVar :: MVar a -> a -> IO ()
+putMVar :: NFData a => MVar a -> a -> IO ()
#ifndef __HADDOCK__
-putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
+putMVar (MVar mvar#) !x = rnf x `seq` IO $ \ s# -> -- strict!
case putMVar# mvar# x s# of
s2# -> (# s2#, () #)
#endif
@@ -70,7 +71,7 @@ putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- it was successful, or 'False' otherwise.
--
-tryPutMVar :: MVar a -> a -> IO Bool
+tryPutMVar :: NFData a => MVar a -> a -> IO Bool
#ifndef __HADDOCK__
tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
case tryPutMVar# mvar# x s# of
@@ -79,7 +80,7 @@ tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
#endif
-- |Create an 'MVar' which contains the supplied value.
-newMVar :: a -> IO (MVar a)
+newMVar :: NFData a => a -> IO (MVar a)
newMVar value =
newEmptyMVar >>= \ mvar ->
putMVar mvar value >>
@@ -89,7 +90,7 @@ newMVar value =
This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
from the 'MVar', puts it back, and also returns it.
-}
-readMVar :: MVar a -> IO a
+readMVar :: NFData a => MVar a -> IO a
readMVar m = block $ do
a <- takeMVar m
putMVar m a
@@ -101,7 +102,7 @@ readMVar m = block $ do
another process can put something in the 'MVar' after the take
happens but before the put does.
-}
-swapMVar :: MVar a -> a -> IO a
+swapMVar :: NFData a => MVar a -> a -> IO a
swapMVar mvar new = block $ do
old <- takeMVar mvar
putMVar mvar new
@@ -116,7 +117,7 @@ swapMVar mvar new = block $ do
{-# INLINE withMVar #-}
-- inlining has been reported to have dramatic effects; see
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
-withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar :: NFData a => MVar a -> (a -> IO b) -> IO b
withMVar m io = block $ do
a <- takeMVar m
b <- Exception.catch (unblock (io a))
@@ -130,7 +131,7 @@ withMVar m io = block $ do
exception is raised during the operation.
-}
{-# INLINE modifyMVar_ #-}
-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io = block $ do
a <- takeMVar m
a' <- Exception.catch (unblock (io a))
@@ -142,10 +143,11 @@ modifyMVar_ m io = block $ do
returned (@b@) in addition to the modified value of the 'MVar'.
-}
{-# INLINE modifyMVar #-}
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
+modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io = block $ do
a <- takeMVar m
(a',b) <- Exception.catch (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a'
return b
+
diff --git a/strict-concurrency.cabal b/strict-concurrency.cabal
index 289d2f0..955309c 100644
--- a/strict-concurrency.cabal
+++ b/strict-concurrency.cabal
@@ -1,22 +1,23 @@
Name: strict-concurrency
-Version: 0.1
+Version: 0.2
Synopsis: Strict concurrency abstractions
Category: Control
Description:
- This package provides strict versions of some standard Haskell
- concurrency abstractions (MVars,Chans), which provide control
- over where evaluation takes place not offered by the default
- lazy types. This may be useful for deciding when and where
- evaluation occurs, leading to improved time or space use,
+ This package provides head normal form strict versions of some
+ standard Haskell concurrency abstractions (MVars,Chans), which
+ provide control over where evaluation takes place not offered by
+ the default lazy types. This may be useful for deciding when and
+ where evaluation occurs, leading to improved time or space use,
depending on the circumstances.
License: BSD3
License-File: LICENSE
Author: Don Stewart <dons@galois.com>
Maintainer: Don Stewart <dons@galois.com>
-Copyright: (c) 2007 Don Stewart
+Copyright: (c) 2007-8 Don Stewart
Homepage: http://code.haskell.org/~dons/code/strict-concurrency
-build-depends: base
-ghc-options: -Wall -Werror -fglasgow-exts
-extensions: CPP
+build-depends: base, parallel
+ghc-options: -Wall -fglasgow-exts
+extensions: CPP, BangPatterns
+build-type: Simple
exposed-modules: Control.Concurrent.MVar.Strict
Control.Concurrent.Chan.Strict
diff --git a/tests/chan-test.hs b/tests/chan-test.hs
index 8d81e8f..0cd6351 100644
--- a/tests/chan-test.hs
+++ b/tests/chan-test.hs
@@ -21,8 +21,13 @@ main = do
forkIO (writeList2Chan c f)
return l
--- lazily returns values to the main thread to compute, should run twice
--- as fast if we compute in the worker thread
-fibonacci = 0 : 1 : zipWith (+) fibonacci (tail fibonacci)
+--
+-- very computationally expensive jobs:
-fibonacci2 = 1 : 1 : zipWith (+) fibonacci2 (tail fibonacci2)
+fibonacci = map fib [0..]
+
+fibonacci2 = map fib [1..] -- to defeat CSE
+
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n-1) + fib (n-2)
diff --git a/tests/run-tests b/tests/run-tests
index 7f5ab26..87ba9f3 100644
--- a/tests/run-tests
+++ b/tests/run-tests
@@ -1,7 +1,7 @@
#!/bin/sh
+N=35
M=5000000
-N=2000
O=50000000
ghc -cpp -O -no-recomp -threaded --make mvar-test.hs -o lazy-mvar
@@ -13,6 +13,17 @@ ghc -DSTRICT -cpp -O -no-recomp -threaded --make chan-test.hs -o strict-chan
ghc -cpp -O -no-recomp -threaded --make thread-ring.hs -o lazy-thread-ring
ghc -DSTRICT -cpp -O -no-recomp -threaded --make thread-ring.hs -o strict-thread-ring
+echo "******* Testing Chans ************"
+
+echo "** Should be slow:"
+/usr/bin/time ./lazy-chan $N +RTS -tstderr -RTS > /dev/null
+
+echo "** Should be fast:"
+/usr/bin/time ./strict-chan $N +RTS -tstderr -RTS > /dev/null
+
+echo "** Should be twice as fast (on 2 cores)"
+/usr/bin/time ./strict-chan $N +RTS -N2 -tstderr -RTS > /dev/null
+
echo "******* Testing MVars ************"
echo "** Should have a space leak:"
@@ -24,17 +35,6 @@ echo "** Should run in constant space:"
echo "** Should pass (2 cores)"
/usr/bin/time ./strict-mvar $M +RTS -N2 -tstderr -RTS > /dev/null
-echo "******* Testing Chans ************"
-
-echo "** Should be slow:"
-/usr/bin/time ./lazy-chan $N +RTS -tstderr -RTS > /dev/null
-
-echo "** Should be fast:"
-/usr/bin/time ./strict-chan $N +RTS -tstderr -RTS > /dev/null
-
-echo "** Should be fast (2 cores)"
-/usr/bin/time ./strict-chan $N +RTS -N2 -tstderr -RTS > /dev/null
-
echo "******* Testing thread-ring benchmark ************"
echo "** Should be ok **"