diff --git a/Control/Concurrent/Chan/Strict.hs b/Control/Concurrent/Chan/Strict.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 +Maintainer: Don Stewart +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 --- /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 --- /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 --- /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 --- /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