strict-concurrency 0.2.4.1 → 0.2.4.2
raw patch · 8 files changed
+38/−192 lines, 8 filesdep ~basedep ~deepseqnew-uploader
Dependency ranges changed: base, deepseq
Files
- Control/Concurrent/Chan/Strict.hs +0/−2
- Control/Concurrent/MVar/Strict.hs +18/−16
- LICENSE +1/−1
- strict-concurrency.cabal +19/−10
- tests/chan-test.hs +0/−33
- tests/mvar-test.hs +0/−54
- tests/run-tests +0/−44
- tests/thread-ring.hs +0/−32
Control/Concurrent/Chan/Strict.hs view
@@ -56,8 +56,6 @@ 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
Control/Concurrent/MVar/Strict.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns,+ MagicHash, UnboxedTuples, ScopedTypeVariables+#-} ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.MVar.Strict@@ -36,14 +38,14 @@ , addMVarFinalizer -- :: MVar a -> IO () -> IO () ) where -import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, +import Control.Concurrent.MVar ( newEmptyMVar, takeMVar, tryTakeMVar, isEmptyMVar, addMVarFinalizer ) import GHC.Exts-import GHC.IOBase+import GHC.Base+import GHC.MVar (MVar(MVar)) -import Prelude-import Control.OldException as Exception+import Control.Exception as Exception -- import Control.Parallel.Strategies import Control.DeepSeq @@ -92,7 +94,7 @@ from the 'MVar', puts it back, and also returns it. -} readMVar :: NFData a => MVar a -> IO a-readMVar m = block $ do+readMVar m = mask $ \_ -> do a <- takeMVar m putMVar m a return a@@ -104,7 +106,7 @@ happens but before the put does. -} swapMVar :: NFData a => MVar a -> a -> IO a-swapMVar mvar new = block $ do+swapMVar mvar new = mask $ \_ -> do old <- takeMVar mvar putMVar mvar new return old@@ -119,10 +121,10 @@ -- 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+withMVar m io = mask $ \unmask -> do a <- takeMVar m- b <- Exception.catch (unblock (io a))- (\e -> do putMVar m a; throw e)+ b <- Exception.catch (unmask (io a))+ (\(e :: SomeException) -> do putMVar m a; throw e) putMVar m a return b @@ -133,10 +135,10 @@ -} {-# INLINE modifyMVar_ #-} modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO ()-modifyMVar_ m io = block $ do+modifyMVar_ m io = mask $ \unmask -> do a <- takeMVar m- a' <- Exception.catch (unblock (io a))- (\e -> do putMVar m a; throw e)+ a' <- Exception.catch (unmask (io a))+ (\(e :: SomeException) -> do putMVar m a; throw e) putMVar m a' {-|@@ -145,10 +147,10 @@ -} {-# INLINE modifyMVar #-} modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b-modifyMVar m io = block $ do+modifyMVar m io = mask $ \unmask -> do a <- takeMVar m- (a',b) <- Exception.catch (unblock (io a))- (\e -> do putMVar m a; throw e)+ (a',b) <- Exception.catch (unmask (io a))+ (\(e :: SomeException) -> do putMVar m a; throw e) putMVar m a' return b
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) Lennart Kolmodin+Copyright (c) Yitzchak Gale All rights reserved.
strict-concurrency.cabal view
@@ -1,5 +1,5 @@ Name: strict-concurrency-Version: 0.2.4.1+Version: 0.2.4.2 Synopsis: Strict concurrency abstractions Category: Control Description:@@ -12,12 +12,21 @@ License: BSD3 License-File: LICENSE Author: Don Stewart <dons@galois.com>-Maintainer: Don Stewart <dons@galois.com>-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+Maintainer: Yitz Gale <gale@sefer.org>+Copyright: (c) 2007-10 Don Stewart, 2017 Yitzchak Gale+Homepage: https://github.com/ygale/strict-concurrency+Cabal-version: >=1.10+Build-type: Simple++Source-repository HEAD+ type: git+ location: https://github.com/ygale/strict-concurrency.git++Library+ default-language: Haskell2010+ hs-source-dirs: .+ build-depends: base >= 4 && < 5+ , deepseq >= 1+ ghc-options: -Wall+ exposed-modules: Control.Concurrent.MVar.Strict+ Control.Concurrent.Chan.Strict
− tests/chan-test.hs
@@ -1,33 +0,0 @@-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------- 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)
− tests/mvar-test.hs
@@ -1,54 +0,0 @@--{- 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
− tests/run-tests
@@ -1,44 +0,0 @@-#!/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
− tests/thread-ring.hs
@@ -1,32 +0,0 @@--- 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