├── atomic-primops-foreign ├── LICENSE ├── testing │ ├── CommonTesting.hs │ ├── CounterCommon.hs │ ├── CounterForeign.hs │ └── Main.hs ├── atomic-primops-foreign.cabal └── Data │ └── Atomics │ └── Counter │ └── Foreign.hs ├── atomic-primops ├── cabal.project ├── Setup.hs ├── testing │ ├── hello.hs │ ├── Counter.hs │ ├── Issue28.hs │ ├── TemplateHaskellSplices.hs │ ├── ghci-test.hs │ ├── MicroBench.hs │ ├── Makefile │ ├── Raw781_test.hs │ ├── test-atomic-primops.cabal │ ├── CounterCommon.hs │ ├── CommonTesting.hs │ ├── OtherCounterTests.hs │ └── Fetch.hs ├── cbits │ ├── atomics.cmm │ ├── primops.cmm │ └── RtsDup.c ├── LICENSE ├── CHANGELOG.md ├── atomic-primops.cabal ├── benchmarking │ ├── IORef.hs │ └── Reference.hs ├── Makefile └── Data │ └── Atomics │ ├── Internal.hs │ └── Counter.hs ├── lockfree-queue ├── README.md ├── Setup.hs ├── stress_test.sh ├── CHANGELOG.md ├── Benchmark.hs ├── Data │ └── Concurrent │ │ └── Queue │ │ ├── MichaelScott │ │ └── DequeInstance.hs │ │ └── MichaelScott.hs ├── tests │ └── Test.hs ├── RegressionTest.hs ├── LICENSE └── lockfree-queue.cabal ├── mega-deque ├── README.md ├── Setup.hs ├── tests │ └── Test.hs ├── Data │ └── Concurrent │ │ └── MegaDeque.hs ├── mega-deque.cabal └── LICENSE ├── abstract-deque ├── README.md ├── Setup.hs ├── Makefile ├── Data │ └── Concurrent │ │ └── Deque │ │ ├── Reference │ │ └── DequeInstance.hs │ │ ├── Debugger.hs │ │ ├── Reference.hs │ │ └── Class.hs ├── LICENSE ├── abstract-deque.cabal └── DEVLOG.txt ├── chaselev-deque ├── Setup.hs ├── README.md ├── CHANGELOG.md ├── Data │ └── Concurrent │ │ └── Deque │ │ ├── ChaseLev │ │ └── DequeInstance.hs │ │ ├── ChaseLevReactor.hs │ │ ├── ChaseLev2.hs │ │ └── ReactorDeque.hs ├── issue5.sh ├── LICENSE ├── tests │ └── RegressionTests │ │ └── Issue5.hs └── chaselev-deque.cabal ├── atomic-primops-vector ├── Setup.hs ├── tests │ └── Main.hs ├── atomic-primops-vector.cabal ├── Data │ └── Atomics │ │ └── Vector.hs └── LICENSE ├── Obsolete_Deprecated └── IORefCAS │ ├── Setup.hs │ ├── Data │ ├── CAS.hs │ └── CAS │ │ └── Internal │ │ ├── Class.hs │ │ ├── Fake.hs │ │ ├── Native.hs │ │ └── Foreign.hs │ ├── DEVLOG.txt │ ├── LICENSE │ ├── IORefCAS.cabal │ └── README.md ├── .travis_install.sh ├── .gitignore ├── .jenkins_script1.sh ├── .jenkins_script2.sh ├── stack.yaml ├── cabal.project ├── azure-pipelines.yml ├── install_all.sh ├── .travis.yml ├── abstract-deque-tests ├── LICENSE ├── abstract-deque-tests.cabal └── tests │ └── Test.hs ├── DequeTester └── old_unfinished_Test.hs ├── .jenkins_common.sh ├── README.md └── vector-atomics └── Data └── Vector └── Unboxed └── Atomic.hs /atomic-primops-foreign/LICENSE: -------------------------------------------------------------------------------- 1 | ../atomic-primops/LICENSE -------------------------------------------------------------------------------- /atomic-primops/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ./testing 3 | -------------------------------------------------------------------------------- /lockfree-queue/README.md: -------------------------------------------------------------------------------- 1 | See haddock in Data.Concurrent.LinkedQueue 2 | -------------------------------------------------------------------------------- /mega-deque/README.md: -------------------------------------------------------------------------------- 1 | See haddock in Data.Concurrent.Deque.Class 2 | 3 | -------------------------------------------------------------------------------- /mega-deque/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /abstract-deque/README.md: -------------------------------------------------------------------------------- 1 | See haddock in Data.Concurrent.Deque.Class 2 | 3 | -------------------------------------------------------------------------------- /abstract-deque/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /atomic-primops/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chaselev-deque/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lockfree-queue/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chaselev-deque/README.md: -------------------------------------------------------------------------------- 1 | See haddock in Data.Concurrent.Deque.ChaseLev 2 | 3 | -------------------------------------------------------------------------------- /atomic-primops-vector/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /atomic-primops-foreign/testing/CommonTesting.hs: -------------------------------------------------------------------------------- 1 | ../../atomic-primops/testing/CommonTesting.hs -------------------------------------------------------------------------------- /atomic-primops-foreign/testing/CounterCommon.hs: -------------------------------------------------------------------------------- 1 | ../../atomic-primops/testing/CounterCommon.hs -------------------------------------------------------------------------------- /.travis_install.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | cat stack.yaml | grep -v resolver > stack-${STACK_RESOLVER}.yaml 4 | echo "resolver: ${STACK_RESOLVER}" >> stack-${STACK_RESOLVER}.yaml 5 | rm -f stack.yaml 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-* 3 | cabal-dev/ 4 | *~ 5 | *# 6 | *.exe 7 | *.hi 8 | *.o 9 | *onflict* 10 | .stack-work/ 11 | cabal.project.local 12 | cabal.project.local~ 13 | .HTF/ 14 | .ghc.environment.* 15 | test-results.xml 16 | -------------------------------------------------------------------------------- /lockfree-queue/stress_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Example of how to pump up the number of elements for more intensive testing. 4 | 5 | ghc -O2 --make Test.hs -o Test.exe -rtsopts -threaded 6 | 7 | time NUMELEMS=500000 ./Test.exe +RTS -N 8 | 9 | -------------------------------------------------------------------------------- /.jenkins_script1.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Test only the core atomic-primops packages. 4 | 5 | NOTEST_PKGS="" 6 | PKGS="atomic-primops/ atomic-primops/testing/ atomic-primops-foreign/" 7 | TESTPKGS="atomic-primops/testing/ atomic-primops-foreign/" 8 | 9 | source .jenkins_common.sh 10 | -------------------------------------------------------------------------------- /atomic-primops/testing/hello.hs: -------------------------------------------------------------------------------- 1 | 2 | -- A simple test that verifies the compile & link went ok for atomic-primops. 3 | 4 | import Data.IORef 5 | import Data.Atomics 6 | 7 | main = do 8 | putStrLn "hello" 9 | x <- newIORef (3::Int) 10 | t <- readForCAS x 11 | casIORef x t 4 12 | print =<< readIORef x 13 | 14 | -------------------------------------------------------------------------------- /.jenkins_script2.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Test the data structures built on top of the core atomic-primops package. 4 | 5 | NOTEST_PKGS="atomic-primops/ atomic-primops-foreign/" 6 | PKGS="abstract-deque/ abstract-deque-tests/ lockfree-queue/ chaselev-deque/ mega-deque/" 7 | TESTPKGS="$PKGS" 8 | 9 | source .jenkins_common.sh 10 | -------------------------------------------------------------------------------- /lockfree-queue/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.2.4 2 | * Allow building with GHC 9.4. 3 | 4 | ## 0.2.3 5 | * bump for upstream change 6 | 7 | ## 0.2.0.2 8 | * minor: fix for upstream change 9 | 10 | ## 0.2.0.1 11 | * use ticketed CAS internally; add support for -prof mode 12 | 13 | ## 0.2 14 | * switched to MutVar 15 | 16 | ## 0.1 17 | * initial version 18 | -------------------------------------------------------------------------------- /atomic-primops/testing/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Counter (tests) where 3 | import qualified Data.Atomics.Counter as C 4 | 5 | #include "CounterCommon.hs" 6 | 7 | name :: String 8 | name = "Unboxed" 9 | 10 | default_seq_tries, default_conc_tries :: Int 11 | default_seq_tries = 10 * numElems 12 | -- Things are MUCH slower with contention: 13 | default_conc_tries = numElems 14 | 15 | -------------------------------------------------------------------------------- /atomic-primops-foreign/testing/CounterForeign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, BangPatterns #-} 2 | module CounterForeign (tests) where 3 | import qualified Data.Atomics.Counter.Foreign as C 4 | 5 | #include "CounterCommon.hs" 6 | 7 | name = "Foreign" 8 | 9 | -- This version is much slower than some of the others: 10 | default_seq_tries = 10 * base 11 | default_conc_tries = base 12 | 13 | base = numElems `quot` 15 14 | 15 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - abstract-deque/ 4 | - abstract-deque-tests/ 5 | - atomic-primops/ 6 | - atomic-primops/testing/ 7 | - atomic-primops-foreign/ 8 | - atomic-primops-vector/ 9 | - chaselev-deque/ 10 | - lockfree-queue/ 11 | - mega-deque/ 12 | extra-deps: 13 | - git: https://github.com/wangbj/bits-atomic.git 14 | commit: 78c8cd2c0bbf77356b3becba64c7f99e6d4e208b 15 | 16 | resolver: lts-12.4 17 | -------------------------------------------------------------------------------- /lockfree-queue/Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, NamedFieldPuns #-} 2 | 3 | module Main where 4 | import Data.Concurrent.Deque.Tests (test_fifo_OneBottleneck, numElems) 5 | import Data.Concurrent.Queue.MichaelScott (newQ, LinkedQueue) 6 | 7 | {-# SPECIALIZE test_fifo_OneBottleneck :: Bool -> Int -> LinkedQueue Int -> IO () #-} 8 | 9 | -- Benchmark mode: 10 | main :: IO () 11 | main = newQ >>= test_fifo_OneBottleneck True numElems 12 | -------------------------------------------------------------------------------- /atomic-primops-vector/tests/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad 3 | import Data.Vector 4 | import Data.Vector.Mutable 5 | import Data.Atomics.Vector 6 | 7 | main :: IO () 8 | main = do 9 | v <- new 10 :: IO (IOVector Int) 10 | set v 0 11 | tik <- readVectorElem v 5 12 | casVectorElem v 5 tik 99 13 | v' <- unsafeFreeze v 14 | print v' 15 | unless (v' == fromList [0,0,0,0,0,99,0,0,0,0]) 16 | (error "Unexpected result!") 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /lockfree-queue/Data/Concurrent/Queue/MichaelScott/DequeInstance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} 2 | 3 | module Data.Concurrent.Queue.MichaelScott.DequeInstance () where 4 | 5 | import Data.Concurrent.Deque.Class 6 | import qualified Data.Concurrent.Queue.MichaelScott as M 7 | 8 | -- | This queue is not fully general, it covers only part of the 9 | -- configuration space: 10 | type instance Deque lt rt S S bnd safe elt = M.LinkedQueue elt 11 | -------------------------------------------------------------------------------- /atomic-primops/cbits/atomics.cmm: -------------------------------------------------------------------------------- 1 | #include "Cmm.h" 2 | 3 | // These approximate GHC's old barrier operations in terms of the new C11-style 4 | // ordered atomic fences. 5 | 6 | hs_atomic_primops_store_load_barrier() { 7 | prim %fence_seq_cst(); 8 | return (); 9 | } 10 | 11 | hs_atomic_primops_load_load_barrier() { 12 | prim %fence_acquire(); 13 | return (); 14 | } 15 | 16 | hs_atomic_primops_write_barrier() { 17 | prim %fence_release(); 18 | return (); 19 | } 20 | 21 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./abstract-deque 2 | ./abstract-deque-tests 3 | ./atomic-primops 4 | ./atomic-primops/testing 5 | ./atomic-primops-foreign 6 | ./atomic-primops-vector 7 | ./chaselev-deque 8 | ./lockfree-queue 9 | ./mega-deque 10 | 11 | -- Only listed here since bits-atomic is broken upstream 12 | source-repository-package 13 | type: git 14 | location: https://github.com/wangbj/bits-atomic 15 | tag: 78c8cd2c0bbf77356b3becba64c7f99e6d4e208b 16 | -------------------------------------------------------------------------------- /abstract-deque/Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | test: 4 | # cabal-dev install --enable-tests 5 | cabal install --enable-tests 6 | # ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N1 7 | ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N2 8 | ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N3 9 | ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N4 10 | ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N8 11 | ./dist/build/test-abstract-deque/test-abstract-deque -j1 +RTS -N16 12 | -------------------------------------------------------------------------------- /azure-pipelines.yml: -------------------------------------------------------------------------------- 1 | # Starter pipeline 2 | # Start with a minimal pipeline that you can customize to build and deploy your code. 3 | # Add steps that build, run tests, deploy, and more: 4 | # https://aka.ms/yaml 5 | 6 | trigger: 7 | - master 8 | 9 | pool: 10 | vmImage: 'Ubuntu-16.04' 11 | 12 | steps: 13 | - script: echo Hello, world! 14 | displayName: 'Run a one-line script' 15 | 16 | - script: | 17 | echo Add other tasks to build, test, and deploy your project. 18 | echo See https://aka.ms/yaml 19 | displayName: 'Run a multi-line script' 20 | -------------------------------------------------------------------------------- /install_all.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o errexit 4 | set -x 5 | 6 | if [ "$HADDOCK" == "" ]; 7 | then HADDOCK=`which haddock` 8 | fi 9 | 10 | if [ "$CABAL" == "" ]; 11 | then CABAL=`which cabal` 12 | fi 13 | 14 | if [ "$GHC" == "" ]; 15 | then GHC=`which ghc` 16 | fi 17 | 18 | ALLPKG="./atomic-primops ./atomic-primops/testing ./atomic-primops-foreign ./abstract-deque ./abstract-deque-tests ./lockfree-queue ./chaselev-deque ./mega-deque" 19 | 20 | # A manual form of cleaning. 21 | for dir in $ALLPKG; do 22 | rm -rf $dir/dist/ 23 | done 24 | 25 | $CABAL install -fforce-recomp --force-reinstalls --with-ghc=$GHC $ALLPKG $* 26 | -------------------------------------------------------------------------------- /atomic-primops-foreign/testing/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import GHC.Conc 5 | import Test.Framework (Test, defaultMain, testGroup) 6 | import qualified CounterForeign 7 | import Control.Monad (when) 8 | 9 | ---------------------------------------- 10 | 11 | main :: IO () 12 | main = do 13 | -- TEMP: Fixing this at four processors because it takes a REALLY long time at larger numbers: 14 | -- It does 248 test cases and takes 55s at -N16... 15 | -- numcap <- getNumProcessors 16 | let numcap = 4 17 | when (numCapabilities /= numcap) $ setNumCapabilities numcap 18 | defaultMain CounterForeign.tests 19 | -------------------------------------------------------------------------------- /chaselev-deque/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## next [????.??.??] 2 | * Allow building with `base-4.15`. 3 | 4 | ## 0.5.0.5 5 | * Remove an unused dependency on the `bits-atomic` library. 6 | 7 | ## 0.5.0.4 8 | * bugfix 9 | 10 | ## 0.5.0.3 11 | * minor bump to change abstract-deque dep. 12 | 13 | ## 0.5.0.2 14 | * bump to go along with MAJOR bugfix in atomic-primops 0.5.0.2 15 | 16 | ## 0.4 17 | * bump to go along with atomic-primops 0.4 18 | 19 | ## 0.3 20 | * bump to go along with atomic-primops 0.3 21 | 22 | ## 0.1.3 23 | * small release to fix version deps before atomic-primops api change 24 | 25 | ## 0.1.2 26 | 27 | ## 0.1.1 28 | * bump for fixing bugs! First release candidate. 29 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Data/CAS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | #-} 3 | 4 | -- | Atomic compare and swap for IORefs and STRefs. 5 | module Data.CAS 6 | ( 7 | -- Not currently provided by Fake.hs: 8 | -- casSTRef, 9 | casIORef, ptrEq, 10 | atomicModifyIORefCAS, atomicModifyIORefCAS_, 11 | 12 | -- * Generic interface: for interoperation with `Fake` and `Foreign` alternative libraries. 13 | CASRef) 14 | where 15 | 16 | #if __GLASGOW_HASKELL__ <= 702 /* Fix to casMutVar introduced 2011.12.09 */ 17 | #warning "casMutVar is not included or is bugged in your GHC, falling back to Fake version." 18 | import Data.CAS.Internal.Fake 19 | #else 20 | import Data.CAS.Internal.Native 21 | #endif 22 | -------------------------------------------------------------------------------- /atomic-primops/testing/Issue28.hs: -------------------------------------------------------------------------------- 1 | 2 | module Issue28 (main) where 3 | 4 | -- import Control.Monad 5 | import Data.IORef 6 | import Data.Atomics 7 | -- import Data.Atomics.Internal (ptrEq) 8 | 9 | main :: IO () 10 | main = do 11 | putStrLn "Issue28: Conducting the simplest possible read-then-CAS test." 12 | r <- newIORef "hi" 13 | t0 <- readForCAS r 14 | (True,t1) <- casIORef r t0 "bye" 15 | -- putStrLn$ "First CAS succeeded? "++show b1 16 | -- putStrLn$ "Tickets pointer equal? " ++ show (t0 == t1) 17 | -- (b2,t2) <- casIORef r t1 "bye2" 18 | -- putStrLn$ "Second CAS succeeded? " ++ show b2 19 | -- unless (b1 == True) $ error "Test failed" 20 | 21 | putStrLn$ "Issue28: test passed "++show t1 22 | -------------------------------------------------------------------------------- /atomic-primops/testing/TemplateHaskellSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, 2 | RankNTypes #-} 3 | 4 | -- | TH splices used in atommic-primops tests. 5 | -- Splices defined in own module for technical reasons. 6 | 7 | module TemplateHaskellSplices where 8 | 9 | import Language.Haskell.TH 10 | import Control.Monad (replicateM) 11 | 12 | tmap :: forall a. (Enum a, Eq a, Num a) 13 | => a -> Int -> Q Exp 14 | tmap i n = do 15 | f <- newName "f" 16 | as <- replicateM n (newName "a") 17 | lamE [varP f, tupP (map varP as)] $ 18 | tupE [ if i == i' 19 | then [| $(varE f) $a |] 20 | else a 21 | | (a,i') <- map varE as `zip` [1..] ] 22 | -------------------------------------------------------------------------------- /atomic-primops/testing/ghci-test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Test the invocation of the GHCi bytecode intepreter with atomic-primops. 4 | 5 | module Main where 6 | 7 | import Data.Atomics -- import needed to test whether ghci linking error occurs 8 | import TemplateHaskellSplices (tmap) 9 | import Test.Framework (defaultMain) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | 12 | main :: IO () 13 | main = defaultMain 14 | [ 15 | ---------------------------------------- 16 | testCase "Template_Haskell_invocation" $ do 17 | putStrLn "Attempting Template Haskell implementation of map operation" 18 | print $ $(tmap 3 4) (+ 1) (1,2,3,4) -- comment out for compilation to succeed 19 | ---------------------------------------- 20 | ] 21 | -------------------------------------------------------------------------------- /mega-deque/tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, NamedFieldPuns #-} 2 | {- Example build: 3 | ghc --make Test.hs -o Test.exe -rtsopts -fforce-recomp 4 | -} 5 | module Main where 6 | 7 | import Test.HUnit as HU 8 | import Data.Concurrent.Deque.Tests 9 | import Data.Concurrent.Deque.Class 10 | import Data.Concurrent.MegaDeque () -- Instances. 11 | 12 | main :: IO () 13 | main = stdTestHarness $ return all_tests 14 | where 15 | all_tests :: HU.Test 16 | all_tests = TestList $ 17 | [ TestLabel "WSDeque" $ tests_wsqueue (newQ :: IO (WSDeque a)) 18 | , TestLabel "TS_Queue" $ tests_fifo (newQ :: IO (ConcQueue a)) 19 | , TestLabel "NT_Queue" $ tests_fifo (newQ :: IO (Queue a)) 20 | , TestLabel "Full_TS_Deque" $ tests_all (newQ :: IO (ConcDeque a)) 21 | -- , TestLabel "Maxed" $ tests_all (newQ :: IO (Deque T T D D Grow Safe)) 22 | ] 23 | -------------------------------------------------------------------------------- /abstract-deque/Data/Concurrent/Deque/Reference/DequeInstance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeSynonymInstances #-} 2 | 3 | {- | 4 | 5 | By convention, every provider of the "Data.Concurrent.Deque.Class" 6 | interface optionally provides a module that provides the relevant 7 | instances of the 'Deque' type class, covering the [maximum] portion 8 | of the configuration space that the implementation is able to 9 | handle. 10 | 11 | This is kept in a separate package because importing instances is 12 | unconditional and the user may well want to assemble their own 13 | combination of 'Deque' instances to cover the configuration 14 | space. 15 | -} 16 | 17 | module Data.Concurrent.Deque.Reference.DequeInstance () where 18 | 19 | import Data.Concurrent.Deque.Class 20 | import qualified Data.Concurrent.Deque.Reference as R 21 | 22 | -- | The reference implementation is a fully general Deque. It can 23 | -- thus cover the full configuration space. 24 | type instance Deque lt rt l r bnd safe elt = R.SimpleDeque elt 25 | 26 | -------------------------------------------------------------------------------- /chaselev-deque/Data/Concurrent/Deque/ChaseLev/DequeInstance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Data.Concurrent.Deque.ChaseLev.DequeInstance () where 4 | 5 | import Data.Array.IO 6 | import Data.Concurrent.Deque.Class 7 | import qualified Data.Concurrent.Deque.ChaseLev as R 8 | -- import qualified Data.Concurrent.Deque.ReactorDeque as R 9 | 10 | -- | Populate a slice of the configuration-space for `Deque`: 11 | -- 12 | -- Work stealing queues are only threadsafe on one end (pop-only) and 13 | -- double (push/pop) functionality on the other: 14 | 15 | -- type instance Deque NT T D S Grow Safe elt = R.ChaseLevDeque elt -- Minimal slice 16 | 17 | type instance Deque NT t dbl S grow safe elt = R.ChaseLevDeque elt -- Maximal slice 18 | 19 | -- [2011.11.09] Presently having problems with this error when I try 20 | -- to use these Deques: 21 | -- 22 | -- Couldn't match type `Deque 23 | -- Nonthreadsafe Threadsafe DoubleEnd SingleEnd Grow Safe (Par ())' 24 | -- with `R.Deque IOArray (Par ())' 25 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/DEVLOG.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | [2011.12.23] Just did some 7.2 vs 7.4 tests 4 | =========================================== 5 | 6 | The test suite runs very slowly on a multicore system with load. I 7 | just ran on an older 16 core system and it took: 8 | 9 | 7.2.1 -N16 : 3.5 minutes 10 | 7.3.... -N16 : 1.25 minutes 11 | 12 | Versus on my macbook air laptop with four threads (including 13 | hyperthreading): 14 | 15 | 7.2.1 -N4 : 14.3 seconds 16 | 7.4.0RC1 -N4 : 2.8s 17 | 18 | (The older machine is also just worse in general, it takes 3.8s for 19 | the -N4 case. Hyperthreading may *help* in this case though. 20 | Although the laptop is still 4X faster (0.25s vs 1.0s) for the -N2 21 | case as well.) 22 | 23 | For another datapoint let's use a recent 3.1 ghz Westmere: 24 | 25 | 7.3.... -N2 : 0.18s 26 | 7.3.... -N4 : 0.6s 27 | 7.3.... -N8 : 10.4s (oversubscription) 28 | 29 | Oversubscription may be quite bad in the atomicModify (blackholing) 30 | case. But otherwise this machine does well. 31 | 32 | -------------------------------------------------------------------------------- /chaselev-deque/Data/Concurrent/Deque/ChaseLevReactor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | -- | Chase-Lev work stealing Deques 4 | -- 5 | -- This module only provides instances that adapt Edward Kmett's Deque 6 | -- library to the 'Control.Concurrent.Deque.Class' interface. 7 | module Data.Concurrent.Deque.ChaseLev () where 8 | 9 | import qualified Data.Concurrent.Deque.ReactorDeque as R 10 | import Data.Concurrent.Deque.Class 11 | -- import Data.Vector.Unboxed.Mutable 12 | import Data.Array.IO 13 | 14 | -- | For an explanation of the implementation, see \"Dynamic Circular Work-Stealing Deque\" 15 | -- by David Chase and Yossi Lev of Sun Microsystems. 16 | 17 | instance DequeClass (R.Deque IOArray) where 18 | newQ = R.empty 19 | pushL q v = R.push v q 20 | tryPopR q = do x <- R.steal q 21 | case x of 22 | R.Empty -> return Nothing 23 | R.Abort -> return Nothing 24 | R.Stolen e -> return (Just e) 25 | 26 | instance PopL (R.Deque IOArray) where 27 | tryPopL = R.pop 28 | 29 | t = do q <- (newQ :: IO (R.Deque IOArray Int)); pushL q 3; tryPopL q 30 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Data/CAS/Internal/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, MultiParamTypeClasses, BangPatterns, MagicHash #-} 2 | 3 | -- | A type class capturing mutable storage cells that support CAS 4 | -- operations in the IO monad. 5 | 6 | module Data.CAS.Internal.Class 7 | (CASable(..), unsafeName, ptrEq) 8 | where 9 | 10 | import GHC.IO (unsafePerformIO) 11 | import GHC.Exts (Int(I#)) 12 | import GHC.Prim (reallyUnsafePtrEquality#) 13 | import System.Mem.StableName 14 | 15 | -- | It would be nice to use an associated type family with this class 16 | -- (for casref), but that would preclude overlapping instances. 17 | class CASable casref a where 18 | newCASable :: a -> IO (casref a) 19 | readCASable :: casref a -> IO a 20 | writeCASable :: casref a -> a -> IO () 21 | cas :: casref a -> a -> a -> IO (Bool,a) 22 | 23 | 24 | {-# NOINLINE unsafeName #-} 25 | unsafeName :: a -> Int 26 | unsafeName x = unsafePerformIO $ do 27 | sn <- makeStableName x 28 | return (hashStableName sn) 29 | 30 | {-# NOINLINE ptrEq #-} 31 | ptrEq :: a -> a -> Bool 32 | ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1 33 | -------------------------------------------------------------------------------- /chaselev-deque/issue5.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | if [ "$GHC" == "" ]; then 6 | GHC=ghc-7.6.3 7 | fi 8 | 9 | # cd ChaseLev 10 | 11 | CBLARGS="--disable-executable-profiling --disable-library-profiling --disable-documentation --force-reinstalls --with-ghc=$GHC" 12 | 13 | cabal-1.17.0_HEAD install $CBLARGS ../AbstractDeque/ 14 | cabal-1.17.0_HEAD install $CBLARGS ../AtomicPrimops/ 15 | 16 | # This works in -O0, and fails in -O2. 17 | # $GHC -O0 -fforce-recomp --make RegressionTests/Issue5.hs -o Issue5.exe -main-is RegressionTests.Issue5.standalone_single_CAS 18 | 19 | 20 | # OPT="-O2 -threaded -rtsopts" 21 | OPT="-O1 -threaded" 22 | DBG="-keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings -fforce-recomp" 23 | 24 | #$GHC $OPT $DBG --make RegressionTests/Issue5.hs -o Issue5.exe -main-is RegressionTests.Issue5.standalone_pushPop 25 | 26 | $GHC $OPT $DBG -DDEBUGCL --make RegressionTests/Issue5B.hs -o Issue5B.exe -main-is RegressionTests.Issue5B.standalone_pushPop 27 | 28 | ./Issue5B.exe 29 | -------------------------------------------------------------------------------- /lockfree-queue/tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, NamedFieldPuns #-} 2 | {- Example build: 3 | ghc --make Test.hs -o Test.exe -rtsopts -fforce-recomp 4 | -} 5 | module Main where 6 | import Test.Framework (defaultMain) 7 | import Test.Framework.Providers.HUnit (hUnitTestToTests) 8 | import Data.Concurrent.Deque.Tests (tests_fifo, numElems, getNumAgents) 9 | import System.Environment (getArgs, withArgs) 10 | import Test.HUnit 11 | 12 | -- import Data.Concurrent.Queue.MichaelScott (newQ) 13 | import Data.Concurrent.Queue.MichaelScott (LinkedQueue) 14 | import Data.Concurrent.Deque.Class (newQ) 15 | import Data.Concurrent.Deque.Debugger 16 | 17 | main = do 18 | numAgents <- getNumAgents 19 | putStrLn$ "Running with numElems "++show numElems++" and numAgents "++ show numAgents 20 | putStrLn "Use NUMELEMS and +RTS to control the size of this benchmark." 21 | args <- getArgs 22 | -- Don't allow concurent tests (the tests are concurrent!): 23 | withArgs (args ++ ["-j1","--jxml=test-results.xml"]) $ 24 | defaultMain$ hUnitTestToTests$ 25 | TestList 26 | [ TestLabel "MichaelScott" $ tests_fifo (newQ :: IO (LinkedQueue a)) 27 | , TestLabel "MichaelScott(DbgWrapper)" $ 28 | tests_fifo (newQ :: IO (DebugDeque LinkedQueue a)) 29 | ] 30 | 31 | 32 | -------------------------------------------------------------------------------- /atomic-primops/testing/MicroBench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | import Data.Atomics 4 | import Test (test_all_hammer_one) 5 | import Criterion.Types (Benchmarkable, toBenchmarkable) 6 | import Criterion.Main 7 | import Control.DeepSeq 8 | import Control.Exception (evaluate) 9 | import Data.IORef 10 | import qualified Data.Atomics as A 11 | import qualified Data.Atomics.Counter as C 12 | 13 | #if !(MIN_VERSION_deepseq(1,4,2)) 14 | instance NFData (IORef a) where rnf _ = () 15 | #endif 16 | instance NFData C.AtomicCounter where rnf _ = () 17 | 18 | b0 :: Benchmarkable 19 | b0 = toBenchmarkable $ \iters -> test_all_hammer_one 4 (fromIntegral iters) 0 20 | 21 | b1 :: Benchmark 22 | b1 = env (newIORef (0::Int)) $ \ ref -> 23 | bench "CAS_incr" $ nfIO $ do 24 | t <- readForCAS ref 25 | _ <- casIORef ref t (peekTicket t + 1) 26 | return () 27 | 28 | b2 :: Benchmark 29 | b2 = env (newIORef (0::Int)) $ \ ref -> 30 | bench "seq_incr" $ nfIO $ do 31 | x <- readIORef ref 32 | y <- evaluate (x+1) 33 | _ <- writeIORef ref y 34 | return () 35 | 36 | b3 :: Benchmark 37 | b3 = env (C.newCounter (0::Int)) $ \ ref -> 38 | bench "atomic_counter" $ nfIO $ do 39 | C.incrCounter 1 ref 40 | 41 | main :: IO () 42 | main = defaultMain 43 | [ b1, b2, b3 44 | -- bench "test_all_hammer_one" b0 45 | ] 46 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # RRN: Copied from template here: https://github.com/hvr/multi-ghc-travis/blob/master/README.md#ghc-head-snapshots 2 | 3 | # NB: don't set `language: haskell` here 4 | 5 | sudo: false 6 | cache: 7 | directories: 8 | - $HOME/.stack/ 9 | - $HOME/.local/ 10 | 11 | matrix: 12 | include: 13 | - env: STACKVER=1.7.1 STACK_RESOLVER=lts-12.4 # GHC-8.4.3 14 | - env: STACKVER=1.7.1 STACK_RESOLVER=lts-11.17 # GHC-8.2.2 15 | - env: STACKVER=1.7.1 STACK_RESOLVER=lts-9.21 # GHC-8.0.2 16 | - env: STACKVER=1.7.1 STACK_RESOLVER=lts-6.35 # GHC-7.10.3 17 | 18 | # This is stack-specific. Oh well. 19 | before_install: 20 | - mkdir -p ~/.local/bin 21 | - export PATH=~/.local/bin:$PATH 22 | - export STACK_YAML=stack-${STACK_RESOLVER}.yaml 23 | - export STACK_URL=https://github.com/commercialhaskell/stack/releases/download/v${STACKVER}/stack-${STACKVER}-linux-x86_64.tar.gz 24 | 25 | install: 26 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:~/.local/bin:$PATH 27 | - ./.travis_install.sh 28 | - curl -sSL ${STACK_URL} | tar zxf - --strip-components=1 -C ~/.local/bin stack-${STACKVER}-linux-x86_64/stack 29 | - chmod a+x ~/.local/bin/stack 30 | - stack setup 31 | - stack build 32 | 33 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 34 | script: 35 | - stack test 36 | -------------------------------------------------------------------------------- /atomic-primops-vector/atomic-primops-vector.cabal: -------------------------------------------------------------------------------- 1 | -- Initial atomic-primops-vector.cabal generated by cabal init. For 2 | -- further documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: atomic-primops-vector 5 | version: 0.1.0.1 6 | synopsis: Atomic operations on Data.Vector types 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Peter Fogg 11 | maintainer: peter.p.fogg@gmail.com 12 | -- copyright: 13 | category: Concurrency 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.18 17 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 18 | 19 | library 20 | exposed-modules: Data.Atomics.Vector 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >= 4.8 && < 5 24 | , vector >= 0.10 25 | , atomic-primops >= 0.7 26 | , primitive >= 0.5 27 | -- hs-source-dirs: 28 | ghc-options: -O2 -Wall 29 | default-language: Haskell2010 30 | 31 | Test-Suite test-atomic-primops-vector 32 | type: exitcode-stdio-1.0 33 | hs-source-dirs: tests 34 | main-is: Main.hs 35 | build-depends: base >= 4.8 36 | , vector >= 0.10 37 | , atomic-primops-vector 38 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N4 39 | default-language: Haskell2010 40 | -------------------------------------------------------------------------------- /lockfree-queue/RegressionTest.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This test was formulated to exercise a bug that Andreas found. 3 | 4 | -- TODO: Move this to the normal test suite. 5 | 6 | import Control.Concurrent 7 | import Data.Concurrent.Queue.MichaelScott 8 | import Data.Array.IArray 9 | import System.Random.MWC hiding (Seed) 10 | import qualified Data.Vector as V 11 | 12 | -- import GHC.IO.Handle (hFlush, stdout) 13 | import System.IO (stdout, hFlush) 14 | import Debug.Trace (trace) 15 | 16 | main = do 17 | qarray <- fmap (listArray (0, 99)) (sequence (replicate 100 newQ)) 18 | -- Fork 100 threads: 19 | vars <- mapM (\i -> newEmptyMVar >>= \var -> forkIO (prog i qarray var) >> return var) [0..99] 20 | mapM_ takeMVar vars 21 | 22 | 23 | numIters :: Int 24 | -- numIters = 100000 25 | numIters = 10000 26 | -- numIters = 30000 27 | 28 | prog :: Int -> Array Int (LinkedQueue Int) -> MVar () -> IO () 29 | prog i qarray done = go numIters 30 | where 31 | go j | j > 0 && j `mod` 1000 == 0 = 32 | do putStr "." 33 | hFlush stdout 34 | go (j-1) 35 | go j = if j==0 36 | then putMVar done () 37 | else do gen <- initialize (V.singleton (fromIntegral i)) 38 | ix <- uniformR (0,99) gen 39 | pushL (qarray ! ix) i 40 | popUntilNothing (qarray ! i) 41 | go (j-1) 42 | popUntilNothing myq 43 | = do res <- tryPopR myq 44 | case res of 45 | Nothing -> return () 46 | Just _ -> popUntilNothing myq 47 | -------------------------------------------------------------------------------- /atomic-primops-vector/Data/Atomics/Vector.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Atomics.Vector 3 | ( casVectorElem, unsafeCasVectorElem 4 | , readVectorElem, unsafeReadVectorElem ) 5 | where 6 | 7 | import Data.Atomics 8 | import Data.Vector.Mutable 9 | 10 | {-# INLINE casVectorElem #-} 11 | -- | Perform a compare-and-swap on a single element of a mutable vector. 12 | casVectorElem :: IOVector a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) 13 | casVectorElem (MVector st len array) i tick elm = 14 | let idx = i + st 15 | in if i >= len 16 | then error $ "casVectorElem: out of bounds access to index "++show i++ 17 | " of IOVector of length "++show len 18 | else casArrayElem array idx tick elm 19 | 20 | {-# INLINE unsafeCasVectorElem #-} 21 | -- | Unsafe version of `casVectorElem` which is not bounds checked. 22 | unsafeCasVectorElem :: IOVector a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) 23 | unsafeCasVectorElem (MVector st _ array) i tick elm = 24 | let idx = i + st 25 | in casArrayElem array idx tick elm 26 | 27 | {-# INLINE readVectorElem #-} 28 | readVectorElem :: IOVector a -> Int -> IO (Ticket a) 29 | readVectorElem (MVector st len arr) ix = 30 | if ix >= len 31 | then error $ "readVectorElem: out of bounds access to index "++show ix++ 32 | " of IOVector of length "++show len 33 | else readArrayElem arr (st + ix) 34 | 35 | {-# INLINE unsafeReadVectorElem #-} 36 | unsafeReadVectorElem :: IOVector a -> Int -> IO (Ticket a) 37 | unsafeReadVectorElem (MVector st _ arr) ix = readArrayElem arr (st + ix) 38 | -------------------------------------------------------------------------------- /atomic-primops-vector/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Peter Fogg 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Peter Fogg nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /atomic-primops/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012-2013, Ryan R. Newton 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ryan R. Newton nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Adam C. Foltzer 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Adam C. Foltzer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /mega-deque/Data/Concurrent/MegaDeque.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies 2 | , FlexibleInstances 3 | , MultiParamTypeClasses 4 | #-} 5 | 6 | -- | Multiplex multiple queue implementations together using a type family. 7 | module Data.Concurrent.MegaDeque 8 | 9 | where 10 | 11 | 12 | -- Abstract interface: 13 | import Data.Concurrent.Deque.Class 14 | 15 | -- Michael and Scott Queues: 16 | import qualified Data.Concurrent.Queue.MichaelScott as MS 17 | import qualified Data.Concurrent.Deque.ChaseLev as CL 18 | 19 | -- Fallback implementation: 20 | import qualified Data.Concurrent.Deque.Reference as R 21 | 22 | ------------------------------------------------------------ 23 | -- Single-ended Queues: 24 | 25 | -- | This instance classifies the LinkedQueue as being single-ended and fully threadsafe. 26 | 27 | -- newtype instance Deque lt rt S S bnd safe elt = LQQ (LinkedQueue elt) 28 | type instance Deque lt rt S S bnd safe elt = MS.LinkedQueue elt 29 | 30 | -- Work stealing queues are only threadsafe on one end (pop-only) and 31 | -- double (push/pop) functionality on the other: 32 | type instance Deque NT rt D S bnd safe elt = CL.ChaseLevDeque elt 33 | 34 | ------------------------------------------------------------ 35 | -- All others: 36 | 37 | -- It is necessary to enumerate whichever of the 64 possibilities 38 | -- remain here. 39 | 40 | -- But for the free type-variable 'elt' it is not possible to 41 | -- specialize at some types and still have a fallback. This is 42 | -- because no overlap is permitted for type families in GHC <= 7.6. 43 | 44 | type instance Deque lt rt D D bnd safe elt = R.SimpleDeque elt 45 | type instance Deque lt rt S D bnd safe elt = R.SimpleDeque elt 46 | -- Catch what isn't handled by chaselev: 47 | type instance Deque T rt D S bnd safe elt = R.SimpleDeque elt 48 | 49 | -------------------------------------------------------------------------------- /mega-deque/mega-deque.cabal: -------------------------------------------------------------------------------- 1 | Name: mega-deque 2 | Version: 0.1 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan R. Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data 8 | Build-type: Simple 9 | Cabal-version: >=1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | Homepage: https://github.com/rrnewton/haskell-lockfree/wiki 12 | 13 | Synopsis: Collects together queue packages and selects the right one based on a type family. 14 | 15 | Description: 16 | 17 | This module aggregates other queue implementations into a single, parameterizable implementation which 18 | 19 | * single, 1.5, and double-ended queues 20 | * bounded / unbounded capacity 21 | * "safe" or potentially duplicating of elements (e.g. Idempotent Work-stealing) 22 | 23 | Library 24 | exposed-modules: Data.Concurrent.MegaDeque 25 | hs-source-dirs: . 26 | build-depends: base >= 4.8 && < 5 27 | , abstract-deque >= 0.3 28 | , lockfree-queue 29 | , chaselev-deque 30 | default-language: Haskell2010 31 | 32 | Test-Suite test-mega-deque 33 | type: exitcode-stdio-1.0 34 | hs-source-dirs: tests 35 | main-is: Test.hs 36 | build-depends: base >= 4.8 && < 5 37 | , containers 38 | , abstract-deque >= 0.3 39 | , abstract-deque-tests >= 0.3 40 | , lockfree-queue 41 | , chaselev-deque 42 | , HUnit 43 | , mega-deque 44 | ghc-options: -O2 -threaded -rtsopts 45 | default-language: Haskell2010 46 | 47 | Source-Repository head 48 | Type: git 49 | Location: git://github.com/rrnewton/haskell-lockfree.git 50 | -------------------------------------------------------------------------------- /mega-deque/LICENSE: -------------------------------------------------------------------------------- 1 | Unless otherwise noted in individual files, the below 2 | copyright/LICENSE applies to the source files in this repository. 3 | -------------------------------------------------------------------------------- 4 | 5 | Copyright (c)2011, Ryan R. Newton 6 | 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | * Redistributions in binary form must reproduce the above 16 | copyright notice, this list of conditions and the following 17 | disclaimer in the documentation and/or other materials provided 18 | with the distribution. 19 | 20 | * Neither the name of Ryan R. Newton nor the names of other 21 | contributors may be used to endorse or promote products derived 22 | from this software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 27 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 28 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 32 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 33 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /abstract-deque/LICENSE: -------------------------------------------------------------------------------- 1 | Unless otherwise noted in individual files, the below 2 | copyright/LICENSE applies to the source files in this repository. 3 | -------------------------------------------------------------------------------- 4 | 5 | Copyright (c)2011, Ryan R. Newton 6 | 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | * Redistributions in binary form must reproduce the above 16 | copyright notice, this list of conditions and the following 17 | disclaimer in the documentation and/or other materials provided 18 | with the distribution. 19 | 20 | * Neither the name of Ryan R. Newton nor the names of other 21 | contributors may be used to endorse or promote products derived 22 | from this software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 27 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 28 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 32 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 33 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /chaselev-deque/LICENSE: -------------------------------------------------------------------------------- 1 | Unless otherwise noted in individual files, the below 2 | copyright/LICENSE applies to the source files in this repository. 3 | -------------------------------------------------------------------------------- 4 | 5 | Copyright (c)2011, Ryan R. Newton 6 | 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | * Redistributions in binary form must reproduce the above 16 | copyright notice, this list of conditions and the following 17 | disclaimer in the documentation and/or other materials provided 18 | with the distribution. 19 | 20 | * Neither the name of Ryan R. Newton nor the names of other 21 | contributors may be used to endorse or promote products derived 22 | from this software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 27 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 28 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 32 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 33 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /lockfree-queue/LICENSE: -------------------------------------------------------------------------------- 1 | Unless otherwise noted in individual files, the below 2 | copyright/LICENSE applies to the source files in this repository. 3 | -------------------------------------------------------------------------------- 4 | 5 | Copyright (c)2011, Ryan R. Newton 6 | 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | * Redistributions in binary form must reproduce the above 16 | copyright notice, this list of conditions and the following 17 | disclaimer in the documentation and/or other materials provided 18 | with the distribution. 19 | 20 | * Neither the name of Ryan R. Newton nor the names of other 21 | contributors may be used to endorse or promote products derived 22 | from this software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 27 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 28 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 32 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 33 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /abstract-deque-tests/LICENSE: -------------------------------------------------------------------------------- 1 | Unless otherwise noted in individual files, the below 2 | copyright/LICENSE applies to the source files in this repository. 3 | -------------------------------------------------------------------------------- 4 | 5 | Copyright (c)2011, Ryan R. Newton 6 | 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions are met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | * Redistributions in binary form must reproduce the above 16 | copyright notice, this list of conditions and the following 17 | disclaimer in the documentation and/or other materials provided 18 | with the distribution. 19 | 20 | * Neither the name of Ryan R. Newton nor the names of other 21 | contributors may be used to endorse or promote products derived 22 | from this software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 27 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 28 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 32 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 33 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /atomic-primops/testing/Makefile: -------------------------------------------------------------------------------- 1 | 2 | GHC=ghc 3 | 4 | all: simple full 5 | 6 | simple: hello 7 | hello: 8 | $(GHC) -fforce-recomp hello.hs -o hello_regular.exe 9 | $(GHC) -fforce-recomp hello.hs -o hello_threaded.exe -threaded 10 | $(GHC) -fforce-recomp hello.hs -o hello_prof.exe -prof 11 | $(GHC) -fforce-recomp hello.hs -o hello_prof_threaded.exe -prof -threaded 12 | ./hello_regular.exe 13 | ./hello_threaded.exe 14 | ./hello_prof.exe 15 | ./hello_prof_threaded.exe 16 | 17 | NOPROF= --disable-library-profiling --disable-executable-profiling 18 | PROF= --enable-library-profiling --enable-executable-profiling 19 | 20 | CBL= rm -rf dist; echo "\n\n"; cabal install --enable-tests 21 | 22 | #================================================================================ 23 | # The --builddir approach is broken with cabal 1.16. It works fine in 24 | # the current cabal HEAD [2013.07.18]. 25 | # ================================================================================ 26 | 27 | # Try all combinations of profiling, optimization, and threading: 28 | full: 29 | $(CBL) $(NOPROF) -fopt -fthreaded # --builddir=dist_reg_opt_thrd 30 | $(CBL) $(PROF) -fopt -fthreaded # --builddir=dist_prof_opt_thrd 31 | 32 | $(CBL) $(NOPROF) -f-opt -fthreaded # --builddir=dist_reg__thrd 33 | $(CBL) $(PROF) -f-opt -fthreaded # --builddir=dist_prof__thrd 34 | 35 | $(CBL) $(NOPROF) -fopt -f-threaded # --builddir=dist_reg_opt_ 36 | $(CBL) $(PROF) -fopt -f-threaded # --builddir=dist_prof_opt_ 37 | 38 | $(CBL) $(NOPROF) -f-opt -f-threaded # --builddir=dist_reg__ 39 | $(CBL) $(PROF) -f-opt -f-threaded # --builddir=dist_prof__ 40 | 41 | # These shoud be redundant with the above, but we run them anyway: 42 | for f in `ls dist_*/build/hello-world-atomic-primops/hello-world-atomic-primops`; do ./$f; done 43 | 44 | tail dist_*/test/test-atomic-primops-*-test-atomic-primops.log 45 | 46 | clean: 47 | rm -rf ./dist/ ./dist_*/ 48 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Data/CAS/Internal/Fake.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, BangPatterns #-} 2 | -- Author: Ryan Newton 3 | 4 | -- | This is an attempt to imitate a CAS using normal Haskell/GHC operations. 5 | -- Useful for debugging. 6 | -- 7 | 8 | module Data.CAS.Internal.Fake 9 | ( CASRef, casIORef, ptrEq, 10 | atomicModifyIORefCAS, atomicModifyIORefCAS_ 11 | ) 12 | where 13 | 14 | import Data.IORef 15 | import Data.CAS.Internal.Class 16 | import Debug.Trace 17 | import System.Mem.StableName 18 | 19 | -------------------------------------------------------------------------------- 20 | 21 | -- | The type of references supporting CAS. 22 | newtype CASRef a = CR { unCR :: IORef a } 23 | 24 | instance CASable CASRef a where 25 | newCASable x = newIORef x >>= (return . CR) 26 | readCASable = readIORef . unCR 27 | writeCASable = writeIORef . unCR 28 | cas = casIORef . unCR 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | {-# NOINLINE casIORef #-} 33 | -- TEMP -- A non-CAS based version. Alas, this has UNDEFINED BEHAVIOR 34 | -- (see ptrEq). 35 | -- 36 | -- casIORef :: Eq a => IORef a -> a -> a -> IO (Bool,a) 37 | casIORef :: IORef a -> a -> a -> IO (Bool,a) 38 | -- casIORef r !old !new = 39 | casIORef r old new = do 40 | atomicModifyIORef r $ \val -> 41 | {- 42 | trace (" DBG: INSIDE ATOMIC MODIFY, ptr eqs found/expected: " ++ 43 | show [ptrEq val old, ptrEq val old, ptrEq val old] ++ 44 | " ptr eq self: " ++ 45 | show [ptrEq val val, ptrEq old old] ++ 46 | " names: " ++ show (unsafeName old, unsafeName old, unsafeName val, unsafeName val) 47 | ) $ 48 | -} 49 | if (ptrEq val old) 50 | then (new, (True, val)) 51 | else (val, (False,val)) 52 | 53 | atomicModifyIORefCAS = atomicModifyIORef 54 | atomicModifyIORefCAS_ = atomicModifyIORef_ 55 | 56 | atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ())) 57 | 58 | -------------------------------------------------------------------------------- /atomic-primops-foreign/atomic-primops-foreign.cabal: -------------------------------------------------------------------------------- 1 | Name: atomic-primops-foreign 2 | Version: 0.6.2.1 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data 8 | Build-type: Simple 9 | Cabal-version: >=1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | HomePage: https://github.com/rrnewton/haskell-lockfree/wiki 12 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 13 | 14 | -- 0.6 -- Factored out of parent module to separate dependencies. 15 | -- 0.6.2.1 -- ver constraints only 16 | 17 | synopsis: An atomic counter implemented using the FFI. 18 | 19 | description: 20 | This is an alternate implementation of the counter interface 21 | provided by the atomic-primops packag. 22 | 23 | library 24 | exposed-modules: Data.Atomics.Counter.Foreign 25 | hs-source-dirs: . 26 | ghc-options: -O2 -funbox-strict-fields 27 | 28 | -- This can go back further than the atomic-primops package in supporting old GHC's: 29 | -- For now let's say GHC 7.0 through 7.8 and 7.10 (RC) 30 | build-depends: base >= 4.8 && < 5 31 | , bits-atomic >= 0.1.3 32 | CC-Options: -Wall 33 | default-language: Haskell2010 34 | 35 | test-suite test-atomic-primops-foreign 36 | type: exitcode-stdio-1.0 37 | main-is: Main.hs 38 | other-modules: CounterForeign 39 | , CommonTesting 40 | hs-source-dirs: testing 41 | 42 | ghc-options: -threaded -rtsopts -with-rtsopts=-N4 43 | build-depends: base >= 4.8 && < 5 44 | -- For Testing: 45 | , time 46 | , HUnit 47 | , test-framework 48 | , test-framework-hunit 49 | , bits-atomic 50 | , atomic-primops-foreign 51 | default-language: Haskell2010 52 | 53 | Source-Repository head 54 | Type: git 55 | Location: git://github.com/rrnewton/haskell-lockfree.git 56 | Subdir: atomic-primops-foreign/ 57 | -------------------------------------------------------------------------------- /abstract-deque-tests/abstract-deque-tests.cabal: -------------------------------------------------------------------------------- 1 | Name: abstract-deque-tests 2 | Version: 0.3 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan R. Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data 8 | Build-type: Simple 9 | Cabal-version: >= 1.18 10 | Homepage: https://github.com/rrnewton/haskell-lockfree/wiki 11 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 12 | 13 | Synopsis: A test-suite for any queue or double-ended queue satisfying an interface 14 | 15 | Description: 16 | 17 | This package provides tests that can be used with any queue implementation 18 | that satisfies the `abstract-deque` interface. 19 | 20 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 21 | 22 | library 23 | exposed-modules: Data.Concurrent.Deque.Tests 24 | other-modules: 25 | hs-source-dirs: . 26 | build-depends: base >= 4.8 && < 5 27 | , abstract-deque >= 0.3 28 | , random >= 1.0 29 | , containers 30 | , array 31 | , time 32 | , HUnit 33 | , test-framework >= 0.6 34 | , test-framework-hunit >= 0.2.7 35 | ghc-options: -O2 36 | default-language: Haskell2010 37 | default-extensions: CPP 38 | 39 | Source-Repository head 40 | Type: git 41 | Location: git://github.com/rrnewton/haskell-lockfree.git 42 | 43 | test-suite test-abstract-deque 44 | type: exitcode-stdio-1.0 45 | main-is: Test.hs 46 | hs-source-dirs: tests 47 | build-depends: base >= 4.8 && < 5 48 | , abstract-deque >= 0.3 49 | , random >= 1.0 50 | , containers 51 | , array 52 | , HUnit 53 | , test-framework >= 0.6 54 | , test-framework-hunit >= 0.2.7 55 | , time 56 | , abstract-deque 57 | , abstract-deque-tests 58 | ghc-options: -O2 -threaded -rtsopts 59 | default-language: Haskell2010 60 | -------------------------------------------------------------------------------- /atomic-primops/testing/Raw781_test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 2 | -- Test the primops in GHC 7.8.1 directly. 3 | 4 | module Main where 5 | 6 | import GHC.Prim 7 | import GHC.IORef 8 | import GHC.STRef 9 | import GHC.ST 10 | import GHC.IO 11 | 12 | {-# NOINLINE str #-} 13 | str :: String 14 | str = "hello" 15 | 16 | t :: MutVar# d a -> a -> a -> State# d -> (# State# d, Int#, a #) 17 | t = casMutVar# 18 | 19 | (===) :: Int# -> Int# -> Bool 20 | (===) x y = case x ==# y of { 0# -> False; _ -> True } 21 | 22 | ---------------------------------------- 23 | 24 | -- | Performs a machine-level compare and swap operation on an 25 | -- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a 26 | -- swap is performed, along with the 'current' value from the 'STRef'. 27 | -- 28 | -- Note \"compare\" here means pointer equality in the sense of 29 | -- 'GHC.Prim.reallyUnsafePtrEquality#'. 30 | casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current' 31 | -> a -- ^ The 'old' value to compare 32 | -> a -- ^ The 'new' value to replace 'current' if @old == current@ 33 | -> ST s (Bool, a) 34 | casSTRef (STRef var#) old new = ST $ \s1# -> 35 | -- The primop treats the boolean as a sort of error code. 36 | -- Zero means the CAS worked, one that it didn't. 37 | -- We flip that here: 38 | case casMutVar# var# old new s1# of 39 | (# s2#, x#, res #) -> (# s2#, (x# === 0#, res) #) 40 | 41 | -- | Performs a machine-level compare and swap operation on an 42 | -- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a 43 | -- swap is performed, along with the 'current' value from the 'IORef'. 44 | -- 45 | -- Note \"compare\" here means pointer equality in the sense of 46 | -- 'GHC.Prim.reallyUnsafePtrEquality#'. 47 | casIORef :: IORef a -- ^ The 'IORef' containing a value 'current' 48 | -> a -- ^ The 'old' value to compare 49 | -> a -- ^ The 'new' value to replace 'current' if @old == current@ 50 | -> IO (Bool, a) 51 | casIORef (IORef var) old new = stToIO (casSTRef var old new) 52 | 53 | -------------------------------------------------------------------------------- 54 | 55 | main :: IO () 56 | main = do 57 | r <- newIORef str 58 | pr <- casIORef r str "new str" 59 | print pr 60 | -------------------------------------------------------------------------------- /chaselev-deque/tests/RegressionTests/Issue5.hs: -------------------------------------------------------------------------------- 1 | module RegressionTests.Issue5 (standalone_pushPop) where 2 | 3 | import Control.Concurrent 4 | import Data.IORef 5 | import Data.Concurrent.Deque.Class 6 | import qualified Data.Concurrent.Deque.ChaseLev as CL 7 | 8 | -------------------------------------------------------------------------------- 9 | 10 | standalone_pushPop :: IO () 11 | standalone_pushPop = 12 | triv =<< (newQ :: IO (DebugDeque CL.ChaseLevDeque a)) 13 | where 14 | -- This is what's failing with the debug wrapper, WHY? 15 | triv :: PopL d => d [Char] -> IO () 16 | triv q = do 17 | pushL q "hi" 18 | x <- tryPopL q 19 | case x of 20 | Just "hi" -> putStrLn "Got expected value. Test passed.\n" 21 | Just x' -> error$ "A single push/pop got the WRONG value back: "++show x' 22 | Nothing -> error "Even a single push/pop in isolation did not work!" 23 | 24 | 25 | -- | Warning, this enforces the excessively STRONG invariant that if any end of the 26 | -- deque is non-threadsafe then it may ever only be touched by one thread during its 27 | -- entire lifetime. 28 | -- 29 | -- This extreme form of monagamy is easier to verify, because we don't have enough 30 | -- information to know if two operations on different threads are racing with one 31 | -- another or are properly synchronized. 32 | -- 33 | -- The wrapper data structure has two IORefs to track the last thread that touched 34 | -- the left and right end of the deque, respectively. 35 | data DebugDeque d elt = DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId)) (d elt) 36 | 37 | 38 | instance DequeClass d => DequeClass (DebugDeque d) where 39 | pushL (DebugDeque (ref,_) q) elt = do 40 | pushL q elt 41 | 42 | tryPopR (DebugDeque (_,ref) q) = do 43 | tryPopR q 44 | 45 | newQ = do l <- newIORef Nothing 46 | r <- newIORef Nothing 47 | fmap (DebugDeque (l,r)) newQ 48 | 49 | -- FIXME: What are the threadsafe rules for nullQ? 50 | nullQ (DebugDeque _ q) = nullQ q 51 | 52 | leftThreadSafe (DebugDeque _ q) = leftThreadSafe q 53 | rightThreadSafe (DebugDeque _ q) = rightThreadSafe q 54 | 55 | 56 | instance PopL d => PopL (DebugDeque d) where 57 | tryPopL (DebugDeque (ref,_) q) = do 58 | tryPopL q 59 | 60 | -------------------------------------------------------------------------------- /DequeTester/old_unfinished_Test.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | import Data.IORef 4 | import Control.Monad 5 | import Text.Printf 6 | import GHC.Conc 7 | import Control.Concurrent.MVar 8 | 9 | import qualified Data.Concurrent.Deque.Class as C 10 | import Data.Concurrent.Queue.MichaelScott 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Testing 15 | -------------------------------------------------------------------------------- 16 | 17 | spinPop q = do 18 | x <- tryPopR q 19 | case x of 20 | Nothing -> spinPop q 21 | Just x -> return x 22 | 23 | testQ1 = 24 | do q <- newQ 25 | let n = 1000 26 | putStrLn$ "Done creating queue. Pushing elements:" 27 | forM_ [1..n] $ \i -> do 28 | pushL q i 29 | printf " %d" i 30 | putStrLn "\nDone filling queue with elements. Now popping..." 31 | sumR <- newIORef 0 32 | forM_ [1..n] $ \i -> do 33 | x <- spinPop q 34 | printf " %d" x 35 | modifyIORef sumR (+x) 36 | s <- readIORef sumR 37 | let expected = sum [1..n] :: Int 38 | printf "\nSum of popped vals: %d should be %d\n" s expected 39 | when (s /= expected) (error "Incorrect sum!") 40 | return s 41 | 42 | -- This one splits the numCapabilities threads into producers and consumers 43 | testQ2 :: Int -> IO () 44 | testQ2 total = 45 | do q <- newQ 46 | mv <- newEmptyMVar 47 | let producers = max 1 (numCapabilities `quot` 2) 48 | consumers = producers 49 | perthread = total `quot` producers 50 | 51 | printf "Forking %d producer threads.\n" producers 52 | 53 | forM_ [0..producers-1] $ \ id -> 54 | forkIO $ 55 | forM_ (take perthread [id * producers .. ]) $ \ i -> do 56 | pushL q i 57 | printf " [%d] pushed %d \n" id i 58 | 59 | printf "Forking %d consumer threads.\n" consumers 60 | 61 | forM_ [0..consumers-1] $ \ id -> 62 | forkIO $ do 63 | sum <- newIORef 0 64 | forM_ (take perthread [id * producers .. ]) $ \ i -> do 65 | x <- spinPop q 66 | printf " [%d] popped %d \n" id i 67 | modifyIORef sum (+x) 68 | s <- readIORef sum 69 | putMVar mv s 70 | 71 | printf "Reading sums from MVar...\n" 72 | ls <- mapM (\_ -> takeMVar mv) [1..consumers] 73 | let finalSum = Prelude.sum ls 74 | putStrLn$ "Final sum: "++ show finalSum 75 | return () 76 | 77 | 78 | main = testQ1 -------------------------------------------------------------------------------- /abstract-deque/Data/Concurrent/Deque/Debugger.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- | This module provides a wrapper around a deque that can enforce additional 4 | -- invariants at runtime for debugging purposes. 5 | 6 | module Data.Concurrent.Deque.Debugger 7 | (DebugDeque(DebugDeque)) 8 | where 9 | 10 | import Data.IORef 11 | import Control.Concurrent 12 | import Data.Concurrent.Deque.Class 13 | 14 | -- newtype DebugDeque d = DebugDeque d 15 | 16 | -- | Warning, this enforces the excessively STRONG invariant that if any end of the 17 | -- deque is non-threadsafe then it may ever only be touched by one thread during its 18 | -- entire lifetime. 19 | -- 20 | -- This extreme form of monogamy is easier to verify, because we don't have enough 21 | -- information to know if two operations on different threads are racing with one 22 | -- another or are properly synchronized. 23 | -- 24 | -- The wrapper data structure has two IORefs to track the last thread that touched 25 | -- the left and right end of the deque, respectively. 26 | data DebugDeque d elt = DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId)) (d elt) 27 | 28 | 29 | instance DequeClass d => DequeClass (DebugDeque d) where 30 | pushL (DebugDeque (ref,_) q) elt = do 31 | markThread (leftThreadSafe q) ref 32 | pushL q elt 33 | 34 | tryPopR (DebugDeque (_,ref) q) = do 35 | markThread (rightThreadSafe q) ref 36 | tryPopR q 37 | 38 | newQ = do l <- newIORef Nothing 39 | r <- newIORef Nothing 40 | fmap (DebugDeque (l,r)) newQ 41 | 42 | -- FIXME: What are the threadsafe rules for nullQ? 43 | nullQ (DebugDeque _ q) = nullQ q 44 | 45 | leftThreadSafe (DebugDeque _ q) = leftThreadSafe q 46 | rightThreadSafe (DebugDeque _ q) = rightThreadSafe q 47 | 48 | 49 | instance PopL d => PopL (DebugDeque d) where 50 | tryPopL (DebugDeque (ref,_) q) = do 51 | markThread (leftThreadSafe q) ref 52 | tryPopL q 53 | 54 | -- | Mark the last thread to use this endpoint. 55 | markThread :: Bool -> IORef (Maybe ThreadId) -> IO () 56 | markThread True _ = return () -- Don't bother tracking. 57 | markThread False ref = do 58 | _last <- readIORef ref 59 | tid <- myThreadId 60 | -- putStrLn$"Marking! "++show tid 61 | atomicModifyIORef ref $ \ x -> 62 | case x of 63 | Nothing -> (Just tid, ()) 64 | Just tid2 65 | | tid == tid2 -> (Just tid,()) 66 | | otherwise -> error$ "DebugDeque: invariant violated, thread safety not allowed but accessed by: "++show (tid,tid2) 67 | -------------------------------------------------------------------------------- /atomic-primops/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.8.8 [2024.06.20] 2 | * Fix infinite loops in the implementations of `storeLoadBarrier`, 3 | `loadLoadBarrier`, and `writeBarrier` when building with GHC 9.10 or later. 4 | 5 | ## 0.8.7 [2024.04.20] 6 | * Fix typos in the `foreign import`s introduced in `atomic-primops-0.8.5` and 7 | `atomic-primops-0.8.6`, which would lead to linker errors when building 8 | executables with GHC 9.10. 9 | 10 | ## 0.8.6 [2024.04.16] 11 | * Use `prim`, not `ccall`, for the `foreign import`s used when building the 12 | library with GHC 9.10 or later. This fixes a GHC 9.10-specific build issue. 13 | 14 | ## 0.8.5 [2024.02.17] 15 | * Allow building with GHC 9.10. 16 | 17 | ## 0.8.4 [2020.10.03] 18 | * Allow building with `base-4.15` (GHC 9.0). 19 | 20 | ## 0.8.3 [2019.05.02] 21 | * Allow the tests to build with `base-4.13` (GHC 8.8). 22 | * Require GHC 7.10 or later. 23 | 24 | ## 0.8.2 [2018.03.08] 25 | * Allow building with `base-4.11`. 26 | 27 | ## 0.8.1.1 [2017.12.10] 28 | * Bundle `testing/Fetch.hs` with the package tarball 29 | 30 | ## 0.8.1 31 | * Simplify `Setup.hs` to support `Cabal-2.0`/GHC 8.2 32 | * Properly link `store_load_barrier` and friends against the GHC RTS on Windows 33 | when using GHC 8.2 or later 34 | 35 | ## 0.8.0.4 36 | * Internal changes to support forthcoming GHC 8.0 37 | 38 | ## 0.8 39 | * Implements additional fetch primops available in GHC 7.10 40 | 41 | ## 0.7 42 | * This release adds support for GHC 7.10 and its expanded library of (now inline) primops. 43 | 44 | ## 0.6.1 45 | * This is a good version to use for GHC 7.8.3. It includes portability and bug fixes 46 | and adds atomicModifyIORefCAS. 47 | 48 | ## 0.6.0.5 49 | * fix for GHC 7.8 50 | 51 | ## 0.6.0.1 52 | * minor ghc 7.8 fix 53 | 54 | ## 0.6 55 | * add atomicModifyIORefCAS, and bump due to prev bugfixes 56 | 57 | ## 0.5.0.2 58 | * IMPORTANT BUGFIXES - don't use earlier versions. They have been marked deprecated. 59 | 60 | ## 0.5 61 | * Nix Data.Atomics.Counter.Foreign and the bits-atomic dependency. 62 | 63 | ## 0.4.1 64 | * Add advance support for GHC 7.8 65 | 66 | ## 0.4 67 | * Further internal changes, duplicate 'cas' routine well as barriers. 68 | * Add `fetchAddByteArrayInt` 69 | * Add an `Unboxed` counter variant that uses movable "ByteArray"s on the GHC heap. 70 | 71 | ## 0.3 72 | * Major internal change. Duplicate the barrier code from the GHC RTS and thus 73 | enable support for executables that are NOT built with '-threaded'. 74 | 75 | ## 0.2.2.1 76 | * Minor, add warning. 77 | 78 | ## 0.2.2 79 | * Add more counters 80 | 81 | ## 0.2 82 | * Critical bugfix and add Counter. 83 | 84 | ## 0.1.0.2 85 | * disable profiling 86 | 87 | ## 0.1.0.0 88 | * initial release 89 | -------------------------------------------------------------------------------- /atomic-primops/atomic-primops.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: 3.0 2 | Name: atomic-primops 3 | Version: 0.8.8 4 | License: BSD-3-Clause 5 | License-file: LICENSE 6 | Author: Ryan Newton 7 | Maintainer: rrnewton@gmail.com 8 | Category: Data 9 | -- Portability: non-portabile (x86_64) 10 | Build-type: Simple 11 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 12 | HomePage: https://github.com/rrnewton/haskell-lockfree/wiki 13 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 14 | 15 | Synopsis: A safe approach to CAS and other atomic ops in Haskell. 16 | 17 | Description: 18 | After GHC 7.4 a new `casMutVar#` primop became available, but it's 19 | difficult to use safely, because pointer equality is a highly 20 | unstable property in Haskell. This library provides a safer method 21 | based on the concept of "Tickets". 22 | . 23 | Also, this library uses the "foreign primop" capability of GHC to 24 | add access to other variants that may be of 25 | interest, specifically, compare and swap inside an array. 26 | . 27 | Note that as of GHC 7.8, the relevant primops have been included in GHC itself. 28 | This library is engineered to work pre- and post-GHC-7.8, while exposing the 29 | same interface. 30 | 31 | Extra-Source-Files: DEVLOG.md 32 | testing/Test.hs testing/test-atomic-primops.cabal testing/ghci-test.hs 33 | testing/Makefile testing/CommonTesting.hs testing/Counter.hs testing/CounterCommon.hs testing/hello.hs testing/Fetch.hs 34 | testing/Issue28.hs 35 | testing/TemplateHaskellSplices.hs 36 | testing/Raw781_test.hs 37 | extra-doc-files: CHANGELOG.md 38 | 39 | Flag debug 40 | Description: Enable extra internal checks. 41 | Default: False 42 | 43 | Library 44 | Default-Language: Haskell2010 45 | exposed-modules: Data.Atomics 46 | Data.Atomics.Internal 47 | Data.Atomics.Counter 48 | ghc-options: -O2 -funbox-strict-fields 49 | ghc-options: -Wall 50 | 51 | build-depends: base >= 4.8 && < 5 52 | , ghc-prim 53 | , primitive 54 | 55 | if impl(ghc >= 9.9) 56 | cmm-sources: cbits/atomics.cmm 57 | 58 | if os(windows) { 59 | Include-Dirs: cbits 60 | C-Sources: cbits/RtsDup.c 61 | } 62 | CC-Options: -Wall 63 | 64 | if flag(debug) 65 | cpp-options: -DDEBUG_ATOMICS 66 | 67 | Source-Repository head 68 | Type: git 69 | Location: https://github.com/rrnewton/haskell-lockfree/ 70 | Subdir: atomic-primops 71 | -------------------------------------------------------------------------------- /atomic-primops/benchmarking/IORef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | This version uses a boxed IORef representation, but it can be somewhat cheaper 4 | -- than the Refence version because it uses raw CAS rather than full 5 | -- atomicModifyIORef. 6 | 7 | module Data.Atomics.Counter.IORef 8 | (AtomicCounter, CTicket, 9 | newCounter, readCounterForCAS, readCounter, peekCTicket, 10 | writeCounter, casCounter, incrCounter, incrCounter_) 11 | where 12 | 13 | import Control.Monad (void) 14 | import Data.IORef 15 | import Data.Atomics as A 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | -- type AtomicCounter = IORef Int 20 | newtype AtomicCounter = AtomicCounter (IORef Int) 21 | 22 | type CTicket = Ticket Int 23 | 24 | {-# INLINE newCounter #-} 25 | -- | Create a new counter initialized to the given value. 26 | newCounter :: Int -> IO AtomicCounter 27 | newCounter n = fmap AtomicCounter $ newIORef n 28 | 29 | {-# INLINE incrCounter #-} 30 | -- | Try repeatedly until we successfully increment the counter by a given amount. 31 | -- Returns the original value of the counter (pre-increment). 32 | incrCounter :: Int -> AtomicCounter -> IO Int 33 | -- 34 | incrCounter bump cntr = 35 | loop =<< readCounterForCAS cntr 36 | where 37 | loop tick = do 38 | (b,tick') <- casCounter cntr tick (peekCTicket tick + bump) 39 | if b then return (peekCTicket tick') 40 | else loop tick' 41 | {-# INLINE incrCounter_ #-} 42 | incrCounter_ :: Int -> AtomicCounter -> IO () 43 | incrCounter_ b c = void (incrCounter b c) 44 | -- 45 | 46 | {-# INLINE readCounterForCAS #-} 47 | -- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque 48 | -- ticket that can be used in CAS operations. 49 | readCounterForCAS :: AtomicCounter -> IO CTicket 50 | readCounterForCAS (AtomicCounter r) = readForCAS r 51 | 52 | {-# INLINE peekCTicket #-} 53 | -- | Opaque tickets cannot be constructed, but they can be destructed into values. 54 | peekCTicket :: CTicket -> Int 55 | peekCTicket = peekTicket 56 | 57 | {-# INLINE readCounter #-} 58 | -- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. 59 | readCounter :: AtomicCounter -> IO Int 60 | readCounter (AtomicCounter r) = readIORef r 61 | 62 | {-# INLINE writeCounter #-} 63 | -- | Make a non-atomic write to the counter. No memory-barrier. 64 | writeCounter :: AtomicCounter -> Int -> IO () 65 | writeCounter (AtomicCounter r) !new = writeIORef r new 66 | 67 | {-# INLINE casCounter #-} 68 | -- | Compare and swap for the counter ADT. Similar behavior to `casIORef`. 69 | casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) 70 | casCounter (AtomicCounter r) tick !new = casIORef r tick new 71 | -------------------------------------------------------------------------------- /abstract-deque/abstract-deque.cabal: -------------------------------------------------------------------------------- 1 | Name: abstract-deque 2 | Version: 0.3 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan R. Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data 8 | Build-type: Simple 9 | Cabal-version: >= 1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | Homepage: https://github.com/rrnewton/haskell-lockfree/wiki 12 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 13 | 14 | -- Version History: 15 | -- 0.1: 16 | -- 0.1.1: Added nullQ to interface. [First release] 17 | -- 0.1.2: dependency on IORefCAS 18 | -- 0.1.3: Actually turned on real CAS! DANGER 19 | -- 0.1.4: Another release. 20 | -- 0.1.5: Fix for 6.12 and 7.0. 21 | -- 0.1.6: Make useCAS default FALSE. 22 | -- 0.1.7: Add leftThreadSafe / rightThreadSafe 23 | -- 0.2: [breaking] Refactor names of exposed Tests 24 | -- 0.2.2: Add Debugger 25 | -- 0.2.2.1: Add some extra testing helpers. 26 | -- 0.3: Remove testing utilities to their own package. 27 | 28 | Synopsis: Abstract, parameterized interface to mutable Deques. 29 | 30 | Description: 31 | 32 | An abstract interface to highly-parameterizable queues/deques. 33 | . 34 | Background: There exists a feature space for queues that extends between: 35 | . 36 | * simple, single-ended, non-concurrent, bounded queues 37 | . 38 | * double-ended, threadsafe, growable queues 39 | . 40 | ... with important points inbetween (such as 41 | the queues used for work-stealing). 42 | . 43 | This package includes an interface for Deques that allows the 44 | programmer to use a single API for all of the above, while using the 45 | type-system to select an efficient implementation given the 46 | requirements (using type families). 47 | . 48 | This package also includes a simple reference implementation based 49 | on 'IORef' and "Data.Sequence". 50 | 51 | -- Making this default False because abstract-deque should be VERY depndency-safe. 52 | -- The reference implementation can be factored out in the future. 53 | Flag useCAS 54 | Description: Enable the reference implementation to use hardware compare-and-swap. 55 | Default: False 56 | 57 | Library 58 | exposed-modules: Data.Concurrent.Deque.Class, 59 | Data.Concurrent.Deque.Reference, 60 | Data.Concurrent.Deque.Reference.DequeInstance, 61 | Data.Concurrent.Deque.Debugger 62 | build-depends: base >= 4.8 && < 5 63 | , containers 64 | if flag(useCAS) && impl( ghc >= 7.4 ) && !os(mingw32) { 65 | build-depends: atomic-primops >= 0.5.0.2 66 | cpp-options: -DUSE_CAS -DDEFAULT_SIGNATURES 67 | } 68 | 69 | ghc-options: -O2 70 | default-extensions: CPP 71 | default-language: Haskell2010 72 | 73 | Source-Repository head 74 | Type: git 75 | Location: git://github.com/rrnewton/haskell-lockfree.git 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /.jenkins_common.sh: -------------------------------------------------------------------------------- 1 | 2 | set -e 3 | set -x 4 | 5 | if [ "$JENKINS_GHC" == "" ]; then 6 | echo "Must set JENKINS_GHC to, e.g. '7.6.3', to run this script." 7 | exit 1 8 | fi 9 | 10 | # if [ "$CABAL" == "" ]; then 11 | # if [ "$GHC" == "ghc-7.10.1" ]; then 12 | # CABAL=cabal-1.22 13 | DISABLE_EXEC_PROF="--disable-profiling" 14 | ENABLE_EXEC_PROF="--enable-profiling" 15 | # else 16 | # CABAL=cabal-1.20 17 | # DISABLE_EXEC_PROF="--disable-executable-profiling" 18 | # ENABLE_EXEC_PROF="--enable-executable-profiling" 19 | # fi 20 | # fi 21 | 22 | # Temp: trying this [2015.05.04]: 23 | CABAL=cabal-1.22 24 | 25 | # IU-specific environment setup. 26 | source $HOME/rn_jenkins_scripts/acquire_ghc.sh 27 | which $CABAL 28 | which -a ghc 29 | which -a ghc-$JENKINS_GHC 30 | $CABAL --version 31 | 32 | which -a llc || echo "No LLVM" 33 | 34 | 35 | # Pass OPTLVL directly to cabal: 36 | CBLARGS=" $OPTLVL " 37 | 38 | if [ "$PROF" == "prof" ]; then 39 | CBLARGS="$CBLARGS --enable-library-profiling $ENABLE_EXEC_PROF" 40 | else 41 | CBLARGS="$CBLARGS --disable-library-profiling $DISABLE_EXEC_PROF" 42 | fi 43 | 44 | if [ "$HPC" == "hpc" ]; then 45 | # Remove obsolete --enable-library-coverage: 46 | CBLARGS="$CBLARGS --enable-coverage" 47 | else 48 | CBLARGS="$CBLARGS --disable-coverage" 49 | fi 50 | 51 | if [ "$THREADING" == "nothreads" ]; then 52 | echo "Compiling without threading support." 53 | CBLARGS="$CBLARGS -f-threaded " 54 | else 55 | CBLARGS="$CBLARGS -fthreaded --ghc-options=-threaded " 56 | fi 57 | 58 | ALLPKGS="$PKGS $NOTEST_PKGS" 59 | 60 | $CABAL sandbox init 61 | 62 | root=`pwd` 63 | for subdir in $ALLPKGS; do 64 | cd "$root/$subdir" 65 | $CABAL sandbox init --sandbox=$root/.cabal-sandbox 66 | done 67 | cd "$root" 68 | 69 | # TODO: This should really be set dynamically. 70 | CBLPAR="-j8" 71 | 72 | GHC=ghc-$JENKINS_GHC 73 | 74 | # First install everything without testing: 75 | CMDROOT="$CABAL install --reinstall --force-reinstalls $CBLPAR" 76 | 77 | # ------------------------------------------------------------ 78 | # Method 1: Separate compile and then test. 79 | # Problem is, this is triggering what looks like a cabal-1.20 bug: 80 | # ++ cabal-1.20 test --show-details=always 81 | # cabal-1.20: dist/setup-config: invalid argument 82 | # ------------------------------------------------------------ 83 | 84 | # Install the DEPENDENCIES for packages and tests: 85 | # And install the packages themselves to satisy interdependencies. 86 | $CMDROOT $CBLARGS --enable-tests $PKGS 87 | 88 | # List what we've got: 89 | $CABAL sandbox hc-pkg list 90 | 91 | echo "Everything installed, now to test." 92 | for subdir in $TESTPKGS; do 93 | cd "$root/$subdir" 94 | $CABAL configure --enable-tests $CBLARGS 95 | # Print the individual test outputs: 96 | $CABAL test --show-details=streaming 97 | done 98 | 99 | # ------------------------------------------------------------ 100 | # Method 2: A single install/test command 101 | # ------------------------------------------------------------ 102 | 103 | # $CMDROOT $CBLARGS $PKGS --run-tests 104 | # $CABAL sandbox hc-pkg list 105 | -------------------------------------------------------------------------------- /atomic-primops/benchmarking/Reference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | This reference version is implemented with atomicModifyIORef and can be a useful 4 | -- fallback if one of the other implementations needs to be debugged for a given 5 | -- architecture. 6 | module Data.Atomics.Counter.Reference 7 | (AtomicCounter, CTicket, 8 | newCounter, readCounterForCAS, readCounter, peekCTicket, 9 | writeCounter, casCounter, incrCounter, incrCounter_) 10 | where 11 | 12 | import Control.Monad (void) 13 | import Data.IORef 14 | -- import Data.Atomics 15 | import System.IO.Unsafe (unsafePerformIO) 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | -- type AtomicCounter = IORef Int 20 | newtype AtomicCounter = AtomicCounter (IORef Int) 21 | 22 | type CTicket = Int 23 | 24 | {-# INLINE newCounter #-} 25 | -- | Create a new counter initialized to the given value. 26 | newCounter :: Int -> IO AtomicCounter 27 | newCounter !n = fmap AtomicCounter $ newIORef n 28 | 29 | {-# INLINE incrCounter #-} 30 | -- | Try repeatedly until we successfully increment the counter by a given amount. 31 | -- Returns the original value of the counter (pre-increment). 32 | incrCounter :: Int -> AtomicCounter -> IO Int 33 | incrCounter !bump !cntr = 34 | loop =<< readCounterForCAS cntr 35 | where 36 | loop tick = do 37 | (b,tick') <- casCounter cntr tick (peekCTicket tick + bump) 38 | if b then return (peekCTicket tick') 39 | else loop tick' 40 | 41 | {-# INLINE incrCounter_ #-} 42 | incrCounter_ :: Int -> AtomicCounter -> IO () 43 | incrCounter_ b c = void (incrCounter b c) 44 | 45 | {-# INLINE readCounterForCAS #-} 46 | -- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque 47 | -- ticket that can be used in CAS operations. 48 | readCounterForCAS :: AtomicCounter -> IO CTicket 49 | readCounterForCAS = readCounter 50 | 51 | {-# INLINE peekCTicket #-} 52 | -- | Opaque tickets cannot be constructed, but they can be destructed into values. 53 | peekCTicket :: CTicket -> Int 54 | peekCTicket !x = x 55 | 56 | {-# INLINE readCounter #-} 57 | -- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. 58 | readCounter :: AtomicCounter -> IO Int 59 | readCounter (AtomicCounter r) = readIORef r 60 | 61 | {-# INLINE writeCounter #-} 62 | -- | Make a non-atomic write to the counter. No memory-barrier. 63 | writeCounter :: AtomicCounter -> Int -> IO () 64 | writeCounter (AtomicCounter r) !new = writeIORef r new 65 | 66 | {-# INLINE casCounter #-} 67 | -- | Compare and swap for the counter ADT. Similar behavior to `casIORef`. 68 | casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) 69 | casCounter (AtomicCounter r) oldT !new = 70 | let old = oldT in 71 | atomicModifyIORef' r $ \val -> 72 | if (val == old) 73 | then (new, (True, new)) 74 | else (val, (False,val)) 75 | 76 | 77 | {- 78 | {-# NOINLINE unsafeName #-} 79 | unsafeName :: a -> Int 80 | unsafeName x = unsafePerformIO $ do 81 | sn <- makeStableName x 82 | return (hashStableName sn) 83 | 84 | {-# NOINLINE ptrEq #-} 85 | ptrEq :: a -> a -> Bool 86 | ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1 87 | 88 | -} 89 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/IORefCAS.cabal: -------------------------------------------------------------------------------- 1 | Name: IORefCAS 2 | Version: 0.2.0.1 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Adam C. Foltzer, Ryan Newton 6 | Maintainer: acfoltzer@gmail.com, rrnewton@gmail.com 7 | Category: Data 8 | Build-type: Simple 9 | Cabal-version: >=1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | HomePage: https://github.com/rrnewton/haskell-lockfree/wiki 12 | 13 | -- Version History: 14 | -- 0.0.1 -- initial release 15 | -- 0.0.1.1 -- minor bump to include README 16 | -- 0.0.1.2 -- Egad, super minor update. 17 | -- 0.1.0.1 -- Include ptrEq in Data.CAS 18 | -- 0.2 -- Bumped for #if policy to test for GHC >7.2. Removed casSTRef from the API for now. 19 | -- 0.2.0.1 -- fix for test suite 20 | 21 | Synopsis: Atomic compare and swap for IORefs and STRefs. 22 | 23 | Description: 24 | 25 | After GHC 7.2 a new `casMutVar#` primop became available, but was 26 | not yet exposed in Data.IORef. This package fills that gap until 27 | such a time as Data.IORef obsoletes it. 28 | . 29 | Further, in addition to exposing native Haskell CAS operations, this 30 | package contains \"mockups\" that imititate the same functionality 31 | using either atomicModifyIORef and unsafe pointer equality (in 32 | @Data.CAS.Fake@) or using foreign functions (@Data.CAS.Foreign@). 33 | These alternatives are useful for debugging. 34 | . 35 | Note that the foreign option does not operate on IORefs and so is 36 | directly interchangeable with `Data.CAS` and `Data.CAS.Fake` only if 37 | the interface in `Data.CAS.Class` is used. 38 | 39 | Extra-Source-Files: 40 | Makefile, Test.hs, README.md 41 | 42 | Library 43 | exposed-modules: Data.CAS, 44 | Data.CAS.Internal.Class, 45 | Data.CAS.Internal.Fake, 46 | Data.CAS.Internal.Native 47 | if (!os(mingw32)) 48 | exposed-modules: Data.CAS.Internal.Foreign 49 | -- I have observed problems on both Mac and Linux with 7.0.x. [2011.12.23] 50 | -- Thus for now we require GHC 7.2 or greater (base 4.4 or greater). 51 | -- Namely Test.hs observes CAS failing half the time even with only ONE thread. 52 | -- This is probably a tricky pointer-equality related problem. 53 | build-depends: base >= 4.8 && < 5 54 | , ghc-prim 55 | , bits-atomic 56 | default-language: Haskell2010 57 | 58 | -- Executable 59 | Test-Suite test-IORefCAS 60 | type: exitcode-stdio-1.0 61 | main-is: Test.hs 62 | ghc-options: -O2 -threaded -rtsopts 63 | cpp-options: -DT1 -DT2 64 | if !os(mingw32) 65 | cpp-options: -DT3 66 | build-depends: base >= 4.8 && < 5 67 | , time 68 | , ghc-prim 69 | , QuickCheck 70 | , HUnit 71 | , bits-atomic 72 | default-language: Haskell2010 73 | 74 | -- TODO: Refactor to use test-framework: 75 | -- , test-framework, test-framework-hunit 76 | -- test-framework-quickcheck2 77 | 78 | Source-Repository head 79 | Type: git 80 | Location: git://github.com/rrnewton/haskell-lockfree.git 81 | -------------------------------------------------------------------------------- /chaselev-deque/chaselev-deque.cabal: -------------------------------------------------------------------------------- 1 | Name: chaselev-deque 2 | Version: 0.5.0.5 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan R. Newton, Edward Kmett 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data, Concurrent 8 | Build-type: Simple 9 | Cabal-version: >=1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | 12 | Homepage: https://github.com/rrnewton/haskell-lockfree/wiki 13 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 14 | 15 | Synopsis: Chase & Lev work-stealing lock-free double-ended queues (deques). 16 | 17 | Description: 18 | 19 | A queue that is push/pop on one end and pop-only on the other. These are commonly 20 | used for work-stealing. 21 | This implementation derives directly from the pseudocode in the 2005 SPAA paper: 22 | . 23 | http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.170.1097&rep=rep1&type=pdf 24 | 25 | extra-source-files: CHANGELOG.md, README.md 26 | 27 | Flag debug 28 | Description: Enable the extra internal checks. 29 | Default: False 30 | 31 | Library 32 | exposed-modules: Data.Concurrent.Deque.ChaseLev.DequeInstance 33 | Data.Concurrent.Deque.ChaseLev 34 | Data.Concurrent.Deque.ChaseLevUnboxed 35 | -- Data.Concurrent.Deque.ChaseLev2 36 | -- Disabling this [2012.03.08]. It got terrible performance anyway: 37 | -- Data.Concurrent.Deque.ReactorDeque 38 | -- other-modules: Data.Concurrent.Deque.ChaseLevUnboxed 39 | 40 | build-depends: base >= 4.8 && < 5 41 | , array 42 | , transformers 43 | , abstract-deque >= 0.3 && < 0.4 44 | , vector 45 | , ghc-prim 46 | , atomic-primops >= 0.5.0.2 47 | ghc-options: -O2 48 | if flag(debug) 49 | cpp-options: -DDEBUGCL 50 | default-language: Haskell2010 51 | 52 | Source-Repository head 53 | Type: git 54 | Location: git://github.com/rrnewton/haskell-lockfree.git 55 | 56 | Test-Suite test-chaselev-deque 57 | type: exitcode-stdio-1.0 58 | hs-source-dirs: tests 59 | main-is: Test.hs 60 | other-modules: RegressionTests.Issue5 61 | RegressionTests.Issue5B 62 | build-depends: base >= 4.8 && < 5 63 | , abstract-deque >= 0.3 && < 0.4 64 | , abstract-deque-tests >= 0.3 65 | , HUnit 66 | , test-framework 67 | , test-framework-hunit 68 | , atomic-primops >= 0.5.0.2 69 | , vector 70 | , containers 71 | , ghc-prim 72 | , array 73 | , chaselev-deque 74 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N4 75 | default-language: Haskell2010 76 | -- ghc-options: -O2 -threaded -rtsopts 77 | -- -- Debugging generated code: 78 | -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint 79 | -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings 80 | -------------------------------------------------------------------------------- /atomic-primops-foreign/Data/Atomics/Counter/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | This implementation stores an unboxed counter and uses FFI operations to modify 4 | -- its contents. It has the advantage that it can use true fetch-and-add operations. 5 | -- It has the disadvantage of extra overhead due to FFI calls. 6 | -- 7 | -- For more documentation, see the module "Data.Atomics.Counter", which exports 8 | -- the same interface as this module. 9 | 10 | module Data.Atomics.Counter.Foreign 11 | (AtomicCounter, CTicket, 12 | newCounter, readCounterForCAS, readCounter, peekCTicket, 13 | writeCounter, casCounter, incrCounter, incrCounter_) 14 | where 15 | import Control.Monad (void) 16 | import Data.Bits.Atomic 17 | import Foreign.ForeignPtr 18 | import Foreign.Storable 19 | 20 | -- | The type of mutable atomic counters. 21 | type AtomicCounter = ForeignPtr Int 22 | 23 | -- | You should not depend on this type. It varies between different implementations 24 | -- of atomic counters. 25 | type CTicket = Int 26 | 27 | {-# INLINE newCounter #-} 28 | -- | Create a new counter initialized to the given value. 29 | newCounter :: Int -> IO AtomicCounter 30 | newCounter n = do x <- mallocForeignPtr 31 | writeCounter x n 32 | -- Do we need a write barrier here? 33 | return x 34 | 35 | {-# INLINE incrCounter #-} 36 | -- | Increment the counter by a given amount. 37 | -- Returns the original value before the increment. 38 | -- 39 | -- Note that UNLIKE with boxed implementations of counters, where increment is 40 | -- based on CAS, this increment is /O(1)/. Fetch-and-add does not require a retry 41 | -- loop like CAS. 42 | incrCounter :: Int -> AtomicCounter -> IO Int 43 | incrCounter bump r = withForeignPtr r$ \r' -> addAndFetch r' bump 44 | 45 | {-# INLINE incrCounter_ #-} 46 | -- | An alternate version for when you don't care about the old value. 47 | incrCounter_ :: Int -> AtomicCounter -> IO () 48 | incrCounter_ bump r = withForeignPtr r$ \r' -> void (addAndFetch r' bump) 49 | 50 | {-# INLINE readCounterForCAS #-} 51 | -- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque 52 | -- ticket that can be used in CAS operations. 53 | readCounterForCAS :: AtomicCounter -> IO CTicket 54 | readCounterForCAS = readCounter 55 | 56 | {-# INLINE peekCTicket #-} 57 | -- | Opaque tickets cannot be constructed, but they can be destructed into values. 58 | peekCTicket :: CTicket -> Int 59 | peekCTicket x = x 60 | 61 | {-# INLINE readCounter #-} 62 | -- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. 63 | readCounter :: AtomicCounter -> IO Int 64 | readCounter r = withForeignPtr r peek 65 | 66 | {-# INLINE writeCounter #-} 67 | -- | Make a non-atomic write to the counter. No memory-barrier. 68 | writeCounter :: AtomicCounter -> Int -> IO () 69 | writeCounter r !new = withForeignPtr r $ \r' -> poke r' new 70 | 71 | {-# INLINE casCounter #-} 72 | -- | Compare and swap for the counter ADT. 73 | casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) 74 | casCounter r !tick !new = withForeignPtr r $ \r' -> do 75 | cur <- compareAndSwap r' tick new 76 | if cur==tick 77 | then return (True,new) 78 | else return (False,cur) 79 | -- return (b==tick, b) 80 | -------------------------------------------------------------------------------- /lockfree-queue/lockfree-queue.cabal: -------------------------------------------------------------------------------- 1 | Name: lockfree-queue 2 | Version: 0.2.4 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Ryan R. Newton 6 | Maintainer: rrnewton@gmail.com 7 | Category: Data, Concurrent 8 | Build-type: Simple 9 | Cabal-version: 1.18 10 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 11 | Homepage: https://github.com/rrnewton/haskell-lockfree/wiki 12 | Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues 13 | 14 | Synopsis: Michael and Scott lock-free queues. 15 | 16 | Description: 17 | 18 | Michael and Scott queues are described in their PODC 1996 paper: 19 | . 20 | 21 | . 22 | These are single-ended concurrent queues based on a singlly linked 23 | list and using atomic CAS instructions to swap the tail pointers. 24 | As a well-known efficient algorithm they became the basis for Java's 25 | @ConcurrentLinkedQueue@. 26 | 27 | extra-source-files: 28 | CHANGELOG.md 29 | README.md 30 | stress_test.sh 31 | 32 | Library 33 | exposed-modules: Data.Concurrent.Queue.MichaelScott, 34 | Data.Concurrent.Queue.MichaelScott.DequeInstance 35 | build-depends: base >= 4.8 && < 5 36 | , ghc-prim 37 | , abstract-deque >= 0.3 38 | , atomic-primops >= 0.6 39 | -- Build failure on GHC 7.2: 40 | -- queuelike 41 | ghc-options: -O2 42 | default-language: Haskell2010 43 | 44 | Source-Repository head 45 | Type: git 46 | Location: git://github.com/rrnewton/haskell-lockfree.git 47 | 48 | 49 | Test-Suite test-lockfree-queue 50 | type: exitcode-stdio-1.0 51 | hs-source-dirs: tests 52 | main-is: Test.hs 53 | build-depends: lockfree-queue 54 | build-depends: base >= 4.8 && < 5 55 | , bytestring 56 | , abstract-deque >= 0.3 57 | , abstract-deque-tests >= 0.3 58 | , HUnit 59 | , test-framework 60 | , test-framework-hunit 61 | , ghc-prim 62 | , atomic-primops >= 0.6 63 | 64 | ghc-options: -O2 -threaded -rtsopts 65 | default-language: Haskell2010 66 | -- Debugging generated code: 67 | -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint 68 | -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings 69 | 70 | 71 | -- Executable benchmark-lockfree-queue 72 | -- main-is: Benchmark.hs 73 | -- build-depends: base >= 4.4.0.0 && < 5, IORefCAS >= 0.2, abstract-deque, bytestring, 74 | -- HUnit, test-framework, test-framework-hunit, 75 | -- ghc-prim, atomic-primops 76 | -- ghc-options: -O2 -threaded -rtsopts 77 | -- -- Debugging generated code: 78 | -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint 79 | -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings 80 | -------------------------------------------------------------------------------- /chaselev-deque/Data/Concurrent/Deque/ChaseLev2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, NamedFieldPuns, CPP #-} 2 | 3 | -- | Chase-Lev work stealing Deques 4 | -- 5 | -- This implementation derives directly from the pseudocode in the 2005 SPAA paper: 6 | -- 7 | -- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.170.1097&rep=rep1&type=pdf 8 | -- 9 | module Data.Concurrent.Deque.ChaseLev2 10 | ( 11 | -- The convention here is to directly provide the concrete 12 | -- operations as well as providing the class instances. 13 | ChaseLevDeque(), newQ, nullQ, pushL, tryPopL, tryPopR 14 | ) 15 | where 16 | 17 | import Data.IORef 18 | import qualified Data.Concurrent.Deque.Class as PC 19 | 20 | import qualified Data.Vector.Mutable as MV 21 | import qualified Data.Vector as V 22 | -- import Data.Vector.Unboxed.Mutable as V 23 | -- import Data.Vector 24 | import Text.Printf (printf) 25 | import Control.Exception(catch, SomeException, throw, evaluate) 26 | import Control.Monad (when, unless, forM_) 27 | -- import Control.Monad.ST 28 | 29 | -- import Data.CAS (casIORef) 30 | import Data.Atomics (casIORef, readForCAS) 31 | 32 | -------------------------------------------------------------------------------- 33 | -- Instances 34 | 35 | instance PC.DequeClass ChaseLevDeque where 36 | newQ = newQ 37 | nullQ = nullQ 38 | pushL = pushL 39 | tryPopR = tryPopR 40 | 41 | instance PC.PopL ChaseLevDeque where 42 | tryPopL = tryPopL 43 | 44 | -------------------------------------------------------------------------------- 45 | 46 | data ChaseLevDeque a = CLD { 47 | top :: {-# UNPACK #-} !(IORef Int) 48 | , bottom :: {-# UNPACK #-} !(IORef Int) 49 | -- This is a circular array: 50 | , activeArr :: {-# UNPACK #-} !(IORef (MV.IOVector a)) 51 | } 52 | 53 | -- create a new queue, first implementation will not support resizing 54 | newQ :: IO (ChaseLevDeque a) 55 | newQ = do 56 | -- initial size of 8 57 | v <- MV.new 8 58 | bRef <- newIORef 0 59 | tRef <- newIORef 0 60 | vRef <- newIORef v 61 | return$ CLD bRef tRef vRef 62 | 63 | nullQ :: ChaseLevDeque a -> IO Bool 64 | nullQ = CLD { top, bottom } = do 65 | b <- readIORef bottom 66 | t <- readIORef top 67 | let size = b - t 68 | return (size <= 0) 69 | 70 | pushL :: ChaseLevDeque a -> a -> IO () 71 | pushL CLD { top, bottom, array } obj = do 72 | b <- readIORef bottom 73 | t <- readIORef top 74 | arr <- readIORef array 75 | let len = MV.length arr 76 | size = b - t 77 | 78 | -- at this point handle resizing -- 79 | 80 | putCirc arr b obj 81 | writeIORef bottom (b+1) 82 | RETURN () 83 | 84 | tryPopR :: ChaseLevDeque a -> IO (Maybe a) 85 | tryPopR CLD { top, bottom, array } = do 86 | (ticket,t) <- readForCAS top 87 | b <- readIORef bottom 88 | arr <- readIORef array 89 | let size = b - t 90 | if size <= 0 then 91 | return Nothing 92 | else do 93 | obj <- getCirc arr t 94 | (bool,_) <- casIORef top ticket (t+1) 95 | if bool 96 | Just obj 97 | else 98 | Nothing 99 | 100 | tryPopL :: ChaseLevDeque a -> IO (Maybe a) 101 | tryPopL CLD { top, bottom, array } = do 102 | (ticket,t) <- readForCAS top 103 | b <- readIORef bottom 104 | arr <- readIORef array 105 | let size = b - t 106 | if size <= 0 then 107 | return Nothing 108 | else do 109 | obj <- getCirc arr b 110 | (bool,_) <- casIORef top ticket (t+1) 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /atomic-primops/Makefile: -------------------------------------------------------------------------------- 1 | #-------------------------------------------------------------------------------- 2 | # INSTRUCTIONS: 3 | # 4 | # This builds the tests with several GHC versions and with or without profiling. 5 | # 6 | #-------------------------------------------------------------------------------- 7 | 8 | # [2014.02.02] FIXME: this was written for cabal-dev and has not been 9 | # updated for cabal sandboxes. 10 | 11 | ifeq ($(GHC),) 12 | GHC=ghc 13 | endif 14 | 15 | ifeq ($(CABAL),) 16 | CABAL=cabal 17 | # CABAL=cabal-dev 18 | endif 19 | 20 | ifeq ($(DEST),) 21 | DEST=cat 22 | endif 23 | 24 | ifeq ($(PROF),1) 25 | INSTALL_FLAGS= -v --enable-library-profiling --ghc-options=-prof 26 | CBLDEVDIR= cabal-dev/$(GHC)_prof 27 | else 28 | CBLDEVDIR= cabal-dev/$(GHC) 29 | endif 30 | 31 | ifeq ($(INSTALL_FLAGS),) 32 | INSTALL_FLAGS = --disable-library-profiling --disable-documentation 33 | endif 34 | 35 | ifeq ($(CABAL),cabal-dev) 36 | DEPSINSTALL= install-deps -s $(CBLDEVDIR) 37 | EXEC= ./$(CBLDEVDIR)/bin/test-atomic-primops_$(GHC) 38 | INSTALL_FLAGS += -s $(CBLDEVDIR) 39 | else 40 | DEPSINSTALL= install --only-dependencies -j 41 | # EXEC= ./dist/build/test-atomic-primops/test-atomic-primops_$(GHC) 42 | EXEC=$(HOME)/.cabal/bin/test-atomic-primops_$(GHC) 43 | endif 44 | 45 | # Ok, --enable-executable-profiling seems BROKEN [2013.04.20]. It's simply not passing -prof to ghc. 46 | # INSTALL_FLAGS = --enable-library-profiling --enable-executable-profiling 47 | # INSTALL_FLAGS = --disable-library-profiling --disable-documentation 48 | # -j seems broken in cabal-dev 0.9.2 49 | # INSTALL_FLAGS += -j 50 | 51 | test: buildtest runtest 52 | 53 | buildtest: 54 | # FIXME: Is the separate deps install still necessary with a separate build dir? [2013.05.07] 55 | # First install deps WITH profiling: 56 | $(CABAL) $(DEPSINSTALL) --enable-library-profiling --disable-documentation --with-ghc=$(GHC) ./ ./testing/ 57 | # Install the lib and executable with the specified mode: 58 | $(CABAL) install $(INSTALL_FLAGS) --disable-documentation --with-ghc=$(GHC) --program-suffix=_$(GHC) ./ ./testing/ 59 | 60 | runtest: 61 | $(EXEC) +RTS -N -T -RTS 62 | 63 | prof: 64 | PROF=1 ${MAKE} test 2>&1 | ${DEST} 65 | 66 | #-------------------------------------------------------------------------- 67 | 68 | # 7.0 and 7.2 having problems... 69 | # all: test76 test74 prof76 prof74 70 | # [2013.05.07] Now we depend on ANY, so really 7.6 is required: 71 | all: test76 prof76 72 | 73 | # Experimenting with hydra print: 74 | hydra: 75 | (DEST=hydra-head ${MAKE} -j all) | hydra-view 76 | 77 | GHC74=ghc-7.4.2 78 | GHC76=ghc-7.6.3 79 | 80 | 81 | test70: 82 | GHC=ghc-7.0.4 ${MAKE} test 2>&1 | ${DEST} 83 | 84 | test72: 85 | GHC=ghc-7.2.2 ${MAKE} test 2>&1 | ${DEST} 86 | 87 | test74: 88 | GHC=$(GHC74) ${MAKE} test 2>&1 | ${DEST} 89 | 90 | test76: 91 | GHC=$(GHC76) ${MAKE} test 2>&1 | ${DEST} 92 | 93 | prof70: 94 | GHC=ghc-7.0.4 PROF=1 ${MAKE} test 2>&1 | ${DEST} 95 | 96 | prof72: 97 | GHC=ghc-7.2.2 PROF=1 ${MAKE} test 2>&1 | ${DEST} 98 | 99 | prof74: 100 | GHC=$(GHC74) PROF=1 ${MAKE} test 2>&1 | ${DEST} 101 | 102 | prof76: 103 | GHC=$(GHC76) PROF=1 ${MAKE} test 2>&1 | ${DEST} 104 | 105 | 106 | global70: 107 | CABAL=cabal ${MAKE} test70 108 | 109 | global72: 110 | CABAL=cabal ${MAKE} test72 111 | 112 | global74: 113 | CABAL=cabal ${MAKE} test74 114 | 115 | global76: 116 | CABAL=cabal ${MAKE} test76 117 | -------------------------------------------------------------------------------- /atomic-primops/Data/Atomics/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TypeSynonymInstances, BangPatterns #-} 2 | {-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, MagicHash, UnboxedTuples, UnliftedFFITypes #-} 3 | 4 | #define CASTFUN 5 | 6 | -- | This module provides only the raw primops (and necessary types) for atomic 7 | -- operations. 8 | module Data.Atomics.Internal 9 | ( 10 | casIntArray#, fetchAddIntArray#, 11 | readForCAS#, casMutVarTicketed#, casArrayTicketed#, 12 | Ticket, 13 | -- * Very unsafe, not to be used 14 | ptrEq 15 | ) 16 | where 17 | 18 | import GHC.Exts (Int(I#), Any, RealWorld, Int#, State#, MutableArray#, MutVar#, 19 | unsafeCoerce#, reallyUnsafePtrEquality#, 20 | casArray#, casIntArray#, fetchAddIntArray#, readMutVar#, casMutVar#) 21 | 22 | #ifdef DEBUG_ATOMICS 23 | {-# NOINLINE readForCAS# #-} 24 | {-# NOINLINE casMutVarTicketed# #-} 25 | {-# NOINLINE casArrayTicketed# #-} 26 | #else 27 | -- {-# INLINE casMutVarTicketed# #-} 28 | {-# INLINE casArrayTicketed# #-} 29 | -- I *think* inlining may be ok here as long as casting happens on the arrow types: 30 | #endif 31 | 32 | -------------------------------------------------------------------------------- 33 | -- CAS and friends 34 | -------------------------------------------------------------------------------- 35 | 36 | -- | Unsafe, machine-level atomic compare and swap on an element within an Array. 37 | casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a 38 | -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #) 39 | -- WARNING: cast of a function -- need to verify these are safe or eta expand. 40 | casArrayTicketed# = unsafeCoerce# casArray# 41 | 42 | -- | When performing compare-and-swaps, the /ticket/ encapsulates proof 43 | -- that a thread observed a specific previous value of a mutable 44 | -- variable. It is provided in lieu of the "old" value to 45 | -- compare-and-swap. 46 | -- 47 | -- Design note: `Ticket`s exist to hide objects from the GHC compiler, which 48 | -- can normally perform many optimizations that change pointer equality. A Ticket, 49 | -- on the other hand, is a first-class object that can be handled by the user, 50 | -- but will not have its pointer identity changed by compiler optimizations 51 | -- (but will of course, change addresses during garbage collection). 52 | newtype Ticket a = Ticket Any 53 | -- If we allow tickets to be a pointer type, then the garbage collector will update 54 | -- the pointer when the object moves. 55 | 56 | instance Show (Ticket a) where 57 | show _ = "" 58 | 59 | {-# NOINLINE ptrEq #-} 60 | ptrEq :: a -> a -> Bool 61 | ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1 62 | 63 | instance Eq (Ticket a) where 64 | (==) = ptrEq 65 | 66 | -------------------------------------------------------------------------------- 67 | 68 | readForCAS# :: MutVar# RealWorld a -> 69 | State# RealWorld -> (# State# RealWorld, Ticket a #) 70 | -- WARNING: cast of a function -- need to verify these are safe or eta expand: 71 | #ifdef CASTFUN 72 | readForCAS# = unsafeCoerce# readMutVar# 73 | #else 74 | readForCAS# mv rw = 75 | case readMutVar# mv rw of 76 | (# rw', a #) -> (# rw', unsafeCoerce# a #) 77 | #endif 78 | 79 | 80 | casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a -> 81 | State# RealWorld -> (# State# RealWorld, Int#, Ticket a #) 82 | -- WARNING: cast of a function -- need to verify these are safe or eta expand: 83 | casMutVarTicketed# = unsafeCoerce# casMutVar# 84 | -------------------------------------------------------------------------------- /abstract-deque/DEVLOG.txt: -------------------------------------------------------------------------------- 1 | 2 | A log of development activities for this package. 3 | 4 | 5 | [2011.12.29] Observing stack overflow when testing Reference.hs 6 | =============================================================== 7 | 8 | Something is wrong with my HUnit testing framework because I found the 9 | following in the .log file after running "cabal test". 10 | 11 | Test suite test-abstract-deque: RUNNING... 12 | Cases: 2 Tried: 1 Errors: 0 Failures: 0Testing reference deque implementation. 13 | Done creating queue. Pushing elements: 14 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 .... 15 | Done filling queue with elements. Now popping... 16 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 .... 17 | Sum of popped vals: 500500 should be 500500 18 | Check that queue is initially null: True 19 | Forking 1 producer threads. 20 | [0] pushed 0 21 | [0] pushed 1 22 | [0] pushed 2 23 | [0] pushed 3 24 | [0] Stack space overflow: current size 8388608 bytes. 25 | Use `+RTS -Ksize -RTS' to increase it. 26 | ### Error in: 1:test_fifo_HalfToHalf 27 | thread blocked indefinitely in an MVar operation 28 | Cases: 2 Tried: 2 Errors: 1 Failures: 0 29 | pushed 4 30 | [0] pushed 5 31 | [0] pushed 6 32 | [0] pushed 7 33 | [0] pushed 8 34 | [0] pushed 9 35 | Forking 1 consumer threads. 36 | Reading sums from MVar... 37 | Test suite test-abstract-deque: PASS 38 | Test suite logged to: dist/test/abstract-deque-0.1.3-test-abstract-deque.log 39 | 40 | How is that "PASS" if it got a stack overflow!!! 41 | 42 | This looks like a problem with exception handling across threads? 43 | 44 | But wait a second, sometimes it appears to error in the *beginning*: 45 | 46 | Test suite test-abstract-deque: RUNNING... 47 | Cases: 2 Tried: 1 Errors: 0 Failures: 0Stack space overflow: current size 8388608 bytes. 48 | Use `+RTS -Ksize -RTS' to increase it. 49 | ### Error in: 1:test_fifo_HalfToHalf 50 | thread blocked indefinitely in an MVar operation 51 | Cases: 2 Tried: 2 Errors: 1 Failures: 0 52 | Testing reference deque implementation. 53 | 54 | Test FIFO queue: sequential fill and then drain 55 | =============================================== 56 | Done creating queue. Pushing elements: 57 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ... 58 | Done filling queue with elements. Now popping... 59 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 .... 60 | Sum of popped vals: 500500 should be 500500 61 | 62 | Test FIFO queue: producer/consumer Half-To-Half 63 | =============================================== 64 | Check that queue is initially null: True 65 | Forking 1 producer threads. 66 | [0] pushed 0 67 | [0] pushed 1 68 | [0] pushed 2 69 | [0] pushed 3 70 | [0] pushed 4 71 | [0] pushed 5 72 | [0] pushed 6 73 | [0] pushed 7 74 | [0] pushed 8 75 | [0] pushed 9 76 | Forking 1 consumer threads. 77 | Reading sums from MVar... 78 | Test suite test-abstract-deque: PASS 79 | Test suite logged to: dist/test/abstract-deque-0.1.3-test-abstract-deque.log 80 | 81 | That almost looks like the test driver (cabal?) is retrying with a larger stack size automatically!?? 82 | 83 | But then if I compile Test.hs manually and run it directly I never see the stack overflow to begin with. 84 | 85 | Oh wait, I think this overflow is actually coming from cabal itself! 86 | I'm using the parallel (patched) version of cabal. NOPE, using the 87 | regular cabal still results in the stack overflow. 88 | 89 | [ Update: the reason it was passing above was simply that I didn't 90 | exit with an error code: runTestTT won't do it. Once fixed the 91 | stack overflows DO result in test failures. ] 92 | 93 | Right now it's failing nondeterministically. 94 | 95 | -------------------------------------------------------------------------------- /abstract-deque-tests/tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables, NamedFieldPuns, BangPatterns #-} 2 | {-# OPTIONS_GHC -with-rtsopts=-K32M #-} 3 | 4 | import Data.Concurrent.Deque.Class 5 | -- import Data.Concurrent.Deque.Class.Reference (newQueue) 6 | -- import Data.Concurrent.MegaDeque 7 | import Data.Int 8 | import Data.Array as A 9 | import Control.Concurrent (yield) 10 | import Test.Framework (defaultMain) 11 | import Test.Framework.Providers.HUnit (hUnitTestToTests) 12 | import Test.HUnit (assert, assertEqual, Test(TestCase, TestList, TestLabel)) 13 | import qualified Data.Concurrent.Deque.Tests as T 14 | import qualified Data.Concurrent.Deque.Reference as R 15 | import qualified Data.Concurrent.Deque.Class as C 16 | import Data.Concurrent.Deque.Debugger (DebugDeque) 17 | import System.Environment (withArgs) 18 | 19 | -- Import the instances: 20 | import Data.Concurrent.Deque.Reference.DequeInstance () 21 | 22 | test_1 :: Test 23 | test_1 = TestCase $ assert $ 24 | do q <- R.newQ -- Select a specific implementation. 25 | pushR q 3 26 | Just x <- tryPopR q 27 | assertEqual "test_1 result" x (3::Integer) 28 | 29 | test_2 :: Test 30 | test_2 = TestCase $ assert $ 31 | do 32 | -- Here's an example of type-based restriction of the queue implementation: 33 | q <- newQ :: IO (Deque NT T D S Bound Safe Int) 34 | pushL q 33 35 | -- pushR q 33 -- This would cause a type error because the Right end is not Double-capable. 36 | Just x <- tryPopR q 37 | assertEqual "test_2 result" x 33 38 | 39 | test_parfib_work_stealing_specialized :: T.Elt -> IO T.Elt 40 | test_parfib_work_stealing_specialized origInput = do 41 | putStrLn$ " [parfib] Computing fib("++show origInput++")" 42 | numAgents <- T.getNumAgents 43 | qs <- sequence (replicate numAgents R.newQ) 44 | let arr = A.listArray (0,numAgents - 1) qs 45 | 46 | let parfib !myId !myQ !mySum !num 47 | | num <= 2 = 48 | do x <- R.tryPopL myQ 49 | case x of 50 | Nothing -> trySteal myId myQ (mySum+1) 51 | Just n -> parfib myId myQ (mySum+1) n 52 | | otherwise = do 53 | R.pushL myQ (num-1) 54 | parfib myId myQ mySum (num-2) 55 | 56 | trySteal !myId !myQ !mySum = 57 | let loop ind 58 | -- After we finish one sweep... we're completely done. 59 | | ind == myId = return mySum 60 | | ind == size arr = loop 0 61 | | otherwise = do 62 | x <- R.tryPopR (arr ! ind) 63 | case x of 64 | Just n -> parfib myId myQ mySum n 65 | Nothing -> do yield 66 | loop (ind+1) 67 | in loop (myId+1) 68 | 69 | size a = let (st,en) = A.bounds a in en - st + 1 70 | 71 | partial_sums <- T.forkJoin numAgents $ \ myId -> 72 | if myId == 0 73 | then parfib myId (arr ! myId) 0 origInput 74 | else trySteal myId (arr ! myId) 0 75 | 76 | return (sum partial_sums) 77 | 78 | main :: IO () 79 | main = T.stdTestHarness $ return all_tests 80 | where 81 | all_tests :: Test 82 | all_tests = 83 | T.appendLabels "Reference_Deque" $ 84 | [ T.appendLabel "test_1" test_1 85 | , T.appendLabel "test_2" test_2 86 | , T.appendLabel "direct"$ T.tests_all R.newQ 87 | -- Test going through the class interface as well: 88 | , T.appendLabel "thru_class"$ T.tests_all (C.newQ :: IO (R.SimpleDeque a)) 89 | , T.appendLabel "with_debug"$ T.tests_all (C.newQ :: IO (DebugDeque R.SimpleDeque a)) 90 | 91 | , TestLabel "parfib_specialized" $ TestCase $ T.timeit$ 92 | print =<< test_parfib_work_stealing_specialized T.fibSize 93 | ] 94 | 95 | -- main = do 96 | -- putStrLn "[ Test executable: test reference deque implementation... ]" 97 | -- withArgs ["-j1","--jxml=test-results.xml"] $ 98 | -- defaultMain$ hUnitTestToTests$ 99 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Data/CAS/Internal/Native.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, 2 | TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 3 | 4 | module Data.CAS.Internal.Native 5 | ( CASRef, casIORef, ptrEq, 6 | atomicModifyIORefCAS, atomicModifyIORefCAS_ 7 | ) 8 | where 9 | 10 | import Data.CAS.Internal.Class 11 | import GHC.IO 12 | import GHC.IORef 13 | import GHC.Prim 14 | import GHC.ST 15 | import GHC.STRef 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | newtype CASRef a = CR { unCR :: IORef a } 20 | 21 | instance CASable CASRef a where 22 | newCASable x = newIORef x >>= (return . CR) 23 | readCASable = readIORef . unCR 24 | writeCASable = writeIORef . unCR 25 | cas = casIORef . unCR 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | -- | Performs a machine-level compare and swap operation on an 30 | -- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a 31 | -- swap is performed, along with the 'current' value from the 'STRef'. 32 | -- 33 | -- Note \"compare\" here means pointer equality in the sense of 34 | -- 'GHC.Prim.reallyUnsafePtrEquality#'. 35 | casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current' 36 | -> a -- ^ The 'old' value to compare 37 | -> a -- ^ The 'new' value to replace 'current' if @old == current@ 38 | -> ST s (Bool, a) 39 | casSTRef (STRef var#) old new = ST $ \s1# -> 40 | -- The primop treats the boolean as a sort of error code. 41 | -- Zero means the CAS worked, one that it didn't. 42 | -- We flip that here: 43 | case casMutVar# var# old new s1# of 44 | (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) 45 | 46 | -- | Performs a machine-level compare and swap operation on an 47 | -- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a 48 | -- swap is performed, along with the 'current' value from the 'IORef'. 49 | -- 50 | -- Note \"compare\" here means pointer equality in the sense of 51 | -- 'GHC.Prim.reallyUnsafePtrEquality#'. 52 | casIORef :: IORef a -- ^ The 'IORef' containing a value 'current' 53 | -> a -- ^ The 'old' value to compare 54 | -> a -- ^ The 'new' value to replace 'current' if @old == current@ 55 | -> IO (Bool, a) 56 | casIORef (IORef var) old new = stToIO (casSTRef var old new) 57 | 58 | -- | A drop-in replacement for `atomicModifyIORefCAS` that 59 | -- optimistically attempts to compute the new value and CAS it into 60 | -- place without introducing new thunks or locking anything. Note 61 | -- that this is more STRICT than its standard counterpart and will only 62 | -- place evaluated (WHNF) values in the IORef. 63 | atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b 64 | atomicModifyIORefCAS ref fn = do 65 | -- TODO: Should handle contention in a better way. 66 | init <- readIORef ref 67 | loop init effort 68 | where 69 | effort = 30 :: Int -- TODO: Tune this. 70 | loop old 0 = atomicModifyIORef ref fn 71 | loop old tries = do 72 | (new,result) <- evaluate (fn old) 73 | (b,val) <- casIORef ref old new 74 | if b 75 | then return result 76 | else loop val (tries-1) 77 | 78 | -- | A simpler version that modifies the state but does not return anything. 79 | atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO () 80 | -- atomicModifyIORefCAS_ ref fn = atomicModifyIORefCAS ref (\ x -> (fn x, ())) 81 | -- Can't inline a function with a loop so we duplicate this: 82 | -- 83 | atomicModifyIORefCAS_ ref fn = do 84 | init <- readIORef ref 85 | loop init effort 86 | where 87 | effort = 30 :: Int -- TODO: Tune this. 88 | loop old 0 = atomicModifyIORef_ ref fn 89 | loop old tries = do 90 | new <- evaluate (fn old) 91 | (b,val) <- casIORef ref old new 92 | if b 93 | then return () 94 | else loop val (tries-1) 95 | atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ())) 96 | -- 97 | -------------------------------------------------------------------------------- /atomic-primops/testing/test-atomic-primops.cabal: -------------------------------------------------------------------------------- 1 | 2 | -- Trying a completely separate .cabal for testing. 3 | 4 | Name: test-atomic-primops 5 | Version: 0.6.0.5 6 | Build-type: Simple 7 | Cabal-version: >=1.18 8 | -- This is generally controled by the continuous integration script at a more granular level: 9 | tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 10 | 11 | Flag opt 12 | Description: Enable GHC optimization. 13 | Default: False 14 | 15 | Flag threaded 16 | Description: Enable GHC threaded RTS. 17 | Default: True 18 | 19 | -- The MAIN test suite: 20 | Test-Suite test-atomic-primops 21 | type: exitcode-stdio-1.0 22 | main-is: Test.hs 23 | other-modules: 24 | CommonTesting 25 | Counter 26 | Fetch 27 | Issue28 28 | ghc-options: -rtsopts -main-is Test.main -Wall 29 | 30 | if flag(opt) 31 | ghc-options: -O2 -funbox-strict-fields 32 | if flag(threaded) 33 | ghc-options: -threaded 34 | ghc-options: -rtsopts -with-rtsopts=-N4 35 | 36 | -- Set it to always run with some parallelism. 37 | build-depends: base >= 4.8 && < 5 38 | , ghc-prim 39 | , primitive 40 | , containers 41 | , random 42 | , atomic-primops >= 0.6.0.5 43 | -- For Testing: 44 | , time 45 | , HUnit 46 | , test-framework 47 | , test-framework-hunit 48 | -- Optional: Debugging generated code: 49 | -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint 50 | -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings 51 | default-language: Haskell2010 52 | 53 | -- Cabal can get confused if there is no executable or library... so here's a dummy executable. 54 | -- Also it provides a good test of compile/link issues, apart from everything else. 55 | Executable hello-world-atomic-primops 56 | main-is: hello.hs 57 | build-depends: base >= 4.8 && < 5 58 | , atomic-primops 59 | default-language: Haskell2010 60 | 61 | -- This is separated out, because a bug in GHC 7.6 make this fail on Linux. 62 | Test-suite template-haskell-atomic-primops 63 | type: exitcode-stdio-1.0 64 | main-is: ghci-test.hs 65 | other-modules: TemplateHaskellSplices 66 | Buildable: True 67 | build-depends: base >= 4.8 && < 5 68 | , atomic-primops >= 0.6.0.5 69 | , template-haskell 70 | , test-framework 71 | , test-framework-hunit 72 | default-language: Haskell2010 73 | -- A very simple test of one primop included in GHC 7.8: 74 | Test-suite raw_CAS 75 | type: exitcode-stdio-1.0 76 | build-depends: base >= 4.8 && < 5 77 | , ghc-prim 78 | , atomic-primops >= 0.6.0.5 79 | -- ghc-prim, primitive, containers, random, atomic-primops >= 0.5.0.2, 80 | main-is: Raw781_test.hs 81 | default-language: Haskell2010 82 | 83 | Test-suite Issue28 84 | type: exitcode-stdio-1.0 85 | build-depends: base >= 4.8 && < 5 86 | , ghc-prim 87 | , atomic-primops >= 0.6.0.5 88 | main-is: Issue28.hs 89 | ghc-options: -main-is Issue28.main 90 | default-language: Haskell2010 91 | 92 | Benchmark atomic-primops-MicroBench 93 | type: exitcode-stdio-1.0 94 | build-depends: base >= 4.8 && < 5 95 | , ghc-prim 96 | , primitive 97 | , containers 98 | , random 99 | , atomic-primops >= 0.6.0.5 100 | , deepseq >= 1.3 101 | , time 102 | , HUnit 103 | , test-framework 104 | , test-framework-hunit 105 | , criterion >= 1.2.1 106 | main-is: MicroBench.hs 107 | default-language: Haskell2010 -------------------------------------------------------------------------------- /atomic-primops/cbits/primops.cmm: -------------------------------------------------------------------------------- 1 | 2 | // ============================================================ 3 | // NOTE: We only use this file for GHC < 7.8. 4 | // ============================================================ 5 | 6 | #include "Cmm.h" 7 | 8 | #warning "Duplicating functionality from the GHC RTS..." 9 | #define WHICH_CAS DUP_cas 10 | #define WHICH_SLBARRIER DUP_store_load_barrier 11 | #define WHICH_LLBARRIER DUP_load_load_barrier 12 | #define WHICH_WBARRIER DUP_write_barrier 13 | 14 | // These versions are linked directly from the RTS: 15 | /* #define WHICH_CAS cas */ 16 | /* #define WHICH_SLBARRIER store_load_barrier */ 17 | /* #define WHICH_LLBARRIER load_load_barrier */ 18 | /* #define WHICH_WBARRIER write_barrier */ 19 | 20 | // ================================================================================ 21 | 22 | add1Op 23 | /* Int# -> Int# */ 24 | { 25 | W_ num; 26 | num = R1 + 1; 27 | RET_P(num); 28 | } 29 | 30 | 31 | stg_casArrayzh 32 | /* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */ 33 | { 34 | W_ arr, p, ind, old, new, h, len; 35 | arr = R1; // anything else? 36 | ind = R2; 37 | old = R3; 38 | new = R4; 39 | 40 | p = arr + SIZEOF_StgMutArrPtrs + WDS(ind); 41 | (h) = foreign "C" WHICH_CAS(p, old, new) []; 42 | if (h != old) { 43 | // Failure, return what was there instead of 'old': 44 | RET_NP(1,h); 45 | } else { 46 | // Compare and Swap Succeeded: 47 | SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); 48 | len = StgMutArrPtrs_ptrs(arr); 49 | // The write barrier. We must write a byte into the mark table: 50 | I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1; 51 | RET_NP(0,new); 52 | } 53 | } 54 | 55 | 56 | stg_casByteArrayIntzh 57 | /* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */ 58 | { 59 | W_ arr, p, ind, old, new, h, len; 60 | arr = R1; 61 | ind = R2; 62 | old = R3; 63 | new = R4; 64 | 65 | p = arr + SIZEOF_StgArrWords + WDS(ind); 66 | (h) = foreign "C" WHICH_CAS(p, old, new) []; 67 | 68 | RET_N(h); 69 | } 70 | 71 | stg_fetchAddByteArrayIntzh 72 | /* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */ 73 | { 74 | W_ arr, p, ind, incr, h, len; 75 | arr = R1; 76 | ind = R2; 77 | incr = R3; 78 | 79 | p = arr + SIZEOF_StgArrWords + WDS(ind); 80 | (h) = foreign "C" atomic_inc_with(incr, p) []; 81 | 82 | RET_N(h); 83 | } 84 | 85 | // One difference from casMutVar# is that this version returns the NEW 86 | // pointer in the case of success, NOT the old one. 87 | stg_casMutVar2zh 88 | /* MutVar# s a -> Word# -> a -> State# s -> (# State#, Int#, a #) */ 89 | { 90 | W_ mv, old, new, h, addr; 91 | // Calling convention: Up to 8 registers contain arguments. 92 | mv = R1; 93 | old = R2; 94 | new = R3; 95 | addr = mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var; 96 | 97 | // The "cas" function from the C runtime abstracts over 98 | // platform/architecture differences. It returns the old value. 99 | (h) = foreign "C" WHICH_CAS(addr, old, new) []; 100 | if (h != old) { 101 | // Failure: 102 | RET_NP(1, h); 103 | } 104 | else 105 | { 106 | // Success means a mutation and thus GC write barrier: 107 | if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) { 108 | foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") []; 109 | } 110 | // Return the NEW value as the ticket for next time. 111 | RET_NP(0,new); 112 | } 113 | } 114 | 115 | 116 | // Takes a single input argument in R1: 117 | stg_readMutVar2zh 118 | /* MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, Word#, a #) */ 119 | { 120 | W_ mv, res; 121 | mv = R1; 122 | // Do the actual read: 123 | res = W_[mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var]; 124 | RET_NP(res, res); 125 | } 126 | /* emitPrimOp [res] ReadMutVarOp [mutv] _ */ 127 | /* = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) */ 128 | 129 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Build Status and unit tests 3 | =========================== 4 | 5 | * Jenkins: [![Build Status](http://tester-lin.soic.indiana.edu:8080/buildStatus/icon?job=Haskell-LockFree_primops)](http://tester-lin.soic.indiana.edu:8080/job/Haskell-LockFree_primops/) -- Basic primops only, i.e. `atomic-primops` package: 6 | * Jenkins: [![Build Status](http://tester-lin.soic.indiana.edu:8080/buildStatus/icon?job=Haskell-LockFree_dataStructs)](http://tester-lin.soic.indiana.edu:8080/job/Haskell-LockFree_dataStructs) -- all Queue and Deque data structures in this package. 7 | * Travis: [![Build Status](https://travis-ci.org/rrnewton/haskell-lockfree.svg?branch=master)](https://travis-ci.org/rrnewton/haskell-lockfree) -- combined build&test for all packages in the repo. 8 | 9 | Contents of this Repository 10 | ================================================================================ 11 | 12 | This is a multi-package repository. The following directories 13 | each correspond to exactly one cabal package: 14 | 15 | * [abstract-deque]: AbstractDeque - abstract interface for single and 16 | double ended queues, plus reference implementation in pure Haskell 17 | * [lockefree-queue]: classic Michael & Scott algorithm for single ended queues 18 | * [chaselev-deque]: work-stealing "1.5" ended deques. 19 | * [mega-deque]: a package that picks the best implementation for the 20 | interface constraints, which are expressed at the type level. 21 | * [atomic-primops]: *safe* CAS/FAA (compare-and-swap/fetch-and-add) on various kinds of mutable locations 22 | * [atomic-primops-foreign]: Add on package that provides an FFI based 23 | implementation of counters. 24 | 25 | Please see the .cabal files for more detailed descriptions of each package. 26 | 27 | 28 | How to Test and Install 29 | ================================================================================ 30 | 31 | First, to use compare-and-swap based data structures, you should be 32 | using GHC 7.4.1 or later. Some of these libaries will be forced to 33 | "fake it" on earlier versions of GHC. 34 | 35 | You can install all of the packages in your user's .cabal directory 36 | with the following command: 37 | 38 | ./install_all.sh 39 | 40 | You may also want to build the tests at the same time: 41 | 42 | ./install_all.sh --enable-tests 43 | 44 | There are currently [2012.02.29] some problems with cabal failing to 45 | automatically install dependencies for *tests* (as opposed to 46 | libraries). You may have to manually install some packages via cabal 47 | (e.g. `test-framework-HUnit`). 48 | 49 | If you take a look at that `install_all.sh` script, you'll notice you 50 | can also configure which executables for `cabal` and `ghc` it uses, 51 | for example: 52 | 53 | GHC=ghc-7.4.1 CABAL=cabal-0.10.2 ./install_all.sh --enable-tests 54 | 55 | Next, you can run the tests like this: 56 | 57 | ./MichaelScott/dist/build/test-lockfree-queue/test-lockfree-queue 58 | 59 | That test should complete successfully with a zero exit code. 60 | 61 | Note that if you have trouble building test-suites through cabal, you 62 | can build them manually with GHC using a command like the following: 63 | 64 | cd MichaelScott/ 65 | ghc-7.4.1 -O2 -threaded -rtsopts Test.hs -o Test.exe 66 | 67 | Building with Profiling for debugging: 68 | ---------------------------------------- 69 | 70 | 71 | ghc-7.4.1 -prof -osuf=o_p -O2 -threaded -rtsopts Test.hs -o Test.exe 72 | 73 | You might have to reinstall some of the dependencies with profiling 74 | enabled: 75 | 76 | cabal install -p hostname xml regex-base regex-posix ansi-terminal ansi-wl-pprint test-framework test-framework-hunit --reinstall 77 | 78 | Reinstalling with profiling can be REALLY annoying once the libraries 79 | are already installed. For example, if you forget a dependency above 80 | it will complete most of the compile, giving you the "profiling 81 | version not available" error only later on, resulting in a quadratic 82 | compilation process as you reinstall, add one more dep, reinstall, 83 | repeat. 84 | 85 | 86 | 87 | KNOWN PROBLEMS 88 | ================================================================================ 89 | 90 | TODO 91 | ---------------------------------------- 92 | 93 | * It would be nice to add a binding to TBB concurrent queues or other 94 | foreign implementations (for storable types). 95 | 96 | * Test on windows. (It hasn't been tried.) 97 | -------------------------------------------------------------------------------- /abstract-deque/Data/Concurrent/Deque/Reference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, CPP, BangPatterns #-} 2 | 3 | {-| 4 | A strawman implementation of concurrent Dequeues. This 5 | implementation is so simple that it also makes a good reference 6 | implementation for debugging. 7 | 8 | The queue representation is simply an IORef containing a Data.Sequence. 9 | 10 | Also see "Data.Concurrent.Deque.Reference.DequeInstance". 11 | By convention a module of this name is also provided. 12 | 13 | -} 14 | 15 | module Data.Concurrent.Deque.Reference 16 | (SimpleDeque(..), 17 | newQ, nullQ, newBoundedQ, pushL, pushR, tryPopR, tryPopL, tryPushL, tryPushR, 18 | 19 | _is_using_CAS -- Internal 20 | ) 21 | where 22 | 23 | import Prelude hiding (length) 24 | import qualified Data.Concurrent.Deque.Class as C 25 | import Data.Sequence 26 | import Data.IORef 27 | 28 | #ifdef USE_CAS 29 | #warning "abstract-deque: reference implementation using CAS..." 30 | import Data.Atomics (atomicModifyIORefCAS) 31 | -- Toggle these and compare performance: 32 | modify = atomicModifyIORefCAS 33 | _is_using_CAS = True 34 | #else 35 | modify = atomicModifyIORef 36 | _is_using_CAS = False 37 | #endif 38 | 39 | {-# INLINE modify #-} 40 | modify :: IORef a -> (a -> (a, b)) -> IO b 41 | _is_using_CAS :: Bool 42 | 43 | 44 | -- | Stores a size bound (if any) as well as a mutable Seq. 45 | data SimpleDeque elt = DQ {-# UNPACK #-} !Int !(IORef (Seq elt)) 46 | 47 | 48 | newQ :: IO (SimpleDeque elt) 49 | newQ = do r <- newIORef empty 50 | return $! DQ 0 r 51 | 52 | newBoundedQ :: Int -> IO (SimpleDeque elt) 53 | newBoundedQ lim = 54 | do r <- newIORef empty 55 | return $! DQ lim r 56 | 57 | pushL :: SimpleDeque t -> t -> IO () 58 | pushL (DQ 0 qr) !x = do 59 | () <- modify qr addleft 60 | return () 61 | where 62 | -- Here we are very strict to avoid stack leaks. 63 | addleft !s = extended `seq` pair 64 | where extended = x <| s 65 | pair = (extended, ()) 66 | pushL (DQ n _) _ = error$ "should not call pushL on Deque with size bound "++ show n 67 | 68 | tryPopR :: SimpleDeque a -> IO (Maybe a) 69 | tryPopR (DQ _ qr) = modify qr $ \ s -> 70 | case viewr s of 71 | EmptyR -> (empty, Nothing) 72 | s' :> x -> (s', Just x) 73 | 74 | nullQ :: SimpleDeque elt -> IO Bool 75 | nullQ (DQ _ qr) = 76 | do s <- readIORef qr 77 | case viewr s of 78 | EmptyR -> return True 79 | _ :> _ -> return False 80 | 81 | -- -- This simplistic version simply spins: 82 | -- popR q = do x <- tryPopR q 83 | -- case x of 84 | -- Nothing -> popR q 85 | -- Just x -> return x 86 | 87 | -- popL q = do x <- tryPopL q 88 | -- case x of 89 | -- Nothing -> popL q 90 | -- Just x -> return x 91 | 92 | tryPopL :: SimpleDeque a -> IO (Maybe a) 93 | tryPopL (DQ _ qr) = modify qr $ \s -> 94 | case viewl s of 95 | EmptyL -> (empty, Nothing) 96 | x :< s' -> (s', Just x) 97 | 98 | pushR :: SimpleDeque t -> t -> IO () 99 | pushR (DQ 0 qr) x = modify qr (\s -> (s |> x, ())) 100 | pushR (DQ n _) _ = error$ "should not call pushR on Deque with size bound "++ show n 101 | 102 | tryPushL :: SimpleDeque a -> a -> IO Bool 103 | tryPushL q@(DQ 0 _) v = pushL q v >> return True 104 | tryPushL (DQ lim qr) v = 105 | modify qr $ \s -> 106 | if length s == lim 107 | then (s, False) 108 | else (v <| s, True) 109 | 110 | tryPushR :: SimpleDeque a -> a -> IO Bool 111 | tryPushR q@(DQ 0 _) v = pushR q v >> return True 112 | tryPushR (DQ lim qr) v = 113 | modify qr $ \s -> 114 | if length s == lim 115 | then (s, False) 116 | else (s |> v, True) 117 | 118 | -------------------------------------------------------------------------------- 119 | -- Instances 120 | -------------------------------------------------------------------------------- 121 | 122 | instance C.DequeClass SimpleDeque where 123 | newQ = newQ 124 | nullQ = nullQ 125 | pushL = pushL 126 | tryPopR = tryPopR 127 | leftThreadSafe _ = True 128 | rightThreadSafe _ = True 129 | instance C.PopL SimpleDeque where 130 | tryPopL = tryPopL 131 | instance C.PushR SimpleDeque where 132 | pushR = pushR 133 | 134 | instance C.BoundedL SimpleDeque where 135 | tryPushL = tryPushL 136 | newBoundedQ = newBoundedQ 137 | 138 | instance C.BoundedR SimpleDeque where 139 | tryPushR = tryPushR 140 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/README.md: -------------------------------------------------------------------------------- 1 | See haddock in Data.CAS 2 | 3 | 4 | A few notes on performance results 5 | ================================== 6 | 7 | 8 | [2011.11.12] Initial Measurements 9 | --------------------------------- 10 | 11 | An initial round of tests gives the following results when executing 12 | 100K CAS's from each of four threads on a 3.33GHz Nehalem desktop: 13 | 14 | RAW Haskell CAS: 0.143s 25% productivity 58MB alloc, 204,693 successes 15 | 'Fake' CAS: 0.9s - 1.42s 89% productivity, 132M alloc, 104,044 successes 16 | Foreign CAS: 1.6s 23% productivity, 82M alloc, 264,821 successes 17 | 18 | "Successes" counts the total number of CAS operations that actually 19 | succeeded. 20 | 21 | This microbenchmark is spending a lot of its time in Gen 0 garbage collection. 22 | 23 | Next, a million CAS's per thread: 24 | 25 | RAW Haskell CAS: 0.65 - 1.0 20% productivity 406MB alloc (can stack overflow) 26 | 'Fake' CAS: 14.3 - 17s 270% CPU 92% productivity 1.3GB alloc 1,008,468 successes 27 | Foreign CAS: Stack overflow after 28.5s ... 300-390% CPU, 15% productivity, 28 | 29 | After bumping the stack size up it takes a long 30 | time to finish, even after it has printed the 31 | sample success bit vectors. 32 | 33 | With -K100M: 34 | 78s 6% productivity, 898M alloc, 3,324,943 successes 35 | 67 seconds elapsed in Gen 0 GC!! 36 | 37 | Something odd is going on here. How could it spend so long in GC 38 | for so little allocation?? For only two threads the Foreign 39 | implementation drops to 22s, but still 17.97s elapsed in Gen 0 GC. 40 | 41 | What about the Raw haskell CAS? It also wil stack overflow with the 42 | current version of the test. With a 1G stack it can do 5Mx4 CAS's 43 | (8,9M successful) in 6.7 seconds. 10M in 17s. And STILL not seeing 44 | the previous segfault with the Raw CAS version... 45 | 46 | [2011.11.12] Simple Stack Overflow Fix 47 | -------------------------------------- 48 | 49 | After making sure that all the (+1)'s in the test are strict, the 50 | stack overflow goes away and the numbers change (Raw does 5M in 3.3s 51 | instead of 6.7s). BUT there's still quite a lot of time spent in 52 | GC. Here's 1Mx4 CAS's again: 53 | 54 | RAW Haskell CAS: 0.7s (23% prod, 0.8s total Gen 0 GC) 55 | 'Fake' CAS: 11.8s (91% prod, 0.8s total Gen 0 GC) 56 | Foreign CAS: 52s (6% prod) 57 | 58 | And then adding -A1M makes a neglible change in runtime for Raw, but 59 | reduces the # of gen0 collections from 484 to 235. 60 | 61 | Ok, how about testing on a 3.1GHz Westmere. 62 | Wow, just ran into this: 63 | 64 | cc1: internal compiler error: Segmentation fault 65 | Please submit a full bug report, 66 | with preprocessed source if appropriate. 67 | See for instructions. 68 | make: *** [all] Error 1 69 | 70 | On a different machine it worked (default runtime flags 1Mx4 CAS): 71 | 72 | RAW Haskell CAS: 0.7s 73 | 'Fake' CAS: 8.1s 74 | Foreign CAS: 46s 75 | 76 | The lack of hyperthreading may also be helping. 77 | 78 | : 79 | The primary source of allocation in this example is the accumulation 80 | of the [Bool] lists of success and failure. I should disable those 81 | and test again. 82 | 83 | 84 | [2011.11.13] Testing specialized CAS.Foreign instance 85 | ----------------------------------------------------- 86 | 87 | All of the above results were for a cell containing an Int. That 88 | would not have triggered the specialized (Storable-based) instance in 89 | Foreign.hs. There SHOULD be special cases for all word-sized scalars, 90 | but currently there's just one for Word32. Let's test that one. 91 | 92 | Word32 1Mx4 CAS's: 93 | RAW Haskell CAS: 0.57s (13.7% prod) 94 | Foreign CAS: 0.64s (15% prod) 95 | 96 | Wow, the foreign one is doing as well as the Haskell one even though 97 | there's some extra silliness in the Foreign.CASRef type (causing a 98 | runtime case dispatch to unpack). 99 | 100 | 101 | [2011.11.13] Testing atomicModify based on CAS 102 | ---------------------------------------------- 103 | 104 | An atomicModify based on CAS offers a drop-in replacement that could 105 | improve performance. I implemented one which will try CAS until it 106 | fails a certain number of times ("30" for now, but needs to be tuned). 107 | 108 | These seem to work well. They are cheaper than you would think given 109 | how long it takes to get successful CAS attempts under contention: 110 | 111 | 1Mx4 CAS attempts or atomicModifies: 112 | 0.19s -- CAS attempts 1.07M successful. 113 | 0.02s -- 1M atomicModifyIORefCAS on 1 thread 114 | 0.13s -- 1Mx2 atomicModifyIORefCAS on 2 threads 115 | 0.37s -- 1Mx4 atomicModifyIORefCAS on 4 threads 116 | 117 | And they are cheaper than the real atomicModifyIORef (which also seems 118 | to have a stack space problem right now because of its laziness). But 119 | with a huge stack (1G) it will succeed: 120 | 121 | 1.27s -- 1Mx4 atomicModifyIORef 122 | 123 | But inserting extra strictness (an evaluate call) to avoid the 124 | stack-leak actually makes it slower: 125 | 126 | 2.08s -- 1Mx4 atomicModifyIORef, stricter 127 | 128 | -------------------------------------------------------------------------------- /vector-atomics/Data/Vector/Unboxed/Atomic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE CPP #-} 6 | 7 | module Data.Vector.Unboxed.Atomic 8 | where 9 | 10 | import Foreign.Storable (Storable, sizeOf) 11 | import Data.Int 12 | import Data.Word 13 | import qualified Data.Vector.Primitive as P 14 | -- The specific MV_* constructors that we need are here: 15 | import Data.Vector.Unboxed.Base 16 | import Data.Primitive (MutableByteArray) 17 | 18 | import Data.Atomics (Ticket) 19 | 20 | import qualified Data.Vector.Storable.Mutable as SM 21 | import qualified Data.Bits.Atomic as BA 22 | import Foreign.ForeignPtr (newForeignPtr, withForeignPtr) 23 | import qualified Foreign.Ptr as P 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | -- | Vector types which are implemented as single MutableByteArray, and whose 28 | -- elements are of an appropriate size to perform atomic memory operations on them. 29 | class IsOneMBV v a where 30 | getMutableByteArray :: v s a -> MutableByteArray s 31 | bitSize :: v s a -> Int 32 | 33 | default bitSize :: (IsOneMBV v a, Storable a) => v s a -> Int 34 | bitSize _ = sizeOf (undefined::a) * 8 35 | 36 | {- 37 | bitSize :: a -> Int 38 | default bitSize :: (Storable a) => a -> Int 39 | bitSize _ = sizeOf (undefined::a) * 8 40 | 41 | Huh, this ^^ attempt exposes some of the post-desugaring magic: 42 | 43 | Possible fix: add an instance declaration for (IsOneMBV v0 Int) 44 | In the expression: (Data.Vector.Unboxed.Atomic.$gdmbitSize) 45 | In an equation for `bitSize': 46 | bitSize = (Data.Vector.Unboxed.Atomic.$gdmbitSize) 47 | 48 | -} 49 | 50 | 51 | instance IsOneMBV MVector Int where getMutableByteArray (MV_Int (P.MVector _ _ a)) = a 52 | instance IsOneMBV MVector Int8 where getMutableByteArray (MV_Int8 (P.MVector _ _ a)) = a 53 | instance IsOneMBV MVector Int16 where getMutableByteArray (MV_Int16 (P.MVector _ _ a)) = a 54 | instance IsOneMBV MVector Int32 where getMutableByteArray (MV_Int32 (P.MVector _ _ a)) = a 55 | instance IsOneMBV MVector Int64 where getMutableByteArray (MV_Int64 (P.MVector _ _ a)) = a 56 | 57 | instance IsOneMBV MVector Word where getMutableByteArray (MV_Word (P.MVector _ _ a)) = a 58 | instance IsOneMBV MVector Word8 where getMutableByteArray (MV_Word8 (P.MVector _ _ a)) = a 59 | instance IsOneMBV MVector Word16 where getMutableByteArray (MV_Word16 (P.MVector _ _ a)) = a 60 | instance IsOneMBV MVector Word32 where getMutableByteArray (MV_Word32 (P.MVector _ _ a)) = a 61 | instance IsOneMBV MVector Word64 where getMutableByteArray (MV_Word64 (P.MVector _ _ a)) = a 62 | 63 | instance IsOneMBV MVector Bool where getMutableByteArray (MV_Bool (P.MVector _ _ a)) = a 64 | instance IsOneMBV MVector Char where getMutableByteArray (MV_Char (P.MVector _ _ a)) = a 65 | instance IsOneMBV MVector Double where getMutableByteArray (MV_Double (P.MVector _ _ a)) = a 66 | instance IsOneMBV MVector Float where getMutableByteArray (MV_Float (P.MVector _ _ a)) = a 67 | 68 | -------------------------------------------------------------------------------- 69 | 70 | -- | A class for vectors whose contents are unboxed numbers, not Haskell heap objects. 71 | class AtomicUVec v a where 72 | fetchAndAdd :: v s a -> Int -> a -> IO a 73 | fetchAndSub :: v s a -> Int -> a -> IO a 74 | fetchAndOr :: v s a -> Int -> a -> IO a 75 | fetchAndAnd :: v s a -> Int -> a -> IO a 76 | fetchAndXor :: v s a -> Int -> a -> IO a 77 | fetchAndNand :: v s a -> Int -> a -> IO a 78 | addAndFetch :: v s a -> Int -> a -> IO a 79 | subAndFetch :: v s a -> Int -> a -> IO a 80 | orAndFetch :: v s a -> Int -> a -> IO a 81 | andAndFetch :: v s a -> Int -> a -> IO a 82 | xorAndFetch :: v s a -> Int -> a -> IO a 83 | nandAndFetch :: v s a -> Int -> a -> IO a 84 | -- lockTestAndSet :: v s a -> Int -> IO a 85 | -- lockRelease :: v s a -> Int -> IO () 86 | 87 | compareAndSwap :: v s a -> Int -> a -> a -> IO (Maybe a) 88 | 89 | -- | Atomic operations on /boxed/ vectors containing arbitrary Haskell values. 90 | class AtomicVec v a where 91 | compareAndSwapT :: v s a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) 92 | 93 | -- 94 | -- 95 | 96 | boundsCheck :: (Num a, Ord a) => String -> a -> a -> t -> t 97 | boundsCheck name ix len x 98 | | ix >= 0 && ix < len = x 99 | | otherwise = error $ name ++": index out of bounds " 100 | 101 | -- FIXME: BOUNDS CHECK: 102 | 103 | #define DOOP(name) \ 104 | name (SM.MVector len fp) ix val = \ 105 | withForeignPtr fp (\ptr -> \ 106 | let offset = sizeOf (undefined::elt) * ix in \ 107 | boundsCheck "atomic vector op" ix len \ 108 | (BA.name (P.plusPtr ptr offset) val )) 109 | 110 | instance (Storable elt, BA.AtomicBits elt) => 111 | AtomicUVec SM.MVector elt where 112 | DOOP(fetchAndAdd) 113 | DOOP(fetchAndSub) 114 | DOOP(fetchAndOr) 115 | DOOP(fetchAndAnd) 116 | DOOP(fetchAndXor) 117 | DOOP(fetchAndNand) 118 | DOOP(addAndFetch) 119 | DOOP(subAndFetch) 120 | DOOP(orAndFetch) 121 | DOOP(andAndFetch) 122 | DOOP(xorAndFetch) 123 | DOOP(nandAndFetch) 124 | 125 | compareAndSwap (SM.MVector _len fp) ix old new = 126 | withForeignPtr fp $ \ptr -> do 127 | let offset = sizeOf (undefined::elt) * ix 128 | old' <- BA.compareAndSwap (P.plusPtr ptr offset) old new 129 | return $! if old' == old 130 | then Nothing 131 | else Just old' 132 | 133 | -- compareAndSwapT arr ix tick new = 134 | -- error "FINISHME - compareAndSwapT " 135 | 136 | -- instance AtomicUVec SM.MVector Int where 137 | -------------------------------------------------------------------------------- /atomic-primops/Data/Atomics/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, CPP #-} 2 | -- | Integer counters providing thread-safe, lock-free mutation functions. 3 | -- 4 | -- Atomic counters are represented by a single memory location, such that 5 | -- built-in processor instructions are sufficient to perform fetch-and-add or 6 | -- compare-and-swap. 7 | -- 8 | -- Remember, contention on such counters should still be minimized! 9 | 10 | module Data.Atomics.Counter 11 | -- Reexport to get all the docs. 12 | ( 13 | -- * Type of counters of counters and tickets 14 | AtomicCounter, 15 | 16 | -- * Creating counters 17 | newCounter, 18 | 19 | -- * Tickets, used for compare-and-swap 20 | -- | See the documentation for "Data.Atomics" for more explanation of the 21 | -- ticket abstraction. The same ideas apply here for counters as for 22 | -- general mutable locations (IORefs). 23 | CTicket, peekCTicket, 24 | 25 | -- * Atomic memory operations 26 | casCounter, incrCounter, incrCounter_, 27 | 28 | -- * Non-atomic operations 29 | readCounter, readCounterForCAS, 30 | writeCounter 31 | ) 32 | where 33 | 34 | 35 | import Data.Atomics.Internal 36 | import GHC.Base hiding ((==#)) 37 | import qualified GHC.PrimopWrappers as GPW 38 | 39 | 40 | -- GHC 7.8 changed some primops 41 | (==#) :: Int# -> Int# -> Bool 42 | (==#) x y = case x GPW.==# y of { 0# -> False; _ -> True } 43 | 44 | 45 | 46 | #ifndef __GLASGOW_HASKELL__ 47 | #error "Counter: this library is not portable to other Haskell's" 48 | #endif 49 | 50 | #include "MachDeps.h" 51 | #ifndef SIZEOF_HSINT 52 | #define SIZEOF_HSINT INT_SIZE_IN_BYTES 53 | #endif 54 | 55 | -- | The type of mutable atomic counters. 56 | data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld) 57 | 58 | -- | You should not depend on this type. It varies between different implementations 59 | -- of atomic counters. 60 | type CTicket = Int 61 | -- TODO: Could newtype this. 62 | 63 | -- | Create a new counter initialized to the given value. 64 | {-# INLINE newCounter #-} 65 | newCounter :: Int -> IO AtomicCounter 66 | newCounter n = do 67 | c <- newRawCounter 68 | writeCounter c n -- Non-atomic is ok; it hasn't been released into the wild. 69 | return c 70 | 71 | -- | Create a new, uninitialized counter. 72 | {-# INLINE newRawCounter #-} 73 | newRawCounter :: IO AtomicCounter 74 | newRawCounter = IO $ \s -> 75 | case newByteArray# size s of { (# s', arr #) -> 76 | (# s', AtomicCounter arr #) } 77 | where !(I# size) = SIZEOF_HSINT 78 | 79 | {-# INLINE readCounter #-} 80 | -- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. 81 | readCounter :: AtomicCounter -> IO Int 82 | readCounter (AtomicCounter arr) = IO $ \s -> 83 | case readIntArray# arr 0# s of { (# s', i #) -> 84 | (# s', I# i #) } 85 | 86 | {-# INLINE writeCounter #-} 87 | -- | Make a non-atomic write to the counter. No memory-barrier. 88 | writeCounter :: AtomicCounter -> Int -> IO () 89 | writeCounter (AtomicCounter arr) (I# i) = IO $ \s -> 90 | case writeIntArray# arr 0# i s of { s' -> 91 | (# s', () #) } 92 | 93 | {-# INLINE readCounterForCAS #-} 94 | -- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque 95 | -- ticket that can be used in CAS operations. Except for the difference in return 96 | -- type, the semantics of this are the same as `readCounter`. 97 | readCounterForCAS :: AtomicCounter -> IO CTicket 98 | readCounterForCAS = readCounter 99 | 100 | {-# INLINE peekCTicket #-} 101 | -- | Opaque tickets cannot be constructed, but they can be destructed into values. 102 | peekCTicket :: CTicket -> Int 103 | peekCTicket !x = x 104 | 105 | {-# INLINE casCounter #-} 106 | -- | Compare and swap for the counter ADT. Similar behavior to 107 | -- `Data.Atomics.casIORef`, in particular, in both success and failure cases it 108 | -- returns a ticket that you should use for the next attempt. (That is, in the 109 | -- success case, it actually returns the new value that you provided as input, but in 110 | -- ticket form.) 111 | casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) 112 | -- casCounter (AtomicCounter barr) !old !new = 113 | casCounter (AtomicCounter mba#) (I# old#) newBox@(I# new#) = IO$ \s1# -> 114 | let (# s2#, res# #) = casIntArray# mba# 0# old# new# s1# in 115 | case res# ==# old# of 116 | False -> (# s2#, (False, I# res# ) #) -- Failure 117 | True -> (# s2#, (True , newBox ) #) -- Success 118 | 119 | -- {-# INLINE sameCTicket #-} 120 | -- sameCTicket :: CTicket -> CTicket -> Bool 121 | -- sameCTicket = (==) 122 | 123 | {-# INLINE incrCounter #-} 124 | -- | Increment the counter by a given amount. Returns the value AFTER the increment 125 | -- (in contrast with the behavior of the underlying instruction on architectures 126 | -- like x86.) 127 | -- 128 | -- Note that UNLIKE with boxed implementations of counters, where increment is 129 | -- based on CAS, this increment is /O(1)/. Fetch-and-add does not require a retry 130 | -- loop like CAS. 131 | incrCounter :: Int -> AtomicCounter -> IO Int 132 | incrCounter (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> 133 | let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in 134 | (# s2#, (I# (res +# incr#)) #) 135 | 136 | {-# INLINE incrCounter_ #-} 137 | -- | An alternate version for when you don't care about the old value. 138 | incrCounter_ :: Int -> AtomicCounter -> IO () 139 | incrCounter_ (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> 140 | let (# s2#, _ #) = fetchAddIntArray# mba# 0# incr# s1# in 141 | (# s2#, () #) 142 | -------------------------------------------------------------------------------- /atomic-primops/testing/CounterCommon.hs: -------------------------------------------------------------------------------- 1 | -- Common tests to the different counter implementations. N.B. #included from 2 | -- other projects via soft links! 3 | 4 | import Control.Monad 5 | import GHC.Conc 6 | import Test.Framework.Providers.HUnit (testCase) 7 | import Test.Framework(Test) 8 | import Test.HUnit (assertEqual) 9 | 10 | import CommonTesting (numElems, forkJoin, timeit, nTimes) 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Test the basics 14 | 15 | case_basic1 :: IO () 16 | case_basic1 = do 17 | r <- C.newCounter 0 18 | ret <- C.incrCounter 10 r 19 | assertEqual "incrCounter returns the NEW value" 10 ret 20 | 21 | case_basic2 :: IO () 22 | case_basic2 = do 23 | r <- C.newCounter 0 24 | t <- C.readCounterForCAS r 25 | (True,newt) <- C.casCounter r t 10 26 | assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt) 27 | 28 | case_basic3 :: IO () 29 | case_basic3 = do 30 | r <- C.newCounter 0 31 | t <- C.readCounterForCAS r 32 | _ <- C.incrCounter 1 r 33 | (False,oldt) <- C.casCounter r t 10 34 | assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt) 35 | 36 | case_basic4 :: IO () 37 | case_basic4 = do 38 | let tries = numElems `quot` 100 39 | r <- C.newCounter 0 40 | nTimes tries $ do 41 | t <- C.readCounterForCAS r 42 | (True,_) <- C.casCounter r t (C.peekCTicket t + 1) 43 | return () 44 | cnt <- C.readCounter r 45 | assertEqual "Every CAS should succeed on one thread" tries cnt 46 | 47 | -------------------------------------------------------------------------------- 48 | -- Repeated increments 49 | 50 | incrloop :: Int -> IO Int 51 | incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r 52 | C.readCounter r 53 | 54 | case_incrloop :: IO () 55 | case_incrloop = do 56 | cnt <- incrloop default_seq_tries 57 | assertEqual "incrloop sum" default_seq_tries cnt 58 | 59 | -- | Here we do a loop to test the unboxing of results from incrCounter: 60 | -- As of now [2013.07.19], it is successfully unboxing the results 61 | -- for Data.Atomics.Counter.Unboxed. 62 | incrloop4B :: Int -> IO () 63 | incrloop4B tries = do 64 | putStrLn " [incrloop4B] A test where we use the result of each incr." 65 | r <- C.newCounter 1 66 | loop r tries 1 67 | where 68 | loop :: C.AtomicCounter -> Int -> Int -> IO () 69 | loop r 0 _ = do v <- C.readCounter r 70 | putStrLn$"Final value: "++show v 71 | return () 72 | loop r i l = do 73 | n <- C.incrCounter l r 74 | if n == 2 75 | then loop r (i-1) 2 76 | else loop r (i-1) 1 77 | 78 | -- | Here we let the counter overflow, which seems to be causing problems. 79 | -- NOTE 2/3/2015: THIS APPEARS TO BE WORKING NOW -Brandon 80 | overflowTest :: Int -> IO () 81 | overflowTest tries = do 82 | putStrLn " [incrloop4B] A test where we use the result of each incr." 83 | r <- C.newCounter 1 84 | loop r tries 1 85 | where 86 | loop :: C.AtomicCounter -> Int -> Int -> IO () 87 | loop r 0 _ = do v <- C.readCounter r 88 | putStrLn$"Final value: "++show v 89 | return () 90 | loop r i l = do 91 | --putStrLn$ " [incrloop4B] Looping with tries left "++show i 92 | n <- C.incrCounter l r 93 | -- This is HANGING afer passing 2,147,483,648. (using Unboxed) 94 | -- Is there some defect wrt overflow? 95 | --putStrLn$ " [incrloop4B] Done incr, received "++show n 96 | loop r (i-1) n 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Parallel repeated increments 100 | 101 | 102 | {-# INLINE parIncrloop #-} 103 | parIncrloop :: (Int -> IO C.AtomicCounter) 104 | -> (Int -> C.AtomicCounter -> IO Int) -> Int -> IO Int 105 | parIncrloop new incr iters = do 106 | numcap <- getNumCapabilities 107 | let (each,left) = iters `quotRem` numcap 108 | putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each 109 | r <- new 0 110 | void $ forkJoin numcap $ \ ix -> do 111 | let mine = if ix==0 then each+left else each 112 | nTimes mine $ void $ incr 1 r 113 | C.readCounter r 114 | 115 | case_parincrloop :: IO () 116 | case_parincrloop = do 117 | cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries 118 | assertEqual "incrloop sum" default_conc_tries cnt 119 | 120 | -- | Use CAS instead of the real incr so we can compare the overhead. 121 | case_parincrloop_wCAS :: IO () 122 | case_parincrloop_wCAS = do 123 | cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries 124 | assertEqual "incrloop sum" default_conc_tries cnt 125 | where 126 | fakeIncr delt r = do tick <- C.readCounterForCAS r 127 | loop r delt tick 128 | loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt) 129 | case x of 130 | (True, newtick) -> return (C.peekCTicket newtick) 131 | (False,newtick) -> loop r delt newtick 132 | 133 | 134 | -------------------------------------------------------------------------------- 135 | 136 | tests :: [Test] 137 | tests = 138 | [ 139 | testCase (name++"_basic1_incrCounter") $ case_basic1 140 | , testCase (name++"_basic2_casCounter") $ case_basic2 141 | , testCase (name++"_basic3_casCounter") $ case_basic3 142 | , testCase (name++"_basic4_casCounter") $ case_basic4 143 | ---------------------------------------- 144 | , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop 145 | , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries) 146 | , testCase (name++"_overflow_test") $ timeit (overflowTest 100000) 147 | ---------------------------------------- 148 | 149 | -- Parallel versions: 150 | , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop 151 | , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS 152 | ] 153 | -------------------------------------------------------------------------------- /Obsolete_Deprecated/IORefCAS/Data/CAS/Internal/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, UndecidableInstances, MagicHash, 2 | TypeFamilies, MultiParamTypeClasses, OverlappingInstances, 3 | BangPatterns, CPP #-} 4 | 5 | 6 | 7 | -- | This is a version of CAS that works outside of Haskell by using 8 | -- the FFI (and the GCC intrinsics-based 'Data.Bits.Atomic'.) 9 | 10 | module Data.CAS.Internal.Foreign 11 | ( 12 | CASRef 13 | -- Plus instance... 14 | ) 15 | where 16 | 17 | import Control.Monad 18 | import Data.Bits.Atomic 19 | import Data.IORef 20 | import Data.Word 21 | import Foreign.Storable 22 | import Foreign.Ptr 23 | import Foreign.ForeignPtr 24 | import Foreign.StablePtr 25 | import Foreign.Marshal.Alloc (malloc) 26 | import qualified Foreign.Concurrent as FC 27 | import Text.Printf 28 | import Unsafe.Coerce 29 | 30 | import Data.CAS.Internal.Class 31 | 32 | -- Convenient overlapping instances of CASable are possible at the at 33 | -- the cost of a runtime dispatch on CASRef representations. (Compile 34 | -- time dispatch is not possible due to impossibility of overlapping 35 | -- instances with associated type families.) 36 | data CASRef a = 37 | Frgn (Ptr a) 38 | | Hskl (ForeignPtr (StablePtr a)) 39 | 40 | -------------------------------------------------------------------------------- 41 | #if 1 42 | -- | EXAMPLE SPECIALIZATION: a more efficient implementation for simple scalars. 43 | -- 44 | -- Boilerplate TODO: We Should have one of these for all word-sized Scalar types. 45 | -- 46 | instance CASable CASRef Word32 where 47 | -- -- We would LIKE to do this for everything in the Storable class: 48 | -- instance (Storable a, AtomicBits a) => CASable a where 49 | -- 50 | -- newtype CASRef a = Frgn (Ptr a) 51 | -- newtype CASRef Word32 = Frgn (Ptr Word32) 52 | newCASable val = do 53 | ptr <- malloc 54 | poke ptr val 55 | return (Frgn ptr) 56 | 57 | writeCASable (Frgn ptr) val = poke ptr val 58 | 59 | readCASable (Frgn ptr) = peek ptr 60 | 61 | {-# NOINLINE cas #-} 62 | cas (Frgn ptr) old new = do 63 | # if 1 64 | -- I'm having problems with this version. The ptrEq will report False even when the swap succeeds. 65 | -- I think the FFI unmarshalling the result ends up creating an extra copy. 66 | -- orig <- compareAndSwap ptr old new 67 | -- printf "Completed swaps orig %d (%d) and old %d (%d)\n" orig (unsafeName orig) old (unsafeName old) 68 | -- return (ptrEq orig old, orig) 69 | 70 | -- BUT, since it's a Word32 it is ok NOT to use pointer equality here. 71 | orig <- compareAndSwap ptr old new 72 | return (orig == old, orig) 73 | 74 | # else 75 | -- ERROR: Trying this incorrect HACK version for a moment: 76 | -- This version will allow a return value of (False,old) 77 | snap <- peek ptr 78 | b <- compareAndSwapBool ptr old new 79 | if b 80 | then return (True, old) 81 | else return (False, snap) 82 | # endif 83 | 84 | #endif 85 | 86 | -------------------------------------------------------------------------------- 87 | #if 0 88 | -- | INEFFICIENT but safe implementation for arbitrary Haskell values. 89 | -- This version uses StablePtr's to store Haskell values in foreign storage. 90 | -- 91 | -- This should NOT be useful for implementing efficient data 92 | -- structures because it itself depends on concurrent access to 93 | -- the GHC runtimes table of pinned StablePtr values. 94 | instance CASable CASRef a where 95 | -- newtype CASRef a = Hskl (StablePtr a) 96 | 97 | newCASable val = do 98 | -- Here we create a storage cell outside the Haskel heap which in 99 | -- turn contains a pointer back into the Haskell heap. 100 | p <- newStablePtr val 101 | -- mem <- malloc 102 | -- poke mem p 103 | -- fp <- FC.newForeignPtr (castPtr$ castStablePtrToPtr p) (freeStablePtr p) 104 | 105 | -- Here we assume that when we let go of the reference that we 106 | -- free whatever StablePtr is contained in it at the time. 107 | -- fp <- FC.newForeignPtr mem $ 108 | -- There should be no races for this finalizer because all 109 | -- Haskell threads have let go of the foreign pointer: 110 | -- do curp <- withForeignPtr fp peek 111 | -- freeStablePtr curp 112 | fp <- mallocForeignPtr 113 | withForeignPtr fp (`poke` p) 114 | FC.addForeignPtrFinalizer fp $ 115 | do putStrLn$ "EXPECTATION INVALIDATED: CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!" 116 | -- Todo... weak pointer here. 117 | curp <- withForeignPtr fp peek 118 | freeStablePtr curp 119 | 120 | return (Hskl fp) 121 | 122 | readCASable (Hskl ptr) = withForeignPtr ptr (\p -> peek p >>= deRefStablePtr) 123 | 124 | -- We must use CAS for ALL writes to ensure that we issue 125 | -- freeStablePtr for every value that gets bumped out of the foreign 126 | -- storage cell. 127 | writeCASable c val = readCASable c >>= loop 128 | where 129 | -- Hard spin: TODO add some contention back-off. 130 | loop x = do (b,v) <- cas c x val 131 | unless b (loop v) 132 | 133 | cas c@(Hskl ptr) old new = withForeignPtr ptr $ \ rawP -> 134 | -- TODO: if we add an AtomicBits instance for StablePtr we can avoid these unsafe coercions 135 | do 136 | osp <- newStablePtr old 137 | nsp <- newStablePtr new 138 | let oldRawPtr = unsafeCoerce osp :: Word 139 | castP = castPtr rawP :: Ptr Word 140 | orig <- compareAndSwap castP oldRawPtr (unsafeCoerce nsp) 141 | let fired = orig == oldRawPtr 142 | -- Restore the value we got back to its real type: 143 | orig' = if True then unsafeCoerce orig else osp 144 | 145 | -- FIXME There's a problem here. What if we put the same 146 | -- object in multiple CASRef's? newStablePtr seems to return 147 | -- the same thing if called multiple times. 148 | 149 | orig'' <- deRefStablePtr orig' 150 | when fired $ freeStablePtr orig' 151 | return (fired, orig'') 152 | 153 | #endif 154 | 155 | 156 | ---------------------------------------------------------------------------------------------------- 157 | -- Helpers: 158 | -------------------------------------------------------------------------------- /atomic-primops/testing/CommonTesting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-} 2 | 3 | -- Various utilities used during testing. 4 | 5 | module CommonTesting where 6 | 7 | import Control.Monad 8 | import Control.Concurrent.MVar 9 | import GHC.Conc 10 | import Data.Time.Clock 11 | import Text.Printf 12 | import GHC.IO (unsafePerformIO) 13 | import System.CPUTime 14 | import System.Mem.StableName (makeStableName, hashStableName) 15 | import System.Environment (getEnvironment) 16 | import System.IO (stderr, hPutStrLn, hFlush) 17 | import Debug.Trace (trace) 18 | 19 | -- import Test.Framework.TH (defaultMainGenerator) 20 | 21 | 22 | ---------------------------------------------------------------------------------------------------- 23 | -- Helpers 24 | ---------------------------------------------------------------------------------------------------- 25 | 26 | checkGCStats :: IO () 27 | checkGCStats = return () 28 | -- do b <- getGCStatsEnabled 29 | -- unless b $ error "Cannot run tests without +RTS -T !!" 30 | 31 | dotdot :: Int -> String -> String 32 | dotdot len chars = 33 | if length chars > len 34 | then take len chars ++ "..." 35 | else chars 36 | 37 | printBits :: [Bool] -> IO () 38 | printBits = print . map pb 39 | where pb True = '1' 40 | pb False = '0' 41 | 42 | forkJoin :: Int -> (Int -> IO b) -> IO [b] 43 | forkJoin numthreads action = 44 | do 45 | answers <- sequence (replicate numthreads newEmptyMVar) -- padding? 46 | dbgPrint 1 $ printf "Forking %d threads.\n" numthreads 47 | 48 | forM_ (zip [0..] answers) $ \ (ix,mv) -> 49 | forkIO (action ix >>= putMVar mv) 50 | 51 | -- Reading answers: 52 | ls <- mapM readMVar answers 53 | dbgPrint 1 $ printf "All %d thread(s) completed\n" numthreads 54 | return ls 55 | 56 | -- TODO: Here's an idea. Describe a structure of forking and joining threads for 57 | -- tests, then we can stress test it by running different interleavings explicitly. 58 | data Forkable a = Fork Int (IO a) 59 | | Parallel (Forkable a) (Forkable a) -- Parallel composition 60 | | Sequence (Forkable a) (Forkable a) -- Sequential compositon, with barrier 61 | -- | Barrier Forkable 62 | 63 | -- | Grab a GC-invariant stable "address" for any value. 64 | {-# NOINLINE unsafeName #-} 65 | unsafeName :: a -> Int 66 | unsafeName x = unsafePerformIO $ do 67 | sn <- makeStableName x 68 | return (hashStableName sn) 69 | 70 | 71 | -- | Measure realtime 72 | timeit :: IO a -> IO a 73 | timeit ioact = do 74 | start <- getCurrentTime 75 | res <- ioact 76 | end <- getCurrentTime 77 | putStrLn$ " Time elapsed: " ++ show (diffUTCTime end start) 78 | return res 79 | 80 | 81 | -- | Measure CPU time rather than realtime... 82 | cputime :: IO t -> IO t 83 | cputime a = do 84 | start <- getCPUTime 85 | v <- a 86 | end <- getCPUTime 87 | let diff = (fromIntegral (end - start)) / (10^(12::Int)) 88 | _ <- printf "SELFTIMED: %0.3f sec\n" (diff :: Double) 89 | return v 90 | 91 | 92 | -- | To make sure we get a simple loop... 93 | nTimes :: Int -> IO () -> IO () 94 | -- nTimes :: Int -> IO a -> IO () 95 | -- Note: starting out I would get 163Mb allocation for 10M sequential incrs (on unboxed). 96 | -- The problem was that the "Int" result from each incr was being allocated. 97 | -- Weird thing is that inlining nTimes reduces the allocation to 323Mb. 98 | -- But forcing it to take an (IO ()) gets rid of the allocation. 99 | -- Egad, wait, no, I have to NOT inline nTimes to get rid of the allocation!?!? 100 | -- Otherwise I'm still stuck with at least 163Mb of allocation. 101 | -- In fact... the allocation is still there even if we use incrCounter_ !! 102 | -- If we leave nTimes uninlined, we can get down to 3Mb allocation with either incrCounter or incrCounter_. 103 | ------------------------- 104 | -- UPDATE: 105 | -- As per http://www.haskell.org/pipermail/glasgow-haskell-users/2011-June/020472.html 106 | -- 107 | -- INLINE should not affect recursive functions. But here it seems to have a 108 | -- deleterious effect! 109 | nTimes 0 _ = return () 110 | nTimes !n !c = c >> nTimes (n-1) c 111 | 112 | 113 | 114 | ---------------------------------------------------------------------------------------------------- 115 | -- DEBUGGING 116 | ---------------------------------------------------------------------------------------------------- 117 | 118 | -- | Debugging flag shared by all accelerate-backend-kit modules. 119 | -- This is activated by setting the environment variable DEBUG=1..5 120 | dbg :: Int 121 | dbg = case lookup "DEBUG" unsafeEnv of 122 | Nothing -> defaultDbg 123 | Just "" -> defaultDbg 124 | Just "0" -> defaultDbg 125 | Just s -> 126 | warnUsing (" DEBUG="++s)$ 127 | case reads s of 128 | ((n,_):_) -> n 129 | [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s 130 | 131 | -- | How many elements or iterations should the test use? 132 | numElems :: Int 133 | numElems = case lookup "NUMELEMS" unsafeEnv of 134 | Nothing -> 1000 * 1000 -- A million by default. 135 | Just str -> warnUsing ("NUMELEMS = "++str) $ 136 | read str 137 | 138 | warnUsing :: String -> a -> a 139 | warnUsing str a = trace (" [Warning]: Using environment variable "++str) a 140 | 141 | defaultDbg :: Int 142 | defaultDbg = 0 143 | 144 | unsafeEnv :: [(String,String)] 145 | unsafeEnv = unsafePerformIO getEnvironment 146 | 147 | -- | Print if the debug level is at or above a threshold. 148 | dbgPrint :: Int -> String -> IO () 149 | dbgPrint lvl str = if dbg < lvl then return () else do 150 | hPutStrLn stderr str 151 | hFlush stderr 152 | 153 | -- My own forM for numeric ranges (not requiring deforestation optimizations). 154 | -- Inclusive start, exclusive end. 155 | {-# INLINE for_ #-} 156 | for_ :: Monad m => Int -> Int -> (Int -> m ()) -> m () 157 | for_ start end _fn | start > end = error "for_: start is greater than end" 158 | for_ start end fn = loop start 159 | where 160 | loop !i | i == end = return () 161 | | otherwise = do fn i; loop (i+1) 162 | 163 | -------------------------------------------------------------------------------- /atomic-primops/testing/OtherCounterTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | Test the counter implementation alternatives. 4 | 5 | module CounterTests where 6 | 7 | import Control.Monad 8 | import GHC.Conc 9 | import System.CPUTime 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Text.Printf 12 | import Data.IORef 13 | 14 | import Data.Atomics 15 | import qualified Data.Atomics.Counter.Reference as C1 16 | import qualified Data.Atomics.Counter.IORef as C2 17 | import qualified Data.Atomics.Counter.Foreign as C3 18 | import qualified Data.Atomics.Counter.Unboxed as C4 19 | 20 | import CommonTesting (numElems, forkJoin, timeit, nTimes) 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | -- {-# INLINE vd #-} 25 | -- vd = void 26 | -- vd x = x 27 | 28 | normal tries = do 29 | r <- newIORef True 30 | nTimes tries $ do 31 | x <- readIORef r 32 | writeIORef r $! not x 33 | 34 | -- This is not allocating per-iteration currently, which is rather amazing given what 35 | -- casIORef returns. 36 | casBased tries = do 37 | r <- newIORef True 38 | nTimes tries $ do 39 | t <- readForCAS r 40 | casIORef r t (not $ peekTicket t) 41 | return () 42 | readIORef r 43 | 44 | normalIncr tries = do 45 | r <- newIORef 0 46 | nTimes tries $ do 47 | x <- readIORef r 48 | writeIORef r $! 1 + x 49 | readIORef r 50 | 51 | casBasedIncr tries = do 52 | r <- newIORef 0 53 | nTimes tries $ do 54 | t <- readForCAS r 55 | casIORef r t $! (1 + peekTicket t) 56 | return () 57 | readIORef r 58 | 59 | incrloop1 tries = do r <- C1.newCounter 0; nTimes tries $ void$ C1.incrCounter 1 r 60 | incrloop2 tries = do r <- C2.newCounter 0; nTimes tries $ void$ C2.incrCounter 1 r 61 | incrloop3 tries = do r <- C3.newCounter 0; nTimes tries $ void$ C3.incrCounter 1 r 62 | incrloop4 tries = do r <- C4.newCounter 0; nTimes tries $ C4.incrCounter_ 1 r 63 | 64 | -- | Here we do a loop to test the unboxing of results from incrCounter: 65 | -- As of now [2013.07.19], it is successfully unboxing the results. 66 | incrloop4B tries = do 67 | putStrLn " [incrloop4B] A test where we use the result of each incr." 68 | r <- C4.newCounter 1 69 | loop r tries 1 70 | where 71 | loop :: C4.AtomicCounter -> Int -> Int -> IO () 72 | loop r 0 _ = do v <- C4.readCounter r 73 | putStrLn$"Final value: "++show v 74 | return () 75 | loop r tries last = do 76 | n <- C4.incrCounter last r 77 | if n == 2 78 | then loop r (tries-1) 2 79 | else loop r (tries-1) 1 80 | 81 | -- | Here we let the counter overflow, which seems to be causing problems. 82 | overflowTest tries = do 83 | putStrLn " [incrloop4B] A test where we use the result of each incr." 84 | r <- C4.newCounter 1 85 | loop r tries 1 86 | where 87 | loop :: C4.AtomicCounter -> Int -> Int -> IO () 88 | loop r 0 _ = do v <- C4.readCounter r 89 | putStrLn$"Final value: "++show v 90 | return () 91 | loop r tries last = do 92 | putStrLn$ " [incrloop4B] Looping with tries left "++show tries 93 | n <- C4.incrCounter last r 94 | -- This is HANGING afer passing 2,147,483,648. 95 | -- Is there some defect wrt overflow? 96 | putStrLn$ " [incrloop4B] Done incr, received "++show n 97 | loop r (tries-1) n 98 | 99 | 100 | 101 | {-# INLINE parIncrloop #-} 102 | parIncrloop new incr iters = do 103 | numcap <- getNumCapabilities 104 | let each = iters `quot` numcap 105 | putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each 106 | r <- new 0 107 | forkJoin numcap $ \ _ -> 108 | nTimes each $ void $ incr 1 r 109 | return r 110 | 111 | parIncrloop1 = parIncrloop C1.newCounter C1.incrCounter 112 | parIncrloop2 = parIncrloop C2.newCounter C2.incrCounter 113 | parIncrloop3 = parIncrloop C3.newCounter C3.incrCounter 114 | parIncrloop4 = parIncrloop C4.newCounter C4.incrCounter 115 | 116 | -------------------------------------------------------------------------------- 117 | 118 | default_seq_tries = 10 * numElems 119 | -- Things are MUCH slower with contention: 120 | default_conc_tries = numElems 121 | 122 | counterTests = 123 | [ 124 | ---------------------------------------- 125 | testCase "RAW_single_thread_repeat_flip" $ do 126 | putStrLn "Timing readIORef/writeIORef on one thread" 127 | timeit (normal default_seq_tries) 128 | , testCase "CAS_single_thread_repeat_flip" $ do 129 | putStrLn "Timing CAS boolean flips on one thread without retries" 130 | fin <- timeit (casBased default_seq_tries) 131 | putStrLn$"Final value: "++show fin 132 | ---------------------------------------- 133 | , testCase "RAW_single_thread_repeat_incr" $ do 134 | putStrLn "Timing readIORef/writeIORef on one thread" 135 | fin <- timeit (normalIncr default_seq_tries) 136 | putStrLn$"Final value: "++show fin 137 | , testCase "CAS_single_thread_repeat_incr" $ do 138 | putStrLn "Timing CAS increments on one thread without retries" 139 | fin <- timeit (casBasedIncr default_seq_tries) 140 | putStrLn$"Final value: "++show fin 141 | ---------------------------------------- 142 | , testCase "CounterReference_single_thread_repeat_incr" $ timeit (incrloop1 default_seq_tries) 143 | , testCase "CounterIORef_single_thread_repeat_incr" $ timeit (incrloop2 default_seq_tries) 144 | , testCase "CounterForeign_single_thread_repeat_incr" $ timeit (incrloop3 default_seq_tries) 145 | , testCase "CounterUnboxed_single_thread_repeat_incr" $ timeit (incrloop4 default_seq_tries) 146 | , testCase "CounterUnboxed_incr_with_result_feedback" $ timeit (incrloop4B default_seq_tries) 147 | ---------------------------------------- 148 | 149 | -- Parallel versions: 150 | , testCase "CounterReference_concurrent_repeat_incr" $ void$ timeit (parIncrloop1 default_conc_tries) 151 | , testCase "CounterIORef_concurrent_repeat_incr" $ void$ timeit (parIncrloop2 default_conc_tries) 152 | , testCase "CounterForeign_concurrent_repeat_incr" $ void$ timeit (parIncrloop3 default_conc_tries) 153 | , testCase "CounterUnboxed_concurrent_repeat_incr" $ void$ timeit (parIncrloop4 default_conc_tries) 154 | ] 155 | -------------------------------------------------------------------------------- /atomic-primops/cbits/RtsDup.c: -------------------------------------------------------------------------------- 1 | 2 | // ============================================================ 3 | // NOTE: We only use this file for GHC < 7.8. 4 | // ============================================================ 5 | 6 | // If I #include "stg/SMP.h", then in I get duplicated symbols. 7 | // Rather, instead this file duplicates certain functionality from the 8 | // GHC runtime system (SMP.h). 9 | 10 | #define THREADED_RTS 11 | #define WITHSMP 12 | #undef KEEP_INLINES 13 | 14 | //-------------------------------------------------------------------------------- 15 | // #define EXTERN_INLINE inline 16 | #define EXTERN_INLINE 17 | 18 | // These are includes from the GHC implementation: 19 | #include "MachDeps.h" 20 | #include "stg/Types.h" 21 | // Grab the HOST_ARCH from here: 22 | #include "ghcplatform.h" 23 | 24 | //-------------------------------------------------------------------------------- 25 | 26 | /* 27 | * We need to tell both the compiler AND the CPU about the barriers. 28 | * It's no good preventing the CPU from reordering the operations if 29 | * the compiler has already done so - hence the "memory" restriction 30 | * on each of the barriers below. 31 | */ 32 | EXTERN_INLINE void 33 | DUP_write_barrier(void) { 34 | #if i386_HOST_ARCH || x86_64_HOST_ARCH 35 | __asm__ __volatile__ ("" : : : "memory"); 36 | #elif powerpc_HOST_ARCH 37 | __asm__ __volatile__ ("lwsync" : : : "memory"); 38 | #elif sparc_HOST_ARCH 39 | /* Sparc in TSO mode does not require store/store barriers. */ 40 | __asm__ __volatile__ ("" : : : "memory"); 41 | #elif arm_HOST_ARCH && defined(arm_HOST_ARCH_PRE_ARMv7) 42 | __asm__ __volatile__ ("" : : : "memory"); 43 | #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) 44 | __asm__ __volatile__ ("dmb st" : : : "memory"); 45 | #elif !defined(WITHSMP) 46 | return; 47 | #else 48 | #error memory barriers unimplemented on this architecture 49 | #endif 50 | } 51 | 52 | EXTERN_INLINE void 53 | DUP_store_load_barrier(void) { 54 | #if i386_HOST_ARCH 55 | __asm__ __volatile__ ("lock; addl $0,0(%%esp)" : : : "memory"); 56 | #elif x86_64_HOST_ARCH 57 | __asm__ __volatile__ ("lock; addq $0,0(%%rsp)" : : : "memory"); 58 | #elif powerpc_HOST_ARCH 59 | __asm__ __volatile__ ("sync" : : : "memory"); 60 | #elif sparc_HOST_ARCH 61 | __asm__ __volatile__ ("membar #StoreLoad" : : : "memory"); 62 | #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) 63 | __asm__ __volatile__ ("dmb" : : : "memory"); 64 | #elif !defined(WITHSMP) 65 | return; 66 | #else 67 | #error memory barriers unimplemented on this architecture 68 | #endif 69 | } 70 | 71 | EXTERN_INLINE void 72 | DUP_load_load_barrier(void) { 73 | #if i386_HOST_ARCH 74 | __asm__ __volatile__ ("" : : : "memory"); 75 | #elif x86_64_HOST_ARCH 76 | __asm__ __volatile__ ("" : : : "memory"); 77 | #elif powerpc_HOST_ARCH 78 | __asm__ __volatile__ ("lwsync" : : : "memory"); 79 | #elif sparc_HOST_ARCH 80 | /* Sparc in TSO mode does not require load/load barriers. */ 81 | __asm__ __volatile__ ("" : : : "memory"); 82 | #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) 83 | __asm__ __volatile__ ("dmb" : : : "memory"); 84 | #elif !defined(WITHSMP) 85 | return; 86 | #else 87 | #error memory barriers unimplemented on this architecture 88 | #endif 89 | } 90 | 91 | // Load a pointer from a memory location that might be being modified 92 | // concurrently. This prevents the compiler from optimising away 93 | // multiple loads of the memory location, as it might otherwise do in 94 | // a busy wait loop for example. 95 | // #define VOLATILE_LOAD(p) (*((StgVolatilePtr)(p))) 96 | 97 | 98 | /* 99 | * CMPXCHG - the single-word atomic compare-and-exchange instruction. Used 100 | * in the STM implementation. 101 | */ 102 | EXTERN_INLINE StgWord 103 | DUP_cas(StgVolatilePtr p, StgWord o, StgWord n) 104 | { 105 | #if i386_HOST_ARCH || x86_64_HOST_ARCH 106 | __asm__ __volatile__ ( 107 | "lock\ncmpxchg %3,%1" 108 | :"=a"(o), "=m" (*(volatile unsigned int *)p) 109 | :"0" (o), "r" (n)); 110 | return o; 111 | #elif powerpc_HOST_ARCH 112 | StgWord result; 113 | __asm__ __volatile__ ( 114 | "1: lwarx %0, 0, %3\n" 115 | " cmpw %0, %1\n" 116 | " bne 2f\n" 117 | " stwcx. %2, 0, %3\n" 118 | " bne- 1b\n" 119 | "2:" 120 | :"=&r" (result) 121 | :"r" (o), "r" (n), "r" (p) 122 | :"cc", "memory" 123 | ); 124 | return result; 125 | #elif sparc_HOST_ARCH 126 | __asm__ __volatile__ ( 127 | "cas [%1], %2, %0" 128 | : "+r" (n) 129 | : "r" (p), "r" (o) 130 | : "memory" 131 | ); 132 | return n; 133 | #elif arm_HOST_ARCH && defined(arm_HOST_ARCH_PRE_ARMv6) 134 | StgWord r; 135 | arm_atomic_spin_lock(); 136 | r = *p; 137 | if (r == o) { *p = n; } 138 | arm_atomic_spin_unlock(); 139 | return r; 140 | #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv6) 141 | StgWord result,tmp; 142 | 143 | __asm__ __volatile__( 144 | "1: ldrex %1, [%2]\n" 145 | " mov %0, #0\n" 146 | " teq %1, %3\n" 147 | " it eq\n" 148 | " strexeq %0, %4, [%2]\n" 149 | " teq %0, #1\n" 150 | " it eq\n" 151 | " beq 1b\n" 152 | #if !defined(arm_HOST_ARCH_PRE_ARMv7) 153 | " dmb\n" 154 | #endif 155 | : "=&r"(tmp), "=&r"(result) 156 | : "r"(p), "r"(o), "r"(n) 157 | : "cc","memory"); 158 | 159 | return result; 160 | #elif !defined(WITHSMP) 161 | StgWord result; 162 | result = *p; 163 | if (result == o) { 164 | *p = n; 165 | } 166 | return result; 167 | #else 168 | #error cas() unimplemented on this architecture 169 | #endif 170 | } 171 | 172 | 173 | // Copied from atomic_inc in the GHC RTS, except tweaked to allow 174 | // arbitrary increments (other than 1). 175 | EXTERN_INLINE StgWord 176 | atomic_inc_with(StgWord incr, StgVolatilePtr p) 177 | { 178 | #if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) 179 | StgWord r; 180 | r = incr; 181 | __asm__ __volatile__ ( 182 | "lock\nxadd %0,%1": 183 | "+r" (r), "+m" (*p): 184 | ); 185 | return r + incr; 186 | #else 187 | StgWord old, new; 188 | do { 189 | old = *p; 190 | new = old + incr; 191 | } while (DUP_cas(p, old, new) != old); 192 | return new; 193 | #endif 194 | } 195 | -------------------------------------------------------------------------------- /abstract-deque/Data/Concurrent/Deque/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, CPP, TypeSynonymInstances, MultiParamTypeClasses, 2 | FlexibleInstances, EmptyDataDecls #-} 3 | 4 | #ifdef DEFAULT_SIGNATURES 5 | {-# LANGUAGE DefaultSignatures #-} 6 | #endif 7 | 8 | {- | 9 | An abstract, parameterizable interface for queues. 10 | 11 | This interface includes a non-associated type family for Deques 12 | plus separate type classes encapsulating the Deque operations. 13 | That is, we separate type selection (type family) from function overloading 14 | (vanilla type classes). 15 | 16 | This design strives to hide the extra phantom-type parameters from 17 | the Class constraints and therefore from the type signatures of 18 | client code. 19 | 20 | -} 21 | module Data.Concurrent.Deque.Class 22 | ( 23 | -- * Highly parameterized Deque type(s) 24 | Deque 25 | -- ** The choices that select a queue-variant. 26 | -- *** Choice #1 -- thread safety. 27 | , Threadsafe, Nonthreadsafe 28 | -- *** Choice #2 -- double or single functionality on an end. 29 | , SingleEnd, DoubleEnd 30 | -- *** Choice #3 -- bounded or growing queues: 31 | , Bound, Grow 32 | -- *** Choice #4 -- duplication of elements. 33 | , Safe, Dup 34 | -- ** Aliases enabling more concise Deque types: 35 | , S, D, NT, T 36 | 37 | -- ** Aliases for commonly used Deque configurations: 38 | , Queue, ConcQueue, ConcDeque, WSDeque 39 | 40 | -- * Class for basic Queue operations 41 | , DequeClass(..) 42 | 43 | -- * Extra capabilities: type classes 44 | 45 | -- | These classes provide a more programmer-friendly constraints than directly 46 | -- using the phantom type parameters to constrain queues in user code. Also note 47 | -- that instances can be provided for types outside the type `Deque` type family. 48 | -- 49 | -- We still make a distinction between the different capabilities 50 | -- (e.g. single-ended / double ended), and thus we need the below type classes for 51 | -- the additional operations unsupported by the minimal "DequeClass". 52 | 53 | -- ** The \"unnatural\" double ended cases: pop left, push right. 54 | , PopL(..), PushR(..) 55 | 56 | -- ** Operations that only make sense for bounded queues. 57 | , BoundedL(..), BoundedR(..) 58 | ) 59 | 60 | 61 | where 62 | 63 | import Prelude hiding (Bounded) 64 | 65 | {- | 66 | 67 | A family of Deques implementations. A concrete Deque implementation 68 | is selected based on the (phantom) type parameters, which encode 69 | several choices. 70 | 71 | For example, a work stealing deque is threadsafe only on one end and 72 | supports push/pop on one end (and pop-only) on the other: 73 | 74 | >> (Deque NT T D S Grow elt) 75 | 76 | Note, however, that the above example is overconstraining in many 77 | situations. It demands an implementation which is NOT threadsafe on 78 | one end and does NOT support push on one end, whereas both these 79 | features would not hurt, if present. 80 | 81 | Thus when accepting a queue as input to a function you probably never 82 | want to overconstrain by demanding a less-featureful option. 83 | 84 | For example, rather than @(Deque NT D T S Grow elt)@ 85 | You would probably want: @(Deque nt D T s Grow elt)@ 86 | 87 | -} 88 | -- data family Deque lThreaded rThreaded lDbl rDbl bnd safe elt 89 | type family Deque lThreaded rThreaded lDbl rDbl bnd safe elt 90 | 91 | -- | Haskell IO threads ("Control.Concurrent") may concurrently access 92 | -- this end of the queue. Note that this attribute is set 93 | -- separately for the left and right ends. 94 | data Threadsafe 95 | -- | Only one thread at a time may access this end of the queue. 96 | data Nonthreadsafe 97 | 98 | -- | This end of the queue provides push-only (left) or pop-only 99 | -- (right) functionality. Thus a 'SingleEnd' / 'SingleEnd' combination 100 | -- is what is commonly referred to as a /single ended queue/, whereas 101 | -- 'DoubleEnd' / 'DoubleEnd' is 102 | -- a /double ended queue/. Heterogeneous combinations are sometimes 103 | -- colloquially referred to as \"1.5 ended queues\". 104 | data SingleEnd 105 | -- | This end of the queue supports both push and pop. 106 | data DoubleEnd 107 | 108 | -- | The queue has bounded capacity. 109 | data Bound 110 | -- | The queue can grow as elements are added. 111 | data Grow 112 | 113 | -- | The queue will not duplicate elements. 114 | data Safe 115 | -- | Pop operations may possibly duplicate elements. Hopefully with low probability! 116 | data Dup 117 | 118 | -- Possible #5: 119 | -- data Lossy -- I know of no algorithm which would motivate having a Lossy mode. 120 | 121 | ---------------------------------------- 122 | 123 | type T = Threadsafe 124 | type NT = Nonthreadsafe 125 | type S = SingleEnd 126 | type D = DoubleEnd 127 | 128 | -- | A traditional single-threaded, single-ended queue. 129 | type Queue a = Deque Nonthreadsafe Nonthreadsafe SingleEnd SingleEnd Grow Safe a 130 | -- | A concurrent queue. 131 | type ConcQueue a = Deque Threadsafe Threadsafe SingleEnd SingleEnd Grow Safe a 132 | -- | A concurrent deque. 133 | type ConcDeque a = Deque Threadsafe Threadsafe DoubleEnd DoubleEnd Grow Safe a 134 | -- | Work-stealing deques (1.5 ended). Typically the worker pushes 135 | -- and pops its own queue (left) whereas thieves only pop (right). 136 | type WSDeque a = Deque Nonthreadsafe Threadsafe DoubleEnd SingleEnd Grow Safe a 137 | 138 | -------------------------------------------------------------------------------- 139 | 140 | -- | Class encompassing the basic queue operations that hold for all 141 | -- single, 1.5, and double ended modes. We arbitrarily call the 142 | -- ends \"left\" and \"right\" and choose the natural operations to be 143 | -- pushing on the left and popping on the right. 144 | class DequeClass d where 145 | -- | Create a new deque. Most appropriate for unbounded deques. 146 | -- If bounded, the size is unspecified. 147 | newQ :: IO (d elt) 148 | 149 | #ifdef DEFAULT_SIGNATURES 150 | #warning "Providing default binding and signature for newQ..." 151 | default newQ :: BoundedL d => IO (d elt) 152 | newQ = newBoundedQ 256 153 | #endif 154 | 155 | -- | Is the queue currently empty? Beware that this can be a highly transient state. 156 | nullQ :: d elt -> IO Bool 157 | 158 | -- | Natural push: push onto the left end of the deque. 159 | pushL :: d elt -> elt -> IO () 160 | -- | Natural pop: pop from the right end of the deque. 161 | tryPopR :: d elt -> IO (Maybe elt) 162 | 163 | -- TODO: Consider adding a peek operation? 164 | 165 | -- TODO: It would also be possible to include blocking/spinning pops. 166 | -- But maybe those should go in separate type classes... 167 | 168 | -- | Runtime indication of thread safety for `pushL` (and `popL`). 169 | -- (Argument unused.) 170 | leftThreadSafe :: d elt -> Bool 171 | 172 | -- | Runtime indication of thread safety for `tryPopR` (and `pushR`). 173 | -- (Argument unused.) 174 | rightThreadSafe :: d elt -> Bool 175 | 176 | class DequeClass d => PopL d where 177 | -- | PopL is not the native operation for the left end, so it requires 178 | -- that the left end be a 'DoubleEnd', but places no other requirements 179 | -- on the input queue. 180 | -- 181 | tryPopL :: d elt -> IO (Maybe elt) 182 | 183 | class DequeClass d => PushR d where 184 | -- | Pushing is not the native operation for the right end, so it requires 185 | -- that end be a 'DoubleEnd'. 186 | pushR :: d elt -> elt -> IO () 187 | 188 | class DequeClass d => BoundedL d where 189 | -- | Create a new, bounded deque with a specified capacity. 190 | newBoundedQ :: Int -> IO (d elt) 191 | -- | For a bounded deque, pushing may fail if the deque is full. 192 | tryPushL :: d elt -> elt -> IO Bool 193 | 194 | class PushR d => BoundedR d where 195 | -- | For a bounded deque, pushing may fail if the deque is full. 196 | tryPushR :: d elt -> elt -> IO Bool 197 | 198 | -------------------------------------------------------------------------------- /chaselev-deque/Data/Concurrent/Deque/ReactorDeque.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleContexts, DeriveDataTypeable #-} 2 | 3 | -- This is the Deque from the Reactor package written by Edward Kmett. 4 | 5 | {- 6 | Copyright 2011 Edward Kmett 7 | 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions 12 | are met: 13 | 14 | 1. Redistributions of source code must retain the above copyright 15 | notice, this list of conditions and the following disclaimer. 16 | 17 | 2. Redistributions in binary form must reproduce the above copyright 18 | notice, this list of conditions and the following disclaimer in the 19 | documentation and/or other materials provided with the distribution. 20 | 21 | 3. Neither the name of the author nor the names of his contributors 22 | may be used to endorse or promote products derived from this software 23 | without specific prior written permission. 24 | 25 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 26 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 27 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 28 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 29 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 30 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 31 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 33 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 | POSSIBILITY OF SUCH DAMAGE. 36 | -} 37 | 38 | module Data.Concurrent.Deque.ReactorDeque ( 39 | Deque 40 | 41 | -- * Local stack operations 42 | , empty -- :: (MonadIO m, MArray a e IO) => IO (Deque a e) 43 | , push -- :: (MonadIO m, MArray a e IO) => e -> Deque a e -> IO () 44 | , pop -- :: (MonadIO m, MArray a e IO) => Deque a e -> IO (Maybe e) 45 | 46 | -- * Performance tuning 47 | , withCapacity -- :: (MonadIO m, MArray a e IO) => Int -> IO (Deque a e) 48 | , minimumCapacity -- :: Int 49 | , defaultCapacity -- :: Int 50 | 51 | -- * Work stealing 52 | , steal -- :: (MonadIO m, MArray a e IO) => Deque a e -> IO (Stolen e) 53 | , Stolen(..) 54 | ) where 55 | 56 | -- | For an explanation of the implementation, see \"Dynamic Circular Work-Stealing Deque\" 57 | -- by David Chase and Yossi Lev of Sun Microsystems. 58 | 59 | import Prelude hiding (read) 60 | import Control.Applicative hiding (empty) 61 | import Data.Bits.Atomic 62 | import Foreign.Ptr 63 | import Foreign.ForeignPtr 64 | import Foreign.Storable 65 | import Data.IORef 66 | import Data.Array.MArray 67 | import Control.Monad 68 | import Control.Monad.IO.Class 69 | import Data.Data 70 | import System.IO.Unsafe 71 | 72 | data Buffer a e = Buffer {-# UNPACK #-} !Int !(a Int e) 73 | 74 | instance Typeable2 a => Typeable1 (Buffer a) where 75 | typeOf1 tae = mkTyConApp bufferTyCon [typeOf1 (aInte tae)] 76 | where aInte :: t a e -> a Int e 77 | aInte = undefined 78 | 79 | bufferTyCon :: TyCon 80 | bufferTyCon = mkTyCon "Reactor.Deque.Buffer" 81 | 82 | size :: Buffer a e -> Int 83 | size (Buffer i _) = i 84 | 85 | data Deque a e = Deque 86 | { _tb :: ForeignPtr Int 87 | , _content :: IORef (Buffer a e) 88 | } 89 | 90 | instance (MArray a e IO, Show e) => Show (Deque a e) where 91 | showsPrec d (Deque tb content) = unsafePerformIO $ do 92 | (t,b) <- withForeignPtr tb $ \p -> (,) <$> peekTop p <*> peekBottom p 93 | buffer <- readIORef content 94 | contents <- forM [t..b-1] (read buffer) 95 | return $ showParen (d > 10) $ 96 | showString "Deque (ptr " . showsPrec 11 t . showChar ' ' . showsPrec 11 b . showString ") (buffer " . showsPrec 11 contents . showChar ')' 97 | 98 | instance Typeable2 a => Typeable1 (Deque a) where 99 | typeOf1 dae = mkTyConApp dequeTyCon [typeOf1 (aInte dae)] 100 | where aInte :: t a e -> a Int e 101 | aInte = undefined 102 | 103 | dequeTyCon :: TyCon 104 | dequeTyCon = mkTyCon "Reactor.Deque.Deque" 105 | 106 | ptr :: Storable a => a -> a -> IO (ForeignPtr a) 107 | ptr a b = do 108 | p <- mallocForeignPtrArray 2 109 | withForeignPtr p $ \q -> do 110 | poke q a 111 | pokeElemOff q 1 b 112 | return p 113 | 114 | minimumCapacity :: Int 115 | minimumCapacity = 16 116 | 117 | defaultCapacity :: Int 118 | defaultCapacity = 32 119 | 120 | bufferWithCapacity :: MArray a e IO => Int -> IO (Buffer a e) 121 | bufferWithCapacity i = 122 | Buffer i <$> newArray_ (0, (minimumCapacity `max` i) - 1) 123 | 124 | withCapacity :: (MonadIO m, MArray a e IO) => Int -> m (Deque a e) 125 | withCapacity i = liftIO (Deque <$> ptr 0 0 <*> (bufferWithCapacity i >>= newIORef)) 126 | 127 | empty :: (MonadIO m, MArray a e IO) => m (Deque a e) 128 | empty = withCapacity defaultCapacity 129 | {-# INLINE empty #-} 130 | 131 | -- unsafeRead 132 | read :: MArray a e IO => Buffer a e -> Int -> IO e 133 | read (Buffer s c) i = do 134 | readArray c (i `mod` s) 135 | {-# INLINE read #-} 136 | 137 | -- unsafeWrite 138 | write :: MArray a e IO => Buffer a e -> Int -> e -> IO () 139 | write (Buffer s c) i e = do 140 | writeArray c (i `mod` s) e 141 | {-# INLINE write #-} 142 | 143 | grow :: MArray a e IO => Buffer a e -> Int -> Int -> IO (Buffer a e) 144 | grow c b t = do 145 | c' <- bufferWithCapacity (size c * 2) 146 | forM_ [t..b-1] $ \i -> read c i >>= write c' i 147 | return c' 148 | {-# INLINE grow #-} 149 | 150 | peekBottom :: Ptr Int -> IO Int 151 | peekBottom p = peekElemOff p 1 152 | 153 | peekTop :: Ptr Int -> IO Int 154 | peekTop p = peek p 155 | 156 | pokeBottom :: Ptr Int -> Int -> IO () 157 | pokeBottom p = pokeElemOff p 1 158 | 159 | push :: (MonadIO m, MArray a e IO) => e -> Deque a e -> m () 160 | push o (Deque tb content) = liftIO $ withForeignPtr tb $ \p -> do 161 | b <- peekBottom p 162 | t <- peekTop p 163 | a <- readIORef content 164 | let size' = b - t 165 | if size' >= size a 166 | then do 167 | a' <- grow a b t 168 | writeIORef content a' 169 | go p a' b 170 | else go p a b 171 | where 172 | go p arr b = do 173 | write arr b o 174 | pokeBottom p (b + 1) 175 | 176 | data Stolen e 177 | = Empty 178 | | Abort 179 | | Stolen e 180 | deriving (Data,Typeable,Eq,Ord,Show,Read) 181 | 182 | steal :: (MonadIO m, MArray a e IO) => Deque a e -> m (Stolen e) 183 | steal (Deque tb content) = liftIO $ withForeignPtr tb $ \p -> do 184 | t <- peekTop p 185 | b <- peekBottom p 186 | a <- readIORef content 187 | let size' = b - t 188 | if size' <= 0 189 | then return Empty 190 | else do 191 | o <- read a t 192 | result <- compareAndSwapBool p t (t + 1) 193 | return $ if result then Stolen o else Abort 194 | 195 | {- 196 | steal' :: MArray a e IO => Deque a e -> IO (Maybe e) 197 | steal' deque = do 198 | s <- steal deque 199 | case s of 200 | Stolen e -> return (Just e) 201 | Empty -> return Nothing 202 | Abort -> steal' deque 203 | -} 204 | 205 | pop :: (MonadIO m, MArray a e IO) => Deque a e -> m (Maybe e) 206 | pop (Deque tb content) = liftIO $ withForeignPtr tb $ \p -> do 207 | b <- peekBottom p 208 | a <- readIORef content 209 | let b' = b - 1 210 | pokeBottom p b' 211 | t <- peekTop p 212 | let size' = b' - t 213 | if size' < 0 214 | then do 215 | pokeBottom p t 216 | return Nothing 217 | else do 218 | o <- read a b' 219 | if size' > 0 220 | then return (Just o) 221 | else do 222 | result <- compareAndSwapBool p t (t + 1) 223 | if result 224 | then do 225 | pokeBottom p (t + 1) 226 | return (Just o) 227 | else do 228 | pokeBottom p (t + 1) 229 | return Nothing 230 | -------------------------------------------------------------------------------- /atomic-primops/testing/Fetch.hs: -------------------------------------------------------------------------------- 1 | module Fetch (tests) where 2 | 3 | -- tests for our fetch-and-* family of functions. 4 | import Control.Monad 5 | import System.Random 6 | import Test.Framework.Providers.HUnit (testCase) 7 | import Test.Framework (Test) 8 | import Test.HUnit (assertEqual,assertBool) 9 | import Data.Primitive 10 | import Data.List 11 | import Data.Bits 12 | import Data.Atomics 13 | import Control.Monad.Primitive 14 | import Control.Concurrent 15 | 16 | tests :: [Test] 17 | tests = [ 18 | testCase "Fetch-and-* operations return previous value" case_return_previous 19 | , testCase "Fetch-and-* operations behave like their corresponding bitwise operators" case_like_bitwise 20 | , testCase "fetchAndIntArray and fetchOrIntArray are atomic" $ fetchAndOrTest 10000000 21 | , testCase "fetchNandIntArray atomic" $ fetchNandTest 1000000 22 | , testCase "fetchAddIntArray and fetchSubIntArray are atomic" $ fetchAddSubTest 10000000 23 | , testCase "fetchXorIntArray is atomic" $ fetchXorTest 10000000 24 | ] 25 | 26 | nand :: Bits a => a -> a -> a 27 | nand x y = complement (x .&. y) 28 | 29 | fetchOps :: [( String 30 | , MutableByteArray RealWorld -> Int -> Int -> IO Int 31 | , Int -> Int -> Int )] 32 | fetchOps = [ 33 | ("Add", fetchAddIntArray, (+)), 34 | ("Sub", fetchSubIntArray, (-)), 35 | ("And", fetchAndIntArray, (.&.)), 36 | ("Nand", fetchNandIntArray, nand), 37 | ("Or", fetchOrIntArray, (.|.)), 38 | ("Xor", fetchXorIntArray, xor) 39 | ] 40 | 41 | 42 | -- Test all operations at once, somewhat randomly, ensuring they behave like 43 | -- their corresponding bitwise operator; we compose a few operations before 44 | -- inspecting the intermediate result, and spread them randomly around a small 45 | -- array. 46 | -- TODO use quickcheck if we want 47 | case_like_bitwise :: IO () 48 | case_like_bitwise = do 49 | let opGroupSize = 5 50 | let grp n = go n [] 51 | where go _ stck [] = [stck] 52 | go 0 stck xs = stck : go n [] xs 53 | go i stck (x:xs) = go (i-1) (x:stck) xs 54 | -- Inf list of different short sequences of bitwise operations: 55 | let opGroups = grp opGroupSize $ cycle $ concat $ permutations fetchOps 56 | 57 | let size = 4 58 | randIxs <- randomRs (0, size-1) <$> newStdGen 59 | randArgs <- grp opGroupSize . randoms <$> newStdGen 60 | 61 | a <- newByteArray (sizeOf (undefined::Int) * size) 62 | forM_ [0.. size-1] $ \ix-> writeByteArray a ix (0::Int) 63 | 64 | forM_ (take 1000000 $ zip randIxs $ zipWith zip opGroups randArgs) $ 65 | \ (ix, opsArgs)-> do 66 | assertEqual "test not b0rken" (length opsArgs) opGroupSize 67 | 68 | let doOpGroups pureLHS [] = return pureLHS 69 | doOpGroups pureLHS (((_,atomicOp,op), v) : rest) = do 70 | atomicOp a ix v >> doOpGroups (pureLHS `op` v) rest 71 | 72 | vInitial <- readByteArray a ix 73 | vFinalPure <- doOpGroups vInitial opsArgs 74 | vFinal <- readByteArray a ix 75 | 76 | let nmsArgs = map (\ ((nm,_,_),v) -> (nm,v)) opsArgs 77 | assertEqual ("sequence on initial value "++(show vInitial) 78 | ++" of ops with RHS args: "++(show nmsArgs) 79 | ++" gives same result in both pure and atomic op" 80 | ) vFinal vFinalPure 81 | 82 | 83 | 84 | -- check all operations return the value before the operation was applied; 85 | -- basic smoke test, with each op tested individually. 86 | case_return_previous :: IO () 87 | case_return_previous = do 88 | let l = length fetchOps 89 | a <- newByteArray (sizeOf (undefined::Int) * l) 90 | let randomInts = take l . randoms <$> newStdGen :: IO [Int] 91 | initial <- randomInts 92 | forM_ (zip [0..] initial) $ \(ix, v)-> writeByteArray a ix v 93 | 94 | args <- randomInts 95 | forM_ (zip4 [0..] initial args fetchOps) $ \(ix, pre, v, (nm,atomicOp,op))-> do 96 | pre' <- atomicOp a ix v 97 | assertEqual (fetchStr nm "returned previous value") pre pre' 98 | let post = pre `op` v 99 | post' <- readByteArray a ix 100 | assertEqual (fetchStrArgVal nm v pre "operation was seen correctly on read") post post' 101 | 102 | fetchStr :: String -> String -> String 103 | fetchStr nm = (("fetch"++nm++"IntArray: ")++) 104 | fetchStrArgVal :: (Show a, Show a1) => String -> a -> a1 -> String -> String 105 | fetchStrArgVal nm v initial = (("fetch"++nm++"IntArray, with arg "++(show v)++" on value "++(show initial)++": ")++) 106 | 107 | -- ---------------------------------------------------------------------------- 108 | -- Tests of atomicity: 109 | 110 | 111 | -- Concurrently run a sequence of AND and OR simultaneously on separate parts 112 | -- of the bit range of an Int. 113 | fetchAndOrTest :: Int -> IO () 114 | fetchAndOrTest iters = do 115 | out0 <- newEmptyMVar 116 | out1 <- newEmptyMVar 117 | mba <- newByteArray (sizeOf (undefined :: Int)) 118 | let andLowersBit , orRaisesBit :: Int -> Int 119 | andLowersBit = clearBit (complement 0) 120 | orRaisesBit = setBit 0 121 | writeByteArray mba 0 (0 :: Int) 122 | -- thread 1 toggles bit 0, thread 2 toggles bit 1; then we verify results 123 | -- in the main thread. 124 | let go v b = do 125 | -- Avoid stack overflow on GHC 7.6: 126 | let replicateMrev l 0 = putMVar v l 127 | replicateMrev l iter = do 128 | low <- fetchOrIntArray mba 0 (orRaisesBit b) 129 | high <- fetchAndIntArray mba 0 (andLowersBit b) 130 | replicateMrev ((low,high):l) (iter-1) 131 | in replicateMrev [] iters 132 | void $ forkIO $ go out0 0 133 | void $ forkIO $ go out1 1 134 | res0 <- takeMVar out0 135 | res1 <- takeMVar out1 136 | let check b = all ( \(low,high)-> (not $ testBit low b) && testBit high b) 137 | 138 | assertBool "fetchAndOrTest not broken" $ length (res0++res1) == iters*2 139 | assertBool "fetchAndOrTest thread1" $ check 0 res0 140 | assertBool "fetchAndOrTest thread2" $ check 1 res1 141 | 142 | -- Nand of 1 is a bit complement. Concurrently run two threads running an even 143 | -- number of complements in this way and verify the final value is unchanged. 144 | -- TODO think of a more clever test 145 | fetchNandTest :: Int -> IO () 146 | fetchNandTest iters = do 147 | let nandComplements = complement 0 148 | dblComplement mba = replicateM_ (2 * iters) $ 149 | fetchNandIntArray mba 0 nandComplements 150 | randomInts <- take 10 . randoms <$> newStdGen :: IO [Int] 151 | forM_ randomInts $ \ initial -> do 152 | final <- race initial dblComplement dblComplement 153 | assertEqual "fetchNandTest" initial final 154 | 155 | 156 | -- ---------------------------------------------------------------------------- 157 | -- Code below copied with minor modifications from GHC 158 | -- testsuite/tests/concurrent/should_run/AtomicPrimops.hs @ f293931 159 | -- ---------------------------------------------------------------------------- 160 | 161 | 162 | -- | Test fetchAddIntArray# by having two threads concurrenctly 163 | -- increment a counter and then checking the sum at the end. 164 | fetchAddSubTest :: Int -> IO () 165 | fetchAddSubTest iters = do 166 | tot <- race 0 167 | (\ mba -> work fetchAddIntArray mba iters 2) 168 | (\ mba -> work fetchSubIntArray mba iters 1) 169 | assertEqual "fetchAddSubTest" iters tot 170 | where 171 | work :: (MutableByteArray RealWorld -> Int -> Int -> IO Int) -> MutableByteArray RealWorld -> Int -> Int 172 | -> IO () 173 | work _ _ 0 _ = return () 174 | work op mba n val = op mba 0 val >> work op mba (n-1) val 175 | 176 | -- | Test fetchXorIntArray# by having two threads concurrenctly XORing 177 | -- and then checking the result at the end. Works since XOR is 178 | -- commutative. 179 | -- 180 | -- Covers the code paths for AND, NAND, and OR as well. 181 | fetchXorTest :: Int -> IO () 182 | fetchXorTest iters = do 183 | res <- race n0 184 | (\ mba -> work mba iters t1pat) 185 | (\ mba -> work mba iters t2pat) 186 | assertEqual "fetchXorTest" expected res 187 | where 188 | work :: MutableByteArray RealWorld -> Int -> Int -> IO () 189 | work _ 0 _ = return () 190 | work mba n val = fetchXorIntArray mba 0 val >> work mba (n-1) val 191 | 192 | -- Initial value is a large prime and the two patterns are 1010... 193 | -- and 0101... 194 | (n0, t1pat, t2pat) 195 | -- TODO: If we want to silence warnings from here, use CPP conditional 196 | -- on arch x86_64 197 | | sizeOf (undefined :: Int) == 8 = 198 | (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999) 199 | | otherwise = (0x0000ffff, 0x55555555, 0x99999999) 200 | expected 201 | | sizeOf (undefined :: Int) == 8 = 4294967295 202 | | otherwise = 65535 203 | 204 | -- | Create two threads that mutate the byte array passed to them 205 | -- concurrently. The array is one word large. 206 | race :: Int -- ^ Initial value of array element 207 | -> (MutableByteArray RealWorld -> IO ()) -- ^ Thread 1 action 208 | -> (MutableByteArray RealWorld -> IO ()) -- ^ Thread 2 action 209 | -> IO Int -- ^ Final value of array element 210 | race n0 thread1 thread2 = do 211 | done1 <- newEmptyMVar 212 | done2 <- newEmptyMVar 213 | mba <- newByteArray (sizeOf (undefined :: Int)) 214 | writeByteArray mba 0 n0 215 | void $ forkIO $ thread1 mba >> putMVar done1 () 216 | void $ forkIO $ thread2 mba >> putMVar done2 () 217 | mapM_ takeMVar [done1, done2] 218 | readByteArray mba 0 219 | -------------------------------------------------------------------------------- /lockfree-queue/Data/Concurrent/Queue/MichaelScott.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, ScopedTypeVariables #-} 2 | -- TypeFamilies, FlexibleInstances 3 | 4 | -- | Michael and Scott lock-free, single-ended queues. 5 | -- 6 | -- This is a straightforward implementation of classic Michael & Scott Queues. 7 | -- Pseudocode for this algorithm can be found here: 8 | -- 9 | -- 10 | 11 | -- Uncomment this if desired. Needs more testing: 12 | -- #define RECHECK_ASSUMPTIONS 13 | 14 | module Data.Concurrent.Queue.MichaelScott 15 | ( 16 | -- The convention here is to directly provide the concrete 17 | -- operations as well as providing the typeclass instances. 18 | LinkedQueue(), newQ, nullQ, pushL, tryPopR, 19 | ) 20 | where 21 | 22 | import Data.IORef (readIORef, newIORef) 23 | import System.IO (stderr) 24 | 25 | #ifdef DEBUG 26 | import Data.ByteString.Char8 (hPutStrLn, pack) 27 | #endif 28 | 29 | -- import GHC.Types (Word(W#)) 30 | import GHC.IORef(IORef(IORef)) 31 | import GHC.STRef(STRef(STRef)) 32 | 33 | import qualified Data.Concurrent.Deque.Class as C 34 | import Data.Atomics (readForCAS, casIORef, Ticket, peekTicket) 35 | 36 | -- GHC 7.8 changed some primops 37 | import GHC.Base hiding ((==#), sameMutVar#) 38 | import GHC.Exts hiding ((==#), sameMutVar#) 39 | import qualified GHC.Exts as Exts 40 | (==#) :: Int# -> Int# -> Bool 41 | (==#) x y = case x Exts.==# y of { 0# -> False; _ -> True } 42 | 43 | sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool 44 | sameMutVar# x y = case Exts.sameMutVar# x y of { 0# -> False; _ -> True } 45 | 46 | 47 | -- Considering using the Queue class definition: 48 | -- import Data.MQueue.Class 49 | 50 | data LinkedQueue a = LQ 51 | { head :: {-# UNPACK #-} !(IORef (Pair a)) 52 | , tail :: {-# UNPACK #-} !(IORef (Pair a)) 53 | } 54 | 55 | data Pair a = Null | Cons a {-# UNPACK #-}!(IORef (Pair a)) 56 | 57 | {-# INLINE pairEq #-} 58 | -- | This only checks that the node type is the same and in the case of a Cons Pair 59 | -- checks that the underlying MutVar#s are pointer-equal. This suffices to check 60 | -- equality since each IORef is never used in multiple Pair values. 61 | pairEq :: Pair a -> Pair a -> Bool 62 | pairEq Null Null = True 63 | pairEq (Cons _ (IORef (STRef mv1))) 64 | (Cons _ (IORef (STRef mv2))) = sameMutVar# mv1 mv2 65 | pairEq _ _ = False 66 | 67 | -- | Push a new element onto the queue. Because the queue can grow, 68 | -- this always succeeds. 69 | pushL :: forall a . LinkedQueue a -> a -> IO () 70 | pushL q@(LQ headPtr tailPtr) val = do 71 | r <- newIORef Null 72 | let newp = Cons val r -- Create the new cell that stores val. 73 | -- Enqueue loop: repeatedly read the tail pointer and attempt to extend the last pair. 74 | loop :: IO () 75 | loop = do 76 | tailTicket <- readForCAS tailPtr -- [Re]read the tailptr from the queue structure. 77 | case peekTicket tailTicket of 78 | -- The head and tail pointers should never themselves be NULL: 79 | Null -> error "push: LinkedQueue invariants broken. Internal error." 80 | Cons _ nextPtr -> do 81 | nextTicket <- readForCAS nextPtr 82 | 83 | -- The algorithm can reread tailPtr here to make sure it is still good: 84 | -- [UPDATE: This is actually a necessary part of the algorithm's "hand-over-hand" 85 | -- locking, NOT an optimization.] 86 | #ifdef RECHECK_ASSUMPTIONS 87 | -- There's a possibility for an infinite loop here with StableName based ptrEq. 88 | -- (And at one point I observed such an infinite loop.) 89 | -- But with one based on reallyUnsafePtrEquality# we should be ok. 90 | (tailTicket', tail') <- readForCAS tailPtr -- ANDREAS: used atomicModifyIORef here 91 | if not (pairEq tail tail') then loop 92 | else case next of 93 | #else 94 | case peekTicket nextTicket of 95 | #endif 96 | -- Here tail points (or pointed!) to the last node. Try to link our new node. 97 | Null -> do (b,newtick) <- casIORef nextPtr nextTicket newp 98 | case b of 99 | True -> do 100 | --------------------Exit Loop------------------ 101 | -- After the loop, enqueue is done. Try to swing the tail. 102 | -- If we fail, that is ok. Whoever came in after us deserves it. 103 | _ <- casIORef tailPtr tailTicket newp 104 | return () 105 | ----------------------------------------------- 106 | False -> loop 107 | nxt@(Cons _ _) -> do 108 | -- Someone has beat us by extending the tail. Here we 109 | -- might have to do some community service by updating the tail ptr. 110 | _ <- casIORef tailPtr tailTicket nxt 111 | loop 112 | 113 | loop -- Start the loop. 114 | 115 | -- Andreas's checked this invariant in several places 116 | -- Check for: head /= tail, and head->next == NULL 117 | checkInvariant :: String -> LinkedQueue a -> IO () 118 | checkInvariant s (LQ headPtr tailPtr) = 119 | do head <- readIORef headPtr 120 | tail <- readIORef tailPtr 121 | if (not (pairEq head tail)) 122 | then case head of 123 | Null -> error (s ++ " checkInvariant: LinkedQueue invariants broken. Internal error.") 124 | Cons _ next -> do 125 | next' <- readIORef next 126 | case next' of 127 | Null -> error (s ++ " checkInvariant: next' should not be null") 128 | _ -> return () 129 | else return () 130 | 131 | -- | Attempt to pop an element from the queue if one is available. 132 | -- tryPop will return semi-promptly (depending on contention), but 133 | -- will return 'Nothing' if the queue is empty. 134 | tryPopR :: forall a . LinkedQueue a -> IO (Maybe a) 135 | -- FIXME -- this version 136 | -- TODO -- add some kind of backoff. This should probably at least 137 | -- yield after a certain number of failures. 138 | tryPopR q@(LQ headPtr tailPtr) = loop 0 139 | where 140 | loop :: Int -> IO (Maybe a) 141 | #ifdef DEBUG 142 | -- loop 10 = do hPutStrLn stderr (pack "tryPopR: tried ~10 times!!"); loop 11 -- This one happens a lot on -N32 143 | loop 25 = do hPutStrLn stderr (pack "tryPopR: tried ~25 times!!"); loop 26 144 | loop 50 = do hPutStrLn stderr (pack "tryPopR: tried ~50 times!!"); loop 51 145 | loop 100 = do hPutStrLn stderr (pack "tryPopR: tried ~100 times!!"); loop 101 146 | loop 1000 = do hPutStrLn stderr (pack "tryPopR: tried ~1000 times!!"); loop 1001 147 | #endif 148 | loop !tries = do 149 | headTicket <- readForCAS headPtr 150 | tailTicket <- readForCAS tailPtr 151 | case peekTicket headTicket of 152 | Null -> error "tryPopR: LinkedQueue invariants broken. Internal error." 153 | head@(Cons _ next) -> do 154 | nextTicket' <- readForCAS next 155 | #ifdef RECHECK_ASSUMPTIONS 156 | -- As with push, double-check our information is up-to-date. (head,tail,next consistent) 157 | head' <- readIORef headPtr -- ANDREAS: used atomicModifyIORef headPtr (\x -> (x,x)) 158 | if not (pairEq head head') then loop (tries+1) else do 159 | #else 160 | let head' = head 161 | do 162 | #endif 163 | -- Is queue empty or tail falling behind?: 164 | if pairEq head (peekTicket tailTicket) then do 165 | -- if ptrEq head tail then do 166 | case peekTicket nextTicket' of -- Is queue empty? 167 | Null -> return Nothing -- Queue is empty, couldn't dequeue 168 | next'@(Cons _ _) -> do 169 | -- Tail is falling behind. Try to advance it: 170 | casIORef tailPtr tailTicket next' 171 | loop (tries+1) 172 | 173 | else do -- head /= tail 174 | -- No need to deal with Tail. Read value before CAS. 175 | -- Otherwise, another dequeue might free the next node 176 | case peekTicket nextTicket' of 177 | Null -> error "tryPop: Internal error. Next should not be null if head/=tail." 178 | -- Null -> loop (tries+1) 179 | next'@(Cons value _) -> do 180 | -- Try to swing Head to the next node 181 | (b,_) <- casIORef headPtr headTicket next' 182 | case b of 183 | -- [2013.04.24] Looking at the STG, I can't see a way to get rid of the allocation on this Just: 184 | True -> return (Just value) -- Dequeue done; exit loop. 185 | False -> loop (tries+1) -- ANDREAS: observed this loop being taken >1M times 186 | 187 | -- | Create a new queue. 188 | newQ :: IO (LinkedQueue a) 189 | newQ = do 190 | r <- newIORef Null 191 | let newp = Cons (error "LinkedQueue: Used uninitialized magic value.") r 192 | hd <- newIORef newp 193 | tl <- newIORef newp 194 | return (LQ hd tl) 195 | 196 | -- | Is the queue currently empty? Beware that this can be a highly transient state. 197 | nullQ :: LinkedQueue a -> IO Bool 198 | nullQ (LQ headPtr tailPtr) = do 199 | head <- readIORef headPtr 200 | tail <- readIORef tailPtr 201 | return (pairEq head tail) 202 | 203 | 204 | 205 | -------------------------------------------------------------------------------- 206 | -- Instance(s) of abstract deque interface 207 | -------------------------------------------------------------------------------- 208 | 209 | -- instance DequeClass (Deque T T S S Grow Safe) where 210 | instance C.DequeClass LinkedQueue where 211 | newQ = newQ 212 | nullQ = nullQ 213 | pushL = pushL 214 | tryPopR = tryPopR 215 | leftThreadSafe _ = True 216 | rightThreadSafe _ = True 217 | 218 | -------------------------------------------------------------------------------- 219 | --------------------------------------------------------------------------------