summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYitzGale <>2017-08-29 11:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-08-29 11:52:00 (GMT)
commit33cb46029cbd652f92c36fd418e265d3604e26f3 (patch)
tree7232d6eed0f3001a4c73acb4b2894764e68be769
parent6fab7540720c589e9886b955b3f8d8c4dbcf432e (diff)
version 0.2.4.20.2.4.2
-rw-r--r--Control/Concurrent/Chan/Strict.hs2
-rw-r--r--Control/Concurrent/MVar/Strict.hs34
-rw-r--r--LICENSE2
-rw-r--r--strict-concurrency.cabal29
-rw-r--r--tests/chan-test.hs33
-rw-r--r--tests/mvar-test.hs54
-rw-r--r--tests/run-tests44
-rw-r--r--tests/thread-ring.hs32
8 files changed, 38 insertions, 192 deletions
diff --git a/Control/Concurrent/Chan/Strict.hs b/Control/Concurrent/Chan/Strict.hs
index fbaf0ad..01d2c07 100644
--- a/Control/Concurrent/Chan/Strict.hs
+++ b/Control/Concurrent/Chan/Strict.hs
@@ -56,8 +56,6 @@ 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
diff --git a/Control/Concurrent/MVar/Strict.hs b/Control/Concurrent/MVar/Strict.hs
index 39a8d5c..49e7ab3 100644
--- a/Control/Concurrent/MVar/Strict.hs
+++ b/Control/Concurrent/MVar/Strict.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP, BangPatterns,
+ MagicHash, UnboxedTuples, ScopedTypeVariables
+#-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.MVar.Strict
@@ -36,14 +38,14 @@ module Control.Concurrent.MVar.Strict
, 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 @@ newMVar value =
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 @@ readMVar m = block $ do
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 @@ swapMVar mvar new = block $ do
-- 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 @@ withMVar m io = block $ do
-}
{-# 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 @@ modifyMVar_ m io = block $ do
-}
{-# 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
diff --git a/LICENSE b/LICENSE
index 97392a6..c72c5d2 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) Lennart Kolmodin
+Copyright (c) Yitzchak Gale
All rights reserved.
diff --git a/strict-concurrency.cabal b/strict-concurrency.cabal
index 2f7570c..c349abe 100644
--- a/strict-concurrency.cabal
+++ b/strict-concurrency.cabal
@@ -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 @@ Description:
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
diff --git a/tests/chan-test.hs b/tests/chan-test.hs
deleted file mode 100644
index 0cd6351..0000000
--- a/tests/chan-test.hs
+++ /dev/null
@@ -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)
diff --git a/tests/mvar-test.hs b/tests/mvar-test.hs
deleted file mode 100644
index bb38335..0000000
--- a/tests/mvar-test.hs
+++ /dev/null
@@ -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
diff --git a/tests/run-tests b/tests/run-tests
deleted file mode 100644
index 87ba9f3..0000000
--- a/tests/run-tests
+++ /dev/null
@@ -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
diff --git a/tests/thread-ring.hs b/tests/thread-ring.hs
deleted file mode 100644
index 91f80a3..0000000
--- a/tests/thread-ring.hs
+++ /dev/null
@@ -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