strict-concurrency-0.2.4.1/0000755000175000001440000000000011430634715014402 5ustar donsusersstrict-concurrency-0.2.4.1/strict-concurrency.cabal0000644000175000001440000000200411430634715021222 0ustar donsusersName: strict-concurrency Version: 0.2.4.1 Synopsis: Strict concurrency abstractions Category: Control Description: 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 Maintainer: Don Stewart Copyright: (c) 2007-10 Don Stewart Homepage: http://code.haskell.org/~dons/code/strict-concurrency build-depends: base >= 4 && < 5, deepseq >= 1 ghc-options: -Wall -fglasgow-exts extensions: CPP, BangPatterns build-type: Simple exposed-modules: Control.Concurrent.MVar.Strict Control.Concurrent.Chan.Strict strict-concurrency-0.2.4.1/LICENSE0000644000175000001440000000266311430634715015416 0ustar donsusersCopyright (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. strict-concurrency-0.2.4.1/Setup.lhs0000644000175000001440000000011411430634715016206 0ustar donsusers#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain strict-concurrency-0.2.4.1/tests/0000755000175000001440000000000011430634715015544 5ustar donsusersstrict-concurrency-0.2.4.1/tests/run-tests0000644000175000001440000000267711430634715017447 0ustar donsusers#!/bin/sh N=35 M=5000000 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 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:" /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 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 strict-concurrency-0.2.4.1/tests/thread-ring.hs0000644000175000001440000000133711430634715020310 0ustar donsusers-- 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 strict-concurrency-0.2.4.1/tests/mvar-test.hs0000644000175000001440000000322611430634715020025 0ustar donsusers {- 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 strict-concurrency-0.2.4.1/tests/chan-test.hs0000644000175000001440000000130611430634715017766 0ustar donsusersimport 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 -- -- very computationally expensive jobs: 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) strict-concurrency-0.2.4.1/Control/0000755000175000001440000000000011430634715016022 5ustar donsusersstrict-concurrency-0.2.4.1/Control/Concurrent/0000755000175000001440000000000011430634715020144 5ustar donsusersstrict-concurrency-0.2.4.1/Control/Concurrent/Chan/0000755000175000001440000000000011430634715021015 5ustar donsusersstrict-concurrency-0.2.4.1/Control/Concurrent/Chan/Strict.hs0000644000175000001440000001113411430634715022621 0ustar donsusers{-# 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 import Control.DeepSeq -- 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) 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 :: NFData a => 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 :: NFData a => 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 :: NFData a => 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 :: 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 :: NFData a => 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 ::NFData a => 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 ::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 ::NFData a => Chan a -> [a] -> IO () writeList2Chan = mapM_ . writeChan strict-concurrency-0.2.4.1/Control/Concurrent/MVar/0000755000175000001440000000000011430634715021011 5ustar donsusersstrict-concurrency-0.2.4.1/Control/Concurrent/MVar/Strict.hs0000644000175000001440000001230511430634715022616 0ustar donsusers{-# 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 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 Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar, isEmptyMVar, addMVarFinalizer ) import GHC.Exts import GHC.IOBase import Prelude import Control.OldException as Exception -- import Control.Parallel.Strategies import Control.DeepSeq -- |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 :: NFData a => MVar a -> a -> IO () #ifndef __HADDOCK__ putMVar (MVar mvar#) !x = rnf x `seq` 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 :: NFData a => 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 :: NFData a => 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 :: NFData a => 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 :: NFData a => 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 :: NFData a => 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_ :: NFData a => 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 :: 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