summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDonaldStewart <>2007-11-26 23:21:57 (GMT)
committerLuite Stegeman <luite@luite.com>2007-11-26 23:21:57 (GMT)
commit554bb86b6efb492403dff8a1ede1395e0150d6db (patch)
treeedc2e82b642d6555cac586470b788132182be10e
version 0.10.1
-rw-r--r--Control/Concurrent/Chan/Strict.hs129
-rw-r--r--Control/Concurrent/MVar/Strict.hs151
-rw-r--r--LICENSE30
-rw-r--r--Setup.lhs3
-rw-r--r--strict-concurrency.cabal22
-rw-r--r--tests/chan-test.hs28
-rw-r--r--tests/mvar-test.hs54
-rw-r--r--tests/run-tests44
-rw-r--r--tests/thread-ring.hs32
9 files changed, 493 insertions, 0 deletions
diff --git a/Control/Concurrent/Chan/Strict.hs b/Control/Concurrent/Chan/Strict.hs
new file mode 100644
index 0000000..52e4102
--- /dev/null
+++ b/Control/Concurrent/Chan/Strict.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.Chan.Strict
+-- Copyright : (c) The University of Glasgow 2001, Don Stewart 2007
+-- License : BSD-style
+--
+-- Maintainer : dons@galois.com
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Unbounded, element-strict channels. Elements will be evaluated to
+-- WHNF on entering the channel. For some concurrency applications, this
+-- is more desirable than passing an unevaluted thunk through the channel
+-- (for instance, it guarantees the node willl be evaluated to WHNF in a
+-- worker thead).
+--
+-- Element-strict channes may potentially use more memory than lazy
+-- channels
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.Chan.Strict (
+ -- * The 'Chan' type
+ Chan, -- abstract
+
+ -- * Operations
+ newChan, -- :: IO (Chan a)
+ writeChan, -- :: Chan a -> a -> IO ()
+ readChan, -- :: Chan a -> IO a
+ dupChan, -- :: Chan a -> IO (Chan a)
+ unGetChan, -- :: Chan a -> a -> IO ()
+ isEmptyChan, -- :: Chan a -> IO Bool
+
+ -- * Stream interface
+ getChanContents, -- :: Chan a -> IO [a]
+ writeList2Chan, -- :: Chan a -> [a] -> IO ()
+ ) where
+
+import Prelude
+
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import Control.Concurrent.MVar.Strict
+
+-- 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
+-- are used to handle consumers trying to read from an empty channel.
+
+-- |'Chan' is an abstract type representing an unbounded FIFO channel.
+data Chan a
+ = Chan (MVar (Stream a))
+ (MVar (Stream a))
+
+type Stream a = MVar (ChItem a)
+
+data ChItem a = ChItem !a (Stream a)
+
+-- @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 = do
+ hole <- newEmptyMVar
+ readm <- newMVar hole
+ write <- newMVar hole
+ return (Chan readm write)
+
+-- To put an element on a channel, a new hole at the write end is created.
+-- What was previously the empty @MVar@ at the back of the channel is then
+-- filled in with a new stream element holding the entered value and the
+-- new hole.
+
+-- |Write a value to a 'Chan'.
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan _read write) val = do
+ new_hole <- newEmptyMVar
+ modifyMVar_ write $ \old_hole -> do
+ putMVar old_hole $! ChItem val new_hole
+ return new_hole
+
+-- |Read the next value from the 'Chan'.
+readChan :: Chan a -> IO a
+readChan (Chan readm _write) = do
+ modifyMVar readm $ \read_end -> do
+ (ChItem val new_read_end) <- readMVar read_end
+ -- Use readMVar here, not takeMVar,
+ -- else dupChan doesn't work
+ return (new_read_end, val)
+
+-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
+-- 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 (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 (Chan readm _write) val = do
+ new_read_end <- newEmptyMVar
+ modifyMVar_ readm $ \read_end -> do
+ putMVar new_read_end (ChItem val read_end)
+ return new_read_end
+
+-- |Returns 'True' if the supplied 'Chan' is empty.
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan readm write) = do
+ withMVar readm $ \r -> do
+ w <- readMVar write
+ let eq = r == w
+ eq `seq` return eq
+
+-- Operators for interfacing with functional streams.
+
+-- |Return a lazy list representing the contents of the supplied
+-- 'Chan', much like 'System.IO.hGetContents'.
+getChanContents :: 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 = mapM_ . writeChan
diff --git a/Control/Concurrent/MVar/Strict.hs b/Control/Concurrent/MVar/Strict.hs
new file mode 100644
index 0000000..84e1e3e
--- /dev/null
+++ b/Control/Concurrent/MVar/Strict.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.MVar.Strict
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Synchronising, strict variables
+--
+-- Values placed in an MVar are evaluated to weak-head normal form
+-- before being placed in the MVar, preventing a common source of
+-- space-leaks involving synchronising variables.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.MVar.Strict
+ (
+ -- * @MVar@s
+ MVar -- abstract
+ , newEmptyMVar -- :: IO (MVar a)
+ , newMVar -- :: a -> IO (MVar a)
+ , takeMVar -- :: MVar a -> IO a
+ , putMVar -- :: MVar a -> a -> IO ()
+ , readMVar -- :: MVar a -> IO a
+ , swapMVar -- :: MVar a -> a -> IO a
+ , tryTakeMVar -- :: MVar a -> IO (Maybe a)
+ , tryPutMVar -- :: MVar a -> a -> IO Bool
+ , isEmptyMVar -- :: MVar a -> IO Bool
+ , withMVar -- :: MVar a -> (a -> IO b) -> IO b
+ , modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
+ , modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+ ) where
+
+import GHC.Conc ( MVar, newEmptyMVar, takeMVar,
+ tryTakeMVar, isEmptyMVar, addMVarFinalizer
+ )
+import GHC.Exts
+import GHC.IOBase
+
+import Prelude
+import Control.Exception as Exception
+
+-- |Put a value into an 'MVar'. If the 'MVar' is currently full,
+-- 'putMVar' will wait until it becomes empty.
+--
+-- There are two further important properties of 'putMVar':
+--
+-- * 'putMVar' is single-wakeup. That is, if there are multiple
+-- threads blocked in 'putMVar', and the 'MVar' becomes empty,
+-- only one thread will be woken up. The runtime guarantees that
+-- the woken thread completes its 'putMVar' operation.
+--
+-- * When multiple threads are blocked on an 'MVar', they are
+-- woken up in FIFO order. This is useful for providing
+-- fairness properties of abstractions built using 'MVar's.
+--
+putMVar :: MVar a -> a -> IO ()
+#ifndef __HADDOCK__
+putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
+ case putMVar# mvar# x s# of
+ s2# -> (# s2#, () #)
+#endif
+
+-- | A non-blocking version of 'putMVar'. The 'tryPutMVar' function
+-- attempts to put the value @a@ into the 'MVar', returning 'True' if
+-- it was successful, or 'False' otherwise.
+--
+tryPutMVar :: MVar a -> a -> IO Bool
+#ifndef __HADDOCK__
+tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
+ case tryPutMVar# mvar# x s# of
+ (# s, 0# #) -> (# s, False #)
+ (# s, _ #) -> (# s, True #)
+#endif
+
+-- |Create an 'MVar' which contains the supplied value.
+newMVar :: a -> IO (MVar a)
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+{-|
+ 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 m = block $ do
+ a <- takeMVar m
+ putMVar m a
+ return a
+
+{-|
+ Take a value from an 'MVar', put a new value into the 'MVar' and
+ return the value taken. Note that there is a race condition whereby
+ another process can put something in the 'MVar' after the take
+ happens but before the put does.
+-}
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new = block $ do
+ old <- takeMVar mvar
+ putMVar mvar new
+ return old
+
+{-|
+ 'withMVar' is a safe wrapper for operating on the contents of an
+ 'MVar'. This operation is exception-safe: it will replace the
+ original contents of the 'MVar' if an exception is raised (see
+ "Control.Exception").
+-}
+{-# 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 m io = block $ do
+ a <- takeMVar m
+ b <- Exception.catch (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a
+ return b
+
+{-|
+ A safe wrapper for modifying the contents of an 'MVar'. Like 'withMVar',
+ 'modifyMVar' will replace the original contents of the 'MVar' if an
+ exception is raised during the operation.
+-}
+{-# INLINE modifyMVar_ #-}
+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ m io = block $ do
+ a <- takeMVar m
+ a' <- Exception.catch (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a'
+
+{-|
+ A slight variation on 'modifyMVar_' that allows a value to be
+ returned (@b@) in addition to the modified value of the 'MVar'.
+-}
+{-# INLINE modifyMVar #-}
+modifyMVar :: 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/LICENSE b/LICENSE
new file mode 100644
index 0000000..97392a6
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) Lennart Kolmodin
+
+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.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..5bde0de
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/strict-concurrency.cabal b/strict-concurrency.cabal
new file mode 100644
index 0000000..289d2f0
--- /dev/null
+++ b/strict-concurrency.cabal
@@ -0,0 +1,22 @@
+Name: strict-concurrency
+Version: 0.1
+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,
+ 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
+Homepage: http://code.haskell.org/~dons/code/strict-concurrency
+build-depends: base
+ghc-options: -Wall -Werror -fglasgow-exts
+extensions: CPP
+exposed-modules: Control.Concurrent.MVar.Strict
+ Control.Concurrent.Chan.Strict
diff --git a/tests/chan-test.hs b/tests/chan-test.hs
new file mode 100644
index 0000000..8d81e8f
--- /dev/null
+++ b/tests/chan-test.hs
@@ -0,0 +1,28 @@
+import Control.Concurrent (forkIO)
+#if defined(STRICT)
+import Control.Concurrent.Chan.Strict
+#else
+import Control.Concurrent.Chan
+#endif
+import System.Environment
+
+-- Fork some computation processes, print their results
+main = do
+ n <- getArgs >>= readIO . head
+ f1 <- run fibonacci
+ f2 <- run fibonacci2
+ mapM_ print . take n $ zip f1 f2
+
+ -- fork a process, return any messages it produces as a list
+ where
+ run f = do
+ c <- newChan
+ l <- getChanContents c
+ 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)
+
+fibonacci2 = 1 : 1 : zipWith (+) fibonacci2 (tail fibonacci2)
diff --git a/tests/mvar-test.hs b/tests/mvar-test.hs
new file mode 100644
index 0000000..bb38335
--- /dev/null
+++ b/tests/mvar-test.hs
@@ -0,0 +1,54 @@
+
+{- The Computer Language Shootout
+ http://shootout.alioth.debian.org/
+ Written by Tom Pledger, 13 Nov 2006. modified by Don Stewart -}
+
+import Control.Concurrent (forkIO,yield)
+#if defined(STRICT)
+import Control.Concurrent.MVar.Strict
+#else
+import Control.Concurrent.MVar
+#endif
+import Control.Monad
+import System
+
+data Colour = Blue | Red | Yellow
+
+complement a b = case (a,b) of
+ (Red,Yellow) -> Blue
+ (Red,Blue) -> Yellow
+ (Red,Red) -> Red
+ (Yellow,Blue) -> Red
+ (Yellow,Red) -> Blue
+ (Yellow,Yellow) -> Yellow
+ (Blue,Red) -> Yellow
+ (Blue,Yellow) -> Red
+ (Blue,Blue) -> Blue
+
+colors = [Blue, Red, Yellow]
+
+data MP = MP !Int !(Maybe Colour) ![Int]
+
+main = do n <- getArgs >>= readIO . head
+ waker <- newEmptyMVar
+ mpv <- newMVar $ MP n Nothing []
+
+ let arrive c t = do
+ MP q w d <- takeMVar mpv
+ case w of
+ _ | q == 0 -> if length d /= 3 then putMVar mpv $ MP 0 w (t:d)
+ else print $ t + sum d
+
+ Nothing -> do putMVar mpv $ MP q (Just c) d
+ c' <- takeMVar waker
+ arrive c' $! t+1
+
+ Just k -> do let c' = complement k c
+ -- this should cause a space leak:
+ putMVar waker c'
+ putMVar mpv $ MP (q-1) Nothing d
+ arrive c' $! t+1
+
+ mapM_ (forkIO . flip arrive 0) colors
+ arrive Blue 0
+ replicateM_ 3 yield
diff --git a/tests/run-tests b/tests/run-tests
new file mode 100644
index 0000000..7f5ab26
--- /dev/null
+++ b/tests/run-tests
@@ -0,0 +1,44 @@
+#!/bin/sh
+
+M=5000000
+N=2000
+O=50000000
+
+ghc -cpp -O -no-recomp -threaded --make mvar-test.hs -o lazy-mvar
+ghc -DSTRICT -cpp -O -no-recomp -threaded --make mvar-test.hs -o strict-mvar
+
+ghc -cpp -O -no-recomp -threaded --make chan-test.hs -o lazy-chan
+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 MVars ************"
+
+echo "** Should have a space leak:"
+/usr/bin/time ./lazy-mvar $M +RTS -tstderr -RTS > /dev/null
+
+echo "** Should run in constant space:"
+/usr/bin/time ./strict-mvar $M +RTS -tstderr -RTS > /dev/null
+
+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 **"
+/usr/bin/time ./lazy-thread-ring $O +RTS -tstderr -RTS > /dev/null
+
+echo "** Should be no slower, use constant space **"
+/usr/bin/time ./strict-thread-ring $O +RTS -tstderr -RTS > /dev/null
diff --git a/tests/thread-ring.hs b/tests/thread-ring.hs
new file mode 100644
index 0000000..91f80a3
--- /dev/null
+++ b/tests/thread-ring.hs
@@ -0,0 +1,32 @@
+-- The Computer Language Benchmarks Game
+-- http://shootout.alioth.debian.org/
+-- Contributed by Jed Brown with improvements by Spencer Janssen and Don Stewart
+
+import Control.Monad
+import Control.Concurrent (forkIO)
+#if defined(STRICT)
+import Control.Concurrent.MVar.Strict
+#else
+import Control.Concurrent.MVar
+#endif
+import System.Environment
+
+ring = 503
+
+new l i = do
+ r <- newEmptyMVar
+ forkIO (thread i l r)
+ return r
+
+thread :: Int -> MVar Int -> MVar Int -> IO ()
+thread i l r = go
+ where go = do
+ m <- takeMVar l
+ when (m == 1) (print i)
+ putMVar r (m - 1) -- strict enough
+ when (m > 0) go
+
+main = do
+ a <- newMVar . read . head =<< getArgs
+ z <- foldM new a [2..ring]
+ thread 1 z a