packages feed

IORefCAS (empty) → 0.0.1

raw patch · 9 files changed

+832/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bits-atomic, ghc-prim

Files

+ Data/CAS.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, MagicHash,+    TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}++-- | Atomic compare and swap for IORefs and CASRefs.+module Data.CAS + ( casSTRef, casIORef,+   atomicModifyIORefCAS, atomicModifyIORefCAS_,++   -- * Generic interface: for interoperation with `Fake` and `Foreign` alternative libraries.+   CASRef)+where++import Data.CAS.Internal.Class+import GHC.IO+import GHC.IORef+import GHC.Prim+import GHC.ST+import GHC.STRef++--------------------------------------------------------------------------------++newtype CASRef a = CR { unCR :: IORef a }++instance CASable CASRef a where +  newCASable x = newIORef x >>= (return . CR)+  readCASable  = readIORef  . unCR+  writeCASable = writeIORef . unCR+  cas          = casIORef   . unCR++--------------------------------------------------------------------------------++-- | Performs a machine-level compare and swap operation on an+-- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'STRef'.+casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> ST s (Bool, a) +casSTRef (STRef var#) old new = ST $ \s1# ->+   -- The primop treats the boolean as a sort of error code.+   -- Zero means the CAS worked, one that it didn't.+   -- We flip that here:+    case casMutVar# var# old new s1# of+      (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)++-- | Performs a machine-level compare and swap operation on an+-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'IORef'.+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> IO (Bool, a) +casIORef (IORef var) old new = stToIO (casSTRef var old new)++-- | A drop-in replacement for `atomicModifyIORefCAS` that+--   optimistically attempts to compute the new value and CAS it into+--   place without introducing new thunks or locking anything.  Note+--   that this is STRICTer than its standard counterpart and will only+--   place evaluated (WHNF) values in the IORef.+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORefCAS ref fn = do+-- TODO: Should handle contention in a better way.+   init <- readIORef ref+   loop init effort+  where +   effort = 30 :: Int -- TODO: Tune this.+   loop old 0     = atomicModifyIORef ref fn+   loop old tries = do +     (new,result) <- evaluate (fn old)+     (b,val) <- casIORef ref old new+     if b +      then return result+      else loop val (tries-1)++-- | A simpler version that modifies the state but does not return anything.+atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()+-- atomicModifyIORefCAS_ ref fn = atomicModifyIORefCAS ref (\ x -> (fn x, ()))+-- Can't inline a function with a loop so we duplicate this:+-- <duplicated code>+atomicModifyIORefCAS_ ref fn = do+   init <- readIORef ref+   loop init effort+  where +   effort = 30 :: Int -- TODO: Tune this.+   loop old 0     = atomicModifyIORef_ ref fn+   loop old tries = do +     new <- evaluate (fn old)+     (b,val) <- casIORef ref old new+     if b +      then return ()+      else loop val (tries-1)+   atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ()))+-- </duplicated code>
+ Data/CAS/Internal/Class.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverlappingInstances, MultiParamTypeClasses, BangPatterns, MagicHash #-}++-- | A type class capturing mutable storage cells that support CAS+--   operations in the IO monad.++module Data.CAS.Internal.Class +  (CASable(..), unsafeName, ptrEq) + where++import GHC.IO (unsafePerformIO)+import GHC.Exts (Int(I#))+import GHC.Prim (reallyUnsafePtrEquality#)+import System.Mem.StableName++-- | It would be nice to use an associated type family with this class+--   (for casref), but that would preclude overlapping instances.+class CASable casref a where +  newCASable   :: a -> IO (casref a)+  readCASable  :: casref a -> IO a +  writeCASable :: casref a -> a -> IO ()+  cas          :: casref a -> a -> a -> IO (Bool,a)+++{-# NOINLINE unsafeName #-}+unsafeName :: a -> Int+unsafeName x = unsafePerformIO $ do +   sn <- makeStableName x+   return (hashStableName sn)++{-# NOINLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1
+ Data/CAS/Internal/Fake.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, BangPatterns #-}+-- Author: Ryan Newton++-- | This is an attempt to imitate a CAS using normal Haskell/GHC operations.+-- Useful for debugging.+-- ++module Data.CAS.Internal.Fake + ( CASRef, casIORef, ptrEq, +   atomicModifyIORefCAS, atomicModifyIORefCAS_ + )+ where ++import Data.IORef+import Data.CAS.Internal.Class+import Debug.Trace+import System.Mem.StableName++--------------------------------------------------------------------------------++-- | The type of references supporting CAS.+newtype CASRef a = CR { unCR :: IORef a }++instance CASable CASRef a where +  newCASable x = newIORef x >>= (return . CR)+  readCASable  = readIORef  . unCR+  writeCASable = writeIORef . unCR+  cas          = casIORef   . unCR++--------------------------------------------------------------------------------++{-# NOINLINE casIORef #-}+-- TEMP -- A non-CAS based version.  Alas, this has UNDEFINED BEHAVIOR+-- (see ptrEq).+-- +--  casIORef :: Eq a => IORef a -> a -> a -> IO (Bool,a)+casIORef :: IORef a -> a -> a -> IO (Bool,a)+-- casIORef r !old !new =   +casIORef r old new = do   +  atomicModifyIORef r $ \val -> +{-+    trace ("    DBG: INSIDE ATOMIC MODIFY, ptr eqs found/expected: " ++ +	   show [ptrEq val old, ptrEq val old, ptrEq val old] ++ +	   " ptr eq self: " ++ +	   show [ptrEq val val, ptrEq old old] +++	   " names: " ++ show (unsafeName old, unsafeName old, unsafeName val, unsafeName val)+	  ) $+-}+    if   (ptrEq val old)+    then (new, (True, val))+    else (val, (False,val))++atomicModifyIORefCAS  = atomicModifyIORef+atomicModifyIORefCAS_ = atomicModifyIORef_++atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ()))+
+ Data/CAS/Internal/Foreign.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, MagicHash,+    TypeFamilies, MultiParamTypeClasses, OverlappingInstances, +    BangPatterns, CPP #-}++++-- | This is a version of CAS that works outside of Haskell by using+--   the FFI (and the GCC intrinsics-based 'Data.Bits.Atomic'.)++module Data.CAS.Internal.Foreign + ( +   CASRef+   -- Plus instance...+ )+ where ++import Control.Monad+import Data.Bits.Atomic+import Data.IORef+import Data.Word+import Foreign.Storable+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Foreign.Marshal.Alloc (malloc)+import qualified Foreign.Concurrent as FC+import Text.Printf+import Unsafe.Coerce++import Data.CAS.Internal.Class++-- Convenient overlapping instances of CASable are possible at the at+-- the cost of a runtime dispatch on CASRef representations.  (Compile+-- time dispatch is not possible due to impossibility of overlapping+-- instances with associated type families.)+data CASRef a = +   Frgn (Ptr a)+ | Hskl (ForeignPtr (StablePtr a))++--------------------------------------------------------------------------------+#if 1+-- | EXAMPLE SPECIALIZATION: a more efficient implementation for simple scalars.+-- +--   Boilerplate TODO: We Should have one of these for all word-sized Scalar types.+-- +instance CASable CASRef Word32 where +-- -- We would LIKE to do this for everything in the Storable class:+-- instance (Storable a,  AtomicBits a) => CASable a where +--+--  newtype CASRef a = Frgn (Ptr a)+--  newtype CASRef Word32 = Frgn (Ptr Word32)+  newCASable val = do +    ptr <- malloc +    poke ptr val+    return (Frgn ptr)++  writeCASable (Frgn ptr) val = poke ptr val++  readCASable (Frgn ptr) = peek ptr ++  {-# NOINLINE cas #-}+  cas (Frgn ptr) old new = do +#  if 1+   -- I'm having problems with this version.  The ptrEq will report False even when the swap succeeds.+   -- I think the FFI unmarshalling the result ends up creating an extra copy.+--    orig <- compareAndSwap ptr old new +--    printf "Completed swaps orig %d (%d) and old %d (%d)\n" orig (unsafeName orig) old (unsafeName old)+--    return (ptrEq orig old, orig)++   -- BUT, since it's a Word32 it is ok NOT to use pointer equality here.+   orig <- compareAndSwap ptr old new +   return (orig == old, orig)++#  else+   -- ERROR: Trying this incorrect HACK version for a moment:+   -- This version will allow a return value of (False,old)+   snap <- peek ptr+   b <- compareAndSwapBool ptr old new +   if b +    then return (True, old)+    else return (False, snap)+#  endif++#endif++--------------------------------------------------------------------------------+#if 0+-- | INEFFICENT but safe implementation for arbitrary Haskell values.+--   This version uses StablePtr's to store Haskell values in foreign storage.+-- +-- This should NOT be useful for implementing efficient data+-- strcuctures because it itself dependends on concurrent access to+-- the GHC runtimes table of pinned StablePtr values.+instance CASable CASRef a where +--  newtype CASRef a = Hskl (StablePtr a)++  newCASable val = do +    -- Here we create a storage cell outside the Haskel heap which in+    -- turn contains a pointer back into the Haskell heap.+    p   <- newStablePtr val+--    mem <- malloc+--    poke mem p +--    fp <- FC.newForeignPtr (castPtr$ castStablePtrToPtr p) (freeStablePtr p)    ++    -- Here we assume that when we let go of the reference that we+    -- free whatever StablePtr is contained in it at the time.+    -- fp <- FC.newForeignPtr mem $ +          -- There should be no races for this finalizer becuase all+          -- Haskell threads have let go of the foreign pointer:+--          do curp <- withForeignPtr fp peek +--	     freeStablePtr curp+    fp <- mallocForeignPtr+    withForeignPtr fp (`poke` p)+    FC.addForeignPtrFinalizer fp $+         do putStrLn$ "EXPECTATION INVALVIDATED: CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!"+	    -- Todo... week pointer here.+            curp <- withForeignPtr fp peek +	    freeStablePtr curp++    return (Hskl fp)++  readCASable (Hskl ptr) = withForeignPtr ptr (\p -> peek p >>= deRefStablePtr)++  -- We must use CAS for ALL writes to ensure that we issue+  -- freeStablePtr for every value that gets bumped out of the foreign+  -- storage cell.+  writeCASable c val = readCASable c >>= loop+   where+    -- Hard spin: TODO add some contention back-off.+    loop x = do (b,v) <- cas c x val+		unless b (loop v)++  cas c@(Hskl ptr) old new = withForeignPtr ptr $ \ rawP -> +    -- TODO: if we add an AtomicBits instance for StablePtr we can avoid these unsafe coercions+    do +       osp <- newStablePtr old+       nsp <- newStablePtr new+       let oldRawPtr = unsafeCoerce osp :: Word+	   castP     = castPtr rawP :: Ptr Word+       orig <- compareAndSwap castP oldRawPtr (unsafeCoerce nsp)+       let fired = orig == oldRawPtr+           -- Restore the value we got back to its real type:+	   orig' = if True then unsafeCoerce orig else osp++       -- FIXME There's a problem here.  What if we put the same+       -- object in multiple CASRef's?  newStablePtr seems to return+       -- the same thing if called multiple times.++       orig'' <- deRefStablePtr orig'+       when fired $ freeStablePtr orig'+       return (fired, orig'')+       +#endif+++----------------------------------------------------------------------------------------------------+-- Helpers:
+ IORefCAS.cabal view
@@ -0,0 +1,50 @@+Name:                IORefCAS+Version:             0.0.1+License:             BSD3+License-file:        LICENSE+Author:              Adam C. Foltzer, Ryan Newton+Maintainer:          acfoltzer@gmail.com, rrnewton@gmail.com+Category:            Data+Build-type:          Simple+Cabal-version:       >=1.8++Synopsis: Atomic compare and swap for IORefs and CASRefs.++Description:++  After GHC 7.2 a new `casMutVar#` primop became available, but was+  not yet exposed in Data.IORef.  This package fills that gap until+  such a time as Data.IORef obsoletes it.+ .+  Further, in addition to exposing native Haskell CAS operations, this+  package contains \"mockups\" that imititate the same functionality+  using either atomicModifyIORef and unsafe pointer equality (in+  @Data.CAS.Fake@) or using foreign functions (@Data.CAS.Foreign@).+  These alternatives are useful for debugging.+  .+  Note that the foreign option does not operate on IORefs and so is+  directly interchangeable with `Data.CAS` and `Data.CAS.Fake` only if+  the interface in `Data.CAS.Class` is used.++Extra-Source-Files:+                     Makefile, Test.hs++Library+  exposed-modules:   Data.CAS,+                     Data.CAS.Internal.Class,+                     Data.CAS.Internal.Fake,+                     Data.CAS.Internal.Foreign+  build-depends:     base >= 4.4.0.0 && < 5,+                     ghc-prim, bits-atomic+++-- Executable +Test-Suite test-IORefCAS+    type:       exitcode-stdio-1.0+    main-is:    Test.hs+    ghc-options: -O2 -threaded -rtsopts +    cpp-options: -DT1 -DT2 -DT3+    build-depends: QuickCheck, HUnit, bits-atomic+-- TODO: Refactor to use test-framework:+--                 , test-framework, test-framework-hunit+-- test-framework-quickcheck2
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Adam C. Foltzer++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Adam C. Foltzer nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,12 @@+++++all:+	ghc -DT1 -O2 --make Test.hs -o t1.exe  -threaded -rtsopts+	ghc -DT2 -O2 --make Test.hs -o t2.exe  -threaded -rtsopts+	ghc -DT3 -O2 --make Test.hs -o t3.exe  -threaded -rtsopts+	ghc -DT1 -DT2 -DT3 -O2 --make Test.hs -o all.exe  -threaded -rtsopts++clean:+	rm -f *.exe *.hi *.o
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, CPP, BangPatterns, OverlappingInstances +    , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances+  #-}+++-- | This test has three different modes which can be toggled via ++import Control.Monad+import Control.Exception+import Control.Concurrent.MVar+import GHC.Conc+import Data.IORef+import Data.Word+import Data.CAS.Internal.Class+import Data.Time.Clock+import System.Environment+import System.Mem.StableName+import GHC.IO (unsafePerformIO)++#ifdef T1+import qualified Data.CAS         as A+#endif+#ifdef T2+import qualified Data.CAS.Internal.Fake    as B+#endif+#ifdef T3+import qualified Data.CAS.Internal.Foreign as C+#endif++import Text.Printf++----------------------------------------------------------------------------------------------------+-- TODO:+--  * Switch the [Bool] implementation to use a BitList.+--  +----------------------------------------------------------------------------------------------------++{-# NOINLINE zer #-}+zer = 0++-- iters = 100+-- iters = 10000+default_iters = 100000+-- iters = 1000000++----------------------------------------------------------------------------------------------------+-- Helpers++printBits = print . map pb+ where pb True  = '1' +       pb False = '0'++forkJoin :: Int -> (IO b) -> IO [b]+forkJoin numthreads action = +  do+     answers <- sequence (replicate numthreads newEmptyMVar) -- padding?+     printf "Forking %d threads.\n" numthreads+    +     forM_ answers $ \ mv -> + 	forkIO (action >>= putMVar mv)++     -- Reading answers:+     ls <- mapM readMVar answers+     printf "All %d thread(s) completed\n" numthreads+     return ls++-- Describe a structure of forking and joining threads for tests:+data Forkable a = Fork Int (IO a)+                | Parallel (Forkable a) (Forkable a) -- Parallel composition+                | Sequence (Forkable a) (Forkable a) -- Sequential compositon, with barrier+--                | Barrier Forkable+++timeit ioact = do +   start <- getCurrentTime+   res <- ioact+   end   <- getCurrentTime+   putStrLn$ "  Time elapsed: " ++ show (diffUTCTime end start)+   return res++----------------------------------------------------------------------------------------------------++-- The element type for our CAS test.+-- type ElemTy = Int+type ElemTy = Word32 -- This will trigger CAS.Foreign's specialization.++{-# INLINE testCAS1 #-}+testCAS1 :: CASable ref ElemTy => ref ElemTy -> IO [Bool]+testCAS1 r = +  do +     bitls <- newIORef []+--     let zer = (0::Int)++--     r :: CASRef Int <- newCASable zer +     let loop 0 = return ()+	 loop n = do++          (b,v) <- cas r zer 100  -- Must use "zer" here.+          atomicModifyIORef bitls (\x -> (b:x, ()))++--          (b,v) <- casIORef r zer 100  -- Must use "zer" here.+--          (b,v) <- casStrict r 0 100  -- Otherwise this is nondeterministic based on compiler opts.+		   -- Sometimes the latter version works on the SECOND evaluation of testCAS.  Interesting.+          putStrLn$ "  After CAS " ++ show (b,v)+          loop (n-1)+     loop 10++     x <- readCASable r+     putStrLn$ "  Finished with loop, read cell: " ++ show x+     writeCASable r 111+     y <- readCASable r+     putStrLn$ "  Wrote and read again read: " ++ show y++     ls <- readIORef bitls+     return (reverse ls)++----------------------------------------------------------------------------------------------------++-- UNFINISHED, TODO:+-- This version hammers on CASref from all threads, then checks to see+-- if enough threads succeeded enough of the time.++-- If each thread tries K attempts, there should be at least K+-- successes.  To establish this consider the inductive argument.  One+-- thread should succeed all the time.  Adding a second thread can+-- only foil the K attempts of the first thread by itself succeeding+-- (leaving the total at or above K).  Likewise for the third thread+-- and so on.++-- Conversely, for N threads each aiming to complete K operations,+-- there should be at most N*N*K total operations required.++testCAS2 :: CASable ref ElemTy => Int -> ref ElemTy -> IO [[Bool]]+testCAS2 iters ref = +  forkJoin numCapabilities $ +    do +       let loop 0 expected !acc = return (reverse acc)+	   loop n expected !acc = do+            -- let bumped = expected+1 -- Must do this only once, should be NOINLINE+	    bumped <- evaluate$ expected+1 +	    (b,v) <- cas ref expected bumped+            when (iters < 30) $ +              putStrLn$ "  Attempted to CAS "++show bumped ++" for "++ show expected ++ " (#"++show (unsafeName expected)++"): " +			++ show b ++ " found " ++ show v ++ " (#"++show (unsafeName v)++")"+	    if b +             then loop (n-1) bumped (b:acc)+             else loop (n-1) v      (b:acc)++       init <- readCASable ref+       loop iters init []+++--------------------------------------------------------------------------------++-- This tests repeated atomicModifyIORefCAS operations.++testCAS3 :: Int -> IORef ElemTy -> IO [()]+testCAS3 iters ref = +  forkJoin numCapabilities (loop iters)+ where +   loop 0  = return ()+   loop n  = do+	-- let bumped = expected+1 -- Must do this only once, should be NOINLINE+--        let bump !x !y = x+y+#ifdef T1+	A.atomicModifyIORefCAS_ ref (+1)+#endif+#ifdef T2+--	B.atomicModifyIORefCAS_ ref (+1)+--	B.atomicModifyIORefCAS_ ref (bump 1)+	x <- atomicModifyIORef ref (\x -> (x+1,x))+        evaluate x -- Avoid stack leak.+#endif+	loop (n-1)++       +++----------------------------------------------------------------------------------------------------+-- Test Oracles++checkOutput1 msg ls =+  if ls == True : replicate (9) False+  then return ()+  else error$ "Test "++ msg ++ " failed to have the right CAS success pattern: " ++ show ls++checkOutput2 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()+checkOutput2 msg iters ls fin = do +  let totalAttempts = sum $ map length ls+  putStrLn$ "Final value "++show fin++", Total successes "++ show (length $ filter id $ concat ls)+  when (fin < fromIntegral iters) $+    error$ "ERROR in "++ show msg ++ " expected at least "++show iters++" successful CAS's.." ++checkOutput3 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()+checkOutput3 msg iters ls fin = do ++  return ()+++----------------------------------------------------------------------------------------------------++main = do +   args <- getArgs+   let iters = +        case args of +	 []  -> default_iters+	 [a] -> read a+	 ls  -> error$ "Wrong number of arguments to executable: " ++ show ls+ +#ifdef T1+   putStrLn$ "\nTesting Raw, native CAS:"+   o1A <- (newCASable zer :: IO (A.CASRef ElemTy)) >>= testCAS1+   checkOutput1 "Raw 1"     o1A+#endif+#ifdef T2+   putStrLn$ "\nTesting Fake CAS, based on atomicModifyIORef:"+   o1B <- (newCASable zer :: IO (B.CASRef ElemTy)) >>= testCAS1+   checkOutput1 "Fake 1"    o1B+#endif+#ifdef T3+   putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"+--   o1C <- (newCASable zer :: IO (C.CASRef ElemTy)) >>= testCAS1+   o1C <- (newCASable zer :: IO (C.CASRef ElemTy)) >>= testCAS1+   checkOutput1 "Foreign 1" o1C+#endif++   ------------------------------------------------------------++#ifdef T1+   putStrLn$ "\nTesting Raw, native CAS:"+   ref   <- newCASable zer :: IO (A.CASRef ElemTy)+   o2A   <- timeit$ testCAS2 iters ref+   mapM_ (printBits . take 100) o2A+   fin2A <- readCASable ref+   checkOutput2 "Raw 1"     iters o2A fin2A+#endif+#ifdef T2+   putStrLn$ "\nTesting Fake CAS, based on atomicModifyIORef:"+   ref   <- newCASable zer :: IO (B.CASRef ElemTy)+   o2B   <- timeit$ testCAS2 iters ref+   mapM_ (printBits . take 100) o2B+   fin2B <- readCASable ref+   checkOutput2 "Fake 1"    iters o2B fin2B+#endif+#ifdef T3+   putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"+   ref   <- newCASable zer :: IO (C.CASRef ElemTy)+   o2C   <- timeit$ testCAS2 iters ref+   mapM_ (printBits . take 100) o2C+   fin2C <- readCASable ref+   checkOutput2 "Foreign 1" iters o2C fin2C+#endif++   ------------------------------------------------------------++#ifdef T1+   putStrLn$ "\nTesting atomicModifyIORefCAS, native CAS:"+--   ref   <- newCASable zer :: IO (A.CASRef ElemTy)+   ref   <- newIORef zer :: IO (IORef ElemTy)+   o3A   <- timeit$ testCAS3 iters ref+--   mapM_ (printBits . take 100) o3A+--   fin3A <- readCASable ref+   fin3A <- readIORef ref+--   checkOutput3 "Raw 2"     iters o3A fin3A+   putStrLn$ "  Final sum: "++ show fin3A+#endif+#ifdef T2+   putStrLn$ "\nTesting atomicModifyIORefCAS:"+--   ref   <- newCASable zer :: IO (B.CASRef ElemTy)+   ref   <- newIORef zer :: IO (IORef ElemTy)+   o3B   <- timeit$ testCAS3 iters ref+--   mapM_ (printBits . take 100) o3B+--   fin3B <- readCASable ref+   fin3B <- readIORef ref+--   checkOutput3 "Fake 2"    iters o3B fin3B+   putStrLn$ "  Final sum: "++ show fin3B+#endif+-- #ifdef T3+--    putStrLn$ "\nTesting Foreign CAS, using mutable cells outside of the Haskell heap:"+--    ref   <- newCASable zer :: IO (C.CASRef ElemTy)+--    o3C   <- testCAS3 iters ref+--    mapM_ (printBits . take 100) o3C+--    fin3C <- readCASable ref+--    checkOutput3 "Foreign 1" iters o3C fin3C+-- #endif++   ------------------------------------------------------------++   putStrLn$ "\nAll test outputs looked good."+++{-+  [2011.11.10] ++Well... just got this output from the WRONG test:++"1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"+"1010101010101010101010101010101010101010101010101010101010101010101010010010100100101010101001001001"+CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!+"0101010101010100010101010101010101010101010101010101010101010101010101010101010101010101010101010101"+"0100010010001001001001001010101010101001010101010101010101010101010101010101010101001010101010101010"++The first problem is that this indicates a bug, the second is that it's coming from the WRONG PLACE.++Let me be more specific.  I'm testing three versions.  On Mac OS I see+the failure in the Foreign.hs, which is where the error message is+located and where it's coming from!++     Testing Raw, native CAS:+     Forking 2 threads.+     All threads 2 completed+     "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"+     "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"++     Testing Fake CAS, based on atomicModifyIORef:+     Forking 2 threads.+     All threads 2 completed+     "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"+     "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"++     Testing Foreign CAS, using mutable cells outside of the Haskell heap:+     Forking 2 threads.+     All threads 2 completed+     CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!+     "1010101010101010101010101010101010101010101010101010101010101010101010101001001001001001001001001001"+     "0100100100100100100100100100101010101010101010101010101010101010101010101010101010101010101010101010"++But on Linux I see this error coming from the test for A.CASRef!++    Testing Raw, native CAS:+    Forking 4 threads.+    All threads 4 completed+    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"+    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"+    CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!+    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"+    "1010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010101010"++    Testing Fake CAS, based on atomicModifyIORef:+    Forking 4 threads.+    All threads 4 completed+    "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"+    "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"+    "1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"+    "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"++    Testing Foreign CAS, using mutable cells outside of the Haskell heap:+    Forking 4 threads.+    All threads 4 completed+    "0010010100101000101010101000101010100101010010101010010100101010100000100100100010101010100101001010"+    "1010101010101010100001000101001010010101000100101010000001000010000100010000001000000001000001010001"+    "0010010010000010000000010000000000010000100001000100101001010001000100100010010010101001001010001001"+    "0010101010100100101001000100101000001000100001000100100010001001010101010101010101010101010101010101"+    Final value 200, Total successes 200+    Final value 2, Total successes 2+    test.exe: ERROR in "Fake 1" expected at least 100 successful CAS's..++As though the instances are getting mixed up or selected in a nondeterministic way.++A.CASRef B.CASRef and C.CASRef should be unique types which do not unify with one another....++If I pump up the numbers I start seeing segfaults, which appear to be+coming from the foreign version but I think that's just because they get swapped!...++OR it's possible that I'm being silly and that I have not put+sufficient barriers between the phases to FORCE all work to complete+and therefore all print messages to be printed out in order.++    Testing Foreign CAS, using mutable cells outside of the Haskell heap:+    Forking 4 threads.+    Segmentation fault++I'm ALSO seeing failures of insufficient successes on my laptop at iters=10K...++------------------------------------------------------------++Ok, going to attempt to tease this out by first testing only one implementation at a time:++  Data.CAS -- insufficient successes occasionally (10K), +              insufficient successes always (100K),+	      stack overflow for this test (1M)+++ -}++++-- test x = do+--   a <- newStablePtr x +--   b <- newStablePtr x +--   printf "First call, word %d IntPtr %d\n" +-- 	 (unsafeCoerce a :: Word)+-- 	 ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr a) :: Int)+--   printf "Second call, word %d IntPtr %d\n" +-- 	 (unsafeCoerce b :: Word)+-- 	 ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)+++-- main = test 3