atomic-primops (empty) → 0.1.0.0
raw patch · 10 files changed
+1216/−0 lines, 10 filesdep +basedep +ghc-primdep +primitivesetup-changed
Dependencies added: base, ghc-prim, primitive
Files
- DEVLOG.md +200/−0
- Data/Atomics.hs +137/−0
- Data/Atomics/Internal.hs +96/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- atomic-primops.cabal +63/−0
- cbits/primops.cmm +91/−0
- testing/Test.hs +562/−0
- testing/runTest.hs +13/−0
- testing/test-atomic-primops.cabal +22/−0
+ DEVLOG.md view
@@ -0,0 +1,200 @@+++[2013.04.07] {Figuring out install methods, linking, and segfaults}++Ok, here's the weird state of affairs at the moment.++ * Mac os, build test in-place compiling directly with Data.Atomics -- WORKS+ * mac os, cabal install then build test -- SEGFAULTS+ * linux, build test in-place compiling directly with Data.Atomics -- Fails link, no "cas".+ * linux, cabal install then build test -- WORKS (but I thought segfaulted earlier?++Weird, right? Well, I'm not surprised by the failed link, because+right now the foreign primops are trying to use a function defined in+SMP.h inside the GHC RTS. That may be illegitemate. (But at the same+time it is EXTERN_INLINE so shouldn't it just inline it before link+time?)++Note that SMP.h is included by Stg.h which is included by Rts.h.+Rts.h is included all over the place, but not directly by Cmm.h.++Anyway, putting in some extra printfs verifies that in the segfaulting+case it is returning a ticket of "zero" and in fact it is also+returning zero as a Haskell pointer because valgrind shows the+segfault as attempting to reference 0x0. Just to confirm, I see+similar behavior if I just hack the CMM to return an invalid pointer:++ stg_readMutVar2zh {+ RET_NP(19, 19);+ }++In fact, with the segfaulting Mac OS config... if I use the above,+hacked stg_readMutVar2zh, I DO see it receives a ticket 19. So it IS+calling the correct code.++WAIT! There's not much we can infer from the previous. Because, the+failure is odd and transient! Once I restored stg_readMutVar2zh to+the original, it is now passing in BOTH compile methods on Mac OS.+Further, it will happily run hundreds of time without segfaulting. So+it appears to be compile time nondeterminism rather than runtime ;-).++-----------------++AHA! It works when I build like this:++ cabal install --disable-library-profiling --disable-documentation+ +But NOT with a vanially cabal install (profiling and documentation).+As expected, it is the profiling that makes the difference.+Note that I am NOT building the test with profiling. The profiling+version should be IRRELEVANT. Why does this cause the segfault?++Well, if it is cabal installed WITH profiling, we can change the+error, at least, by changing how Test.exe is built. Building with no+options (without -threaded -O2) and we see a false positive with the+casArrayElem, then a segfault on the ticket-test:++ Perform a CAS within a MutableArray#+ (Poking at array was ok: 33)+ 1st try should succeed: (False,4377552852)+ 2nd should fail: (False,4377552852)+ Printing array:+ 33 33 33 33 33+ Done.++ casmutarray1: [OK]++ Using new 'ticket' based compare and swap:+ YAY, read the IORef, ticket 4382124888+ Test.exe: internal error: MUT_VAR_DIRTY object entered!+ (GHC version 7.6.2 for x86_64_apple_darwin)+ Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug++What if we actually DO build with profiling?++ ghc -prof -fforce-recomp Test.hs -o Test.exe+ + Test.hs:39:10:+ Dynamic linking required, but this is a non-standard build (eg. prof).+ You need to build the program twice: once the normal way, and then+ in the desired way using -osuf to set the object file suffix. ++Oops, I have to disable the use of test-framework-th and template+haskell it seems. I did that, and it builds and DOESN'T SEGFAULT. +So it's building WITHOUT profiling after installing with profiling+that breaks!!++[2013.04.08] {Further investigating}+------------------------------------++Ok, let's see what the chain of causation here is. HOW is it actually+picking up anything from those profiling installs if profiling is+disabled in the final build-and-link?++Here are the sizes of the relevant binaries on a profile compile:++ Summing ./lib/atomic-primops-0.1.0.0/ghc-7.6.2/HSatomic-primops-0.1.0.0.o+ 44,392 bytes in 1 plain files.+ Summing ./lib/atomic-primops-0.1.0.0/ghc-7.6.2/libHSatomic-primops-0.1.0.0.a+ 58,808 bytes in 1 plain files.+++The final link command issued to gcc says this:++ '-L/Users/rrnewton/.cabal/lib/atomic-primops-0.1.0.0/ghc-7.6.2' ...+ '-lHSatomic-primops-0.1.0.0'++There doesn't seem to be anything that would cause it to pull in the+"_p.a" version... How about I manually delete the "*p_*" files and+see what happens? Same behavior! It is NOT using those files+directly.++And, indeed, if I try to actually build the profiling version of+Test.exe then it fails to find Data.Atomics (presumably based on+failing to find the .p_hi file.)++How about a binary difference in the NON-profiling binaries? Here are+their sizes in the non-profiling (WORKING) build. YES, there are+binary differences:++ 44,336 bytes in 1 plain files.+ 58,752 bytes in 1 plain files.+ +How about with ghc-7.4.2?+-------------------------++ * Exact same pattern of behavior, segfaults with atomic-primops/prof Test.exe/noprof+ ++ +[2013.04.08] {Also trying HPC mode}+-----------------------------------++Under ghc-7.6.2, and installing with --enable-library-coverage, then+building Test.exe with -fhpc, it works on my Mac.++Also, note that the cabal driven test-suite is not working right now+on Mac or Linux.... I think it worked some before I moved it to the+testing/ subdir.++Having a completely separate .cabal for testing/... That works on Mac+and Linux subject to the above bug concerning profiling installs.++[2013.04.20] {Cabal-dev poor isolation}+---------------------------------------++I thought I could build different GHC versions in parallel (ghc-7.6.2,+ghc-7.4.2 etc). But it looks like they interfere. Further, even when+running serially I'm getting excessive rebuilding as I switch modes+(e.g. "make prof74" then "make prof76"). I need to add some isolation+of my own.+++[2013.04.20] {Debugging}++I fixed a major bug in the primop. I also verified that GC is what is+causing all_hammer_one to observe fewer successes than ideal.++Now it passes all tests, *some* of the time. Other times I see+segfaults on the all_hammer_one test with 10K iterations. The 10K+iteration one regularly sees GC's happen, whereas the 1K doesn't. Yet+it APPEARS that the segfault happens *before* the first GC (i.e. as+reported by "+RTS -T"). Is it GC itself that is crashing?++ [Nope ,this was the null pointer error - FIXED]++-----------------------++Ok, things are going pretty well. I've been running many tests with+7.4 and 7.6 that are passing completely. However, I just switched+focus back to the profiling version and got this:++ Installed testing-0.1.0.0+ ./cabal-dev/ghc-7.4.2_prof/bin/test-atomic-primops_ghc-7.4.2 +RTS -N -T -RTS+ test-atomic-primops_ghc-7.4.2: internal error: evacuate(static): strange closure type -385875961+ (GHC version 7.4.2 for x86_64_apple_darwin)+ Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug+ make[1]: *** [runtest] Abort trap: 6++On another run I got this:++ test-atomic-primops_ghc-7.4.2: internal error: MUT_VAR_DIRTY object entered!+ (GHC version 7.4.2 for x86_64_apple_darwin)+ Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug++And on 7.6 I got this:++ /cabal-dev/ghc-7.6.2_prof/bin/test-atomic-primops_ghc-7.6.2 +RTS -N -T -RTS+ test-atomic-primops_ghc-7.6.2: internal error: MVAR object entered!+ (GHC version 7.6.2 for x86_64_apple_darwin)+ Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug+ make[1]: *** [runtest] Abort trap: 6+ +Uh oh... it seems like there's been regression on the profiling version....++STRANGE -- it looks like it was based on extra double quotes in the args to GHC:++ cabal-dev install "-v --enable-library-profiling --ghc-options=-prof" -s cabal-dev/ghc-7.6.2_prof --disable-documentation --with-ghc=ghc-7.6.2 --program-suffix=_ghc-7.6.2 .+ +How did that cause it to compile and yet run with an internal failure?+
+ Data/Atomics.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables #-}++-- | Provides atomic memory operations on IORefs and Mutable Arrays.+--+-- Pointer equality need not be maintained by a Haskell compiler. For example, Int+-- values will frequently be boxed and unboxed, changing the pointer identity of+-- the thunk. To deal with this, the compare-and-swap (CAS) approach used in this+-- module is uses a /sealed/ representation of pointers into the Haskell heap+-- (`Tickets`). Currently, the user cannot coin new tickets, rather a `Ticket`+-- provides evidence of a past observation, and grants permission to make a future+-- change.+module Data.Atomics + (+ -- * Types for atomic operations+ Ticket, peekTicket, -- CASResult(..),++ -- * Atomic operations on mutable arrays+ casArrayElem, casArrayElem2, readArrayElem, ++ -- * Atomic operations on IORefs+ readForCAS, casIORef, casIORef2, + + -- * Atomic operations on raw MutVars+ readMutVarForCAS, casMutVar, casMutVar2+ + ) where++import Control.Monad.ST (stToIO)+import Data.Primitive.Array (MutableArray(MutableArray))+import Data.Atomics.Internal (casArray#, readForCAS#, casMutVarTicketed#, Ticket)+import Data.Int -- TEMPORARY++import Data.IORef+import GHC.IORef+import GHC.STRef+import GHC.ST+import GHC.Prim+import GHC.Arr +import GHC.Base (Int(I#))+import GHC.IO (IO(IO))+import GHC.Word (Word(W#))++--------------------------------------------------------------------------------++{-# INLINE casArrayElem #-}+-- | Compare-and-swap +casArrayElem :: MutableArray RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a)+-- casArrayElem (MutableArray arr#) (I# i#) old new = IO$ \s1# ->+-- case casArray# arr# i# old new s1# of +-- (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)+casArrayElem arr i old new = casArrayElem2 arr i old (seal new)++{-# INLINE casArrayElem2 #-} +-- | This variant takes two tickets: the 'new' value is a ticket rather than an+-- arbitrary, lifted, Haskell value.+casArrayElem2 :: MutableArray RealWorld a -> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)+casArrayElem2 (MutableArray arr#) (I# i#) old new = IO$ \s1# ->+ case casArray# arr# i# old new s1# of + (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)+++{-# INLINE readArrayElem #-}+readArrayElem :: forall a . MutableArray RealWorld a -> Int -> IO (Ticket a)+-- readArrayElem = unsafeCoerce# readArray#+readArrayElem (MutableArray arr#) (I# i#) = IO $ \ st -> unsafeCoerce# (fn st)+ where+ fn :: State# RealWorld -> (# State# RealWorld, a #)+ fn = readArray# arr# i#+++--------------------------------------------------------------------------------++{-# INLINE readForCAS #-}+readForCAS :: IORef a -> IO ( Ticket a )+readForCAS (IORef (STRef mv)) = readMutVarForCAS mv++{-# INLINE casIORef #-}+-- | 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'.+-- +-- Note \"compare\" here means pointer equality in the sense of+-- 'GHC.Prim.reallyUnsafePtrEquality#'.+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'+ -> Ticket a -- ^ A ticket for the 'old' value+ -> a -- ^ The 'new' value to replace 'current' if @old == current@+ -> IO (Bool, Ticket a)+casIORef (IORef (STRef var)) old new = casMutVar var old new +++{-# INLINE casIORef2 #-}+-- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an+-- arbitrary, lifted, Haskell value.+casIORef2 :: IORef a + -> Ticket a -- ^ A ticket for the 'old' value+ -> Ticket a -- ^ A ticket for the 'new' value+ -> IO (Bool, Ticket a)+casIORef2 (IORef (STRef var)) old new = casMutVar2 var old new +++--------------------------------------------------------------------------------++-- | A ticket contains or can get the usable Haskell value.+peekTicket :: Ticket a -> a +peekTicket = unsafeCoerce#++-- Not exposing this for now. Presently the idea is that you must read from the+-- mutable data structure itself to get a ticket.+seal :: a -> Ticket a +seal = unsafeCoerce#+++{-# INLINE readMutVarForCAS #-}+readMutVarForCAS :: MutVar# RealWorld a -> IO ( Ticket a )+readMutVarForCAS !mv = IO$ \ st -> readForCAS# mv st+++-- | MutVar counterpart of `casIORef`.+--+casMutVar :: MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)+casMutVar !mv !tick !new = casMutVar2 mv tick (seal new)+{-# INLINE casMutVar #-}+++-- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an+-- arbitrary, lifted, Haskell value.+casMutVar2 :: MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)+casMutVar2 !mv !tick !new = IO$ \st -> + case casMutVarTicketed# mv tick new st of + (# st, flag, tick' #) ->+ (# st, (flag ==# 0#, tick') #)+-- (# st, if flag ==# 0# then Succeed tick' else Fail tick' #)+-- if flag ==# 0# then else (# st, Fail (W# tick') #)+{-# INLINE casMutVar2 #-}+++
+ Data/Atomics/Internal.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP, TypeSynonymInstances, BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, MagicHash, UnboxedTuples, UnliftedFFITypes #-}++-- | This module provides only the raw primops (and necessary types) for atomic+-- operations. +module Data.Atomics.Internal + (casArray#, + readForCAS#, casMutVarTicketed#, + Ticket )+ where ++import GHC.Base (Int(I#))+import GHC.Word (Word(W#))+import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, unsafeCoerce#, MutVar#, reallyUnsafePtrEquality#) +#if MIN_VERSION_base(4,6,0)+-- Any is only in GHC 7.6!!! We want 7.4 support.+import GHC.Prim (readMutVar#, casMutVar#, Any)+#else+#error "Need to figure out how to emulate Any () in GHC 7.4."+-- type Any a = Word#+#endif ++--------------------------------------------------------------------------------+-- Entrypoints for end-users+--------------------------------------------------------------------------------++{-# INLINE casArray# #-}+-- | Unsafe, machine-level atomic compare and swap on an element within an Array. +casArray# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a + -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)+casArray# = unsafeCoerce# casArrayTypeErased#+++-- | When performing compare-and-swaps, the /ticket/ encapsulates proof+-- that a thread observed a specific previous value of a mutable+-- variable. It is provided in lieu of the "old" value to+-- compare-and-swap.+type Ticket a = Any a+-- If we allow tickets to be a pointer type, then the garbage collector will update+-- the pointer when the object moves.++#if 0+-- This technique is UNSAFE. False negatives are tolerable, but it may also+-- introduce the possibility of false positives.+type Ticket = Word+type Ticket# = Word# +#endif++instance Show (Ticket a) where+ show _ = "<CAS_ticket>"+++{-# NOINLINE ptrEq #-}+ptrEq :: a -> a -> Bool+ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1++instance Eq (Ticket a) where+ (==) = ptrEq++--------------------------------------------------------------------------------+++{-# INLINE readForCAS# #-}+readForCAS# :: MutVar# RealWorld a ->+ State# RealWorld -> (# State# RealWorld, Ticket a #)+readForCAS# = unsafeCoerce# readMutVar#+-- readForCAS# = unsafeCoerce# readMutVar_TypeErased#++{-# INLINE casMutVarTicketed# #-}+casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a ->+ State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)+casMutVarTicketed# = unsafeCoerce# casMutVar_TypeErased#+-- casMutVarTicketed# = unsafeCoerce# casMutVar#++--------------------------------------------------------------------------------+-- Type-erased versions that call the raw foreign primops:+--------------------------------------------------------------------------------+-- Due to limitations of the "foreign import prim" mechanism, we can't use the+-- polymorphic signature for the below functions. So we lie to the type system+-- instead.++foreign import prim "stg_casArrayzh" casArrayTypeErased#+ :: MutableArray# RealWorld () -> Int# -> Any () -> Any () -> + State# RealWorld -> (# State# RealWorld, Int#, Any () #) +-- out_of_line = True+-- has_side_effects = True++-- | This alternate version of casMutVar returns a numeric "ticket" for+-- future CAS operations.+foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#+ :: MutVar# RealWorld () -> Any () -> Any () ->+ State# RealWorld -> (# State# RealWorld, Int#, Any () #)++-- foreign import prim "stg_readMutVar2zh" readMutVar_TypeErased#+-- :: MutVar# RealWorld () -> +-- State# RealWorld -> (# State# RealWorld, Any () #)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012-2013, Ryan R. Newton++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 Ryan R. Newton 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ atomic-primops.cabal view
@@ -0,0 +1,63 @@+Name: atomic-primops+Version: 0.1.0.0+License: BSD3+License-file: LICENSE+Author: Ryan Newton+Maintainer: rrnewton@gmail.com+Category: Data+Stability: Provisional+-- Portability: non-portabile (x86_64)+Build-type: Simple+Cabal-version: >=1.8+HomePage: https://github.com/rrnewton/haskell-lockfree-queue/wiki++-- Version History:+-- 0.1.0.0 -- initial release+++Synopsis: A safe approach to CAS and other atomic ops in Haskell.++Description:++ After GHC 7.4 a new `casMutVar#` primop became available, but it's+ difficult to use safely, because pointer equality is a highly+ unstable property in Haskell. This library provides a safer method+ based on the concept of "Tickets".+ .+ Also, this library uses the "foreign primop" capability of GHC to+ add access to other variants that may be of+ interest, specifically, compare and swap inside an array.++Extra-Source-Files: DEVLOG.md,+ testing/runTest.hs, testing/Test.hs, testing/test-atomic-primops.cabal+-- Makefile, Test.hs, README.md++Library+ exposed-modules: Data.Atomics+ Data.Atomics.Internal+ ghc-options: -O2 -funbox-strict-fields++ -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater+ -- (base 4.5 or greater).+ build-depends: base >= 4.5.0.0 && < 4.7, ghc-prim, primitive++ -- TODO: Try to push support back to 7.0:+ -- Ah, but if we don't USE casMutVar# in this package we are ok:+ -- build-depends: base >= 4.3, ghc-prim, primitive++ Include-Dirs: cbits+ C-Sources: cbits/primops.cmm+ CC-Options: -Wall++-- -- [2013.04.08] This isn't working presently:+-- -- I'm having problems with building it along with the library; see DEVLOG.+-- -- Switching to a separate package in ./testing/ +-- Test-Suite test-atomic-primops+-- type: exitcode-stdio-1.0+++Source-Repository head+ Type: git+ Location: git://github.com/rrnewton/haskell-lockfree-queue.git++
+ cbits/primops.cmm view
@@ -0,0 +1,91 @@++#include "Cmm.h"++// Duplicate some of the RTS here (CAS instruction).+// #include "RtsDup.h"++// #include "Cmm.h"+// Problems if we try this:+// #include "stg/SMP.h"+// #include "Rts.h"++// Defined in SMP.h: +// EXTERN_INLINE StgWord cas(StgVolatilePtr p, StgWord o, StgWord n);++add1Op+/* Int# -> Int# */+{+ W_ num;+ num = R1 + 1;+ RET_P(num);+}+++stg_casArrayzh+/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */+{+ W_ arr, p, ind, old, new, h, len;+ arr = R1; // anything else?+ ind = R2;+ old = R3;+ new = R4;++ p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);+ (h) = foreign "C" cas(p, old, new) [];+ + if (h != old) {+ // Failure, return what was there instead of 'old':+ RET_NP(1,h);+ } else {+ // Compare and Swap Succeeded:+ SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);+ len = StgMutArrPtrs_ptrs(arr);+ // The write barrier. We must write a byte into the mark table:+ I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;+ RET_NP(0,h);+ }+}+++// One difference from casMutVar# is that this version returns the NEW+// pointer in the case of success, NOT the old one.+stg_casMutVar2zh+ /* MutVar# s a -> Word# -> a -> State# s -> (# State#, Int#, a #) */+{+ W_ mv, old, new, h;+ // Calling convention: Up to 8 registers contain arguments.+ mv = R1;+ old = R2;+ new = R3;++ // The "cas" function from the C runtime abstracts over+ // platform/architecture differences. It returns the old value,+ // which, if equal to "old", means success.+ (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,+ old, new) [];+ if (h != old) {+ // Failure:+ RET_NP(1,h);+ } else {+ // Success means a mutation and thus GC write barrier:+ if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {+ foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];+ }+ // Return the NEW value as the ticket for next time.+ RET_NP(0,new);+ }+}+++// Takes a single input argument in R1:+stg_readMutVar2zh+/* MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, Word#, a #) */+{+ W_ mv, res;+ mv = R1;+ // Do the actual read:+ res = W_[mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var];+ RET_NP(res, res);+}+/* emitPrimOp [res] ReadMutVarOp [mutv] _ */+/* = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) */
+ testing/Test.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-}+-- {-# LANGUAGE TemplateHaskell #-}++-- | This test has three different modes which can be toggled via the+-- C preprocessor. Any subset of the three may be activated.++import Control.Monad+-- import Control.Monad.ST (stToIO)+import Control.Exception (evaluate)+import Control.Concurrent.MVar+import GHC.Conc+import Data.IORef (modifyIORef')+import Data.Int+import Data.Time.Clock+-- import System.Mem.StableName+-- import GHC.IO (unsafePerformIO)+import Text.Printf+-- import qualified GHC.Prim as P+-- import GHC.ST+import GHC.STRef+import GHC.IORef+import GHC.Stats (getGCStats, GCStats(..))+import Data.Primitive.Array+-- import Control.Monad+import Data.Word+import qualified Data.Set as S+import System.Random (randomIO, randomRIO)++import Data.Atomics as A+import Data.Atomics (casArrayElem, readArrayElem)++import Test.HUnit (Assertion, assertEqual, assertBool)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.HUnit (testCase)++-- import Text.Printf(fprintf)++import GHC.IO (unsafePerformIO)+import System.Mem (performGC)+import System.Mem.StableName (makeStableName, hashStableName)+import System.Environment (getEnvironment)+import System.IO (stdout, stderr, hPutStrLn, hFlush)+import Debug.Trace (trace)++-- import Test.Framework.TH (defaultMainGenerator)++------------------------------------------------------------------------++expect_false_positive_on_GC :: Bool+expect_false_positive_on_GC = False++getGCCount :: IO Int64 +getGCCount | expect_false_positive_on_GC = + do GCStats{numGcs} <- getGCStats+ return numGcs+ | otherwise = return 0+#if 1+-- main = $(defaultMainGenerator)+main :: IO ()+main = + defaultMain $ + [ testCase "casTicket1" case_casTicket1+ , testCase "create_and_read" case_create_and_read+ , testCase "create_and_mutate" case_create_and_mutate+ , testCase "create_and_mutate_twice" case_create_and_mutate_twice+ , testCase "n_threads_mutate" case_n_threads_mutate++ , testCase "test_succeed_once Int" (test_succeed_once (0::Int))+ , testCase "test_succeed_once Int64" (test_succeed_once (0::Int64))+ , testCase "test_succeed_once Word32" (test_succeed_once (0::Word32))+ , testCase "test_succeed_once Word16" (test_succeed_once (0::Word16))+ , testCase "test_succeed_once Word8" (test_succeed_once (0::Word8))+ ]+ +++ -- all_hammerConfigs (0::Int64)+ -- Test several configurations of this one:+ [ testCase ("test_all_hammer_one_"++show threads++"_"++show iters ++":")+ (test_all_hammer_one threads iters (0::Int))+ | threads <- [1 .. 2*numCapabilities]+ , iters <- [1, 10, 100, 1000, 10000, 100000, 500000]] +++ [ testCase ("test_hammer_many_threads_1000_10000:")+ (test_all_hammer_one 1000 10000 (0::Int)) ] ++++ [ testCase "casmutarray1" case_casmutarray1] +++ [ testCase ("test_random_array_comm_"++show threads++"_"++show size++"_"++show iters ++":")+ (test_random_array_comm threads size iters)+ | threads <- filter (>0) $ setify $+ [1, numCapabilities `quot` 2, numCapabilities, 2*numCapabilities]+ , size <- [1, 10, 100]+ , iters <- [10000]]+ +setify :: [Int] -> [Int]+setify = S.toList . S.fromList++#else+main = do+ test_all_hammer_one 1 10000 (0::Int)+ putStrLn "Test Done!"+#endif+------------------------------------------------------------------------+{-# NOINLINE mynum #-}+mynum :: Int+mynum = 33++-- Expected output: +{---------------------------------------+ Perform a CAS within a MutableArray#+ 1st try should succeed: (True,33)+ 2nd should fail: (False,44)+ Printing array:+ 33 33 33 44 33+ Done.+-}+case_casmutarray1 :: IO ()+case_casmutarray1 = do + putStrLn "Perform a CAS within a MutableArray#"+ arr <- newArray 5 mynum++ writeArray arr 4 33+ putStrLn "Wrote array elements..."+ + tick <- readArrayElem arr 4+ putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")"++ (res1,tick2) <- casArrayElem arr 3 tick 44+ (res2,_) <- casArrayElem arr 3 tick 44+-- res <- stToIO$ casArrayST arr 3 mynum 44+-- res2 <- stToIO$ casArrayST arr 3 mynum 44 ++ putStrLn "Printing array:"+ forM_ [0..4] $ \ i -> do+ x <- readArray arr i + putStr (" "++show x)++ assertBool "1st try should succeed: " res1+ assertBool "2nd should fail: " (not res2)+++-- | This test uses a number of producer and consumer threads which push and pop+-- elements from random positions in an array.+test_random_array_comm :: Int -> Int -> Int -> IO ()+test_random_array_comm threads size iters = do + arr <- newArray size Nothing+ tick0 <- readArrayElem arr 0+ for_ 1 size $ \ i -> do+ t2 <- readArrayElem arr i+ assertEqual "All initial Nothings in the array should be ticket-equal:" tick0 t2++ ls <- forkJoin threads $ \tid -> do + localAcc <- newIORef 0+ for_ 0 iters $ \iter -> do+ -- Randomly pick a position:+ ix <- randomRIO (0,size-1) :: IO Int+ -- Randomly either produce or consume:+ b <- randomIO :: IO Bool+ if b then do + (b,newtick) <- casArrayElem arr ix tick0 (Just iter)+ return ()+ else do -- Consume:+ tick <- readArrayElem arr ix+ case peekTicket tick of+ Just _ -> do (b,x) <- casArrayElem arr ix tick (peekTicket tick0) -- Set back to Nothing.+ when b $ modifyIORef' localAcc (+1)+-- print (peekTicket x)+ Nothing -> return ()+ return ()+ readIORef localAcc+ + let successes = sum ls+ -- Pidgeonhole principle.+ -- min_success =+ printf "Communication through random array positions (threads/size/iters %s).\n" (show (threads,size,iters))+ printf "Successes: %d (expected 1/4 of total iterations on all threads)\n" successes+ printf "Per-thread successes: %s\n" (show ls)+ assertBool "Number of successes: " (successes <= (threads * iters) `quot` 2 && successes >= 0)+ for_ 0 size $ \ i -> do+ x <- readArray arr i+-- putStr (show x ++ " ")+ return ()+ putStrLn ""+ return ()+ + +----------------------------------------------------------------------------------------------------+-- Simple, non-parameterized tests+ ----------------------------------------------------------------------------------------------------++{-# NOINLINE zer #-}+zer :: Int+zer = 0+default_iters :: Int+default_iters = 100000++case_casTicket1 :: IO ()+case_casTicket1 = do+ dbgPrint 1 "\nUsing new 'ticket' based compare and swap:"++ IORef (STRef mutvar) <- newIORef (3::Int) + tick <- A.readMutVarForCAS mutvar+ dbgPrint 1$"YAY, read the IORef, ticket "++show tick+ dbgPrint 1$" and the value was: "++show (peekTicket tick)++ (True,tick2) <- A.casMutVar mutvar tick 99 + dbgPrint 1$"Hoorah! Attempted compare and swap..."+-- dbgPrint 1$" Result was: "++show (True,tick2)++ dbgPrint 1$"Ok, next take a look at a SECOND CAS attempt, to see if the ticket from the first works..."+ res2 <- A.casMutVar mutvar tick2 12345678+ dbgPrint 1$"Result was: "++show res2+ +-- res <- A.casMutVar mutvar tick 99 + res3 <- A.readMutVarForCAS mutvar+ dbgPrint 1$"To check contents, did a SECOND read: "++show res3++ return ()++---- toddaaro's tests -----++case_create_and_read :: Assertion+case_create_and_read = do+ dbgPrint 1$ " Creating a single value and trying to read it."+ x <- newIORef (120::Int)+ valf <- readIORef x+ assertBool " Does x equal 120?" (valf == 120)++case_create_and_mutate :: Assertion+case_create_and_mutate = do+ dbgPrint 1$ " Creating a single 'ticket' based variable to use and mutating it once."+ x <- newIORef (5::Int)+ tick <- A.readForCAS(x)+ res <- A.casIORef x tick 120+ dbgPrint 1$ " Did setting it to 120 work?"+ dbgPrint 1$ " Result was: " ++ show res+ valf <- readIORef x+ assertBool "Does our x equal 120?" (valf == 120)++case_create_and_mutate_twice :: Assertion+case_create_and_mutate_twice = do+ dbgPrint 1$ " Creating a single 'ticket' based variable to mutate twice."+ x <- newIORef (0::Int)+ tick1 <- A.readForCAS(x)+ res1 <- A.casIORef x tick1 5+ tick2 <- A.readForCAS(x)+ res2 <- A.casIORef x tick2 120+ valf <- readIORef x+ assertBool "Does the value after the first mutate equal 5?" (peekTicket tick2 == 5)+ assertBool "Does the value after the second mutate equal 120?" (valf == 120)++case_n_threads_mutate :: Assertion+case_n_threads_mutate = do+ dbgPrint 1$ " Creating 120 threads and having each increment a counter value."+ counter <- newIORef (0::Int)+ let work :: IORef Int -> IO ()+ work = (\counter -> do+ tick <- A.readForCAS(counter)+ (b,_) <- A.casIORef counter tick (peekTicket tick + 1)+ unless b $ work counter)+ arr <- forkJoin 120 (\_ -> work counter) + ans <- readIORef counter+ assertBool "Did the sum end up equal to 120?" (ans == 120)++----------------------------------------------------------------------------------------------------++----------------------------------------------------------------------------------------------------+-- Adapted Old tests from original CAS library: +++-- | First test: Run a simple CAS a small number of times.+test_succeed_once :: (Show a, Num a, Eq a) => a -> Assertion+test_succeed_once n = + do+ performGC -- We *ASSUME* GC does not happen below.+ performGC -- We *ASSUME* GC does not happen below.+ checkGCStats+ gc1 <- getGCCount + r <- newIORef n+ bitls <- newIORef []+ tick1 <- A.readForCAS r+ let loop 0 = return ()+ loop n = do+ res <- A.casIORef r tick1 100+ atomicModifyIORef bitls (\x -> (res:x, ()))+-- putStrLn$ " CAS result: " ++ show res+ loop (n-1)+ loop 10++ x <- readIORef r+ assertEqual "Finished with loop, read cell: " 100 x+ + writeIORef r 111 + y <- readIORef r+ assertEqual "Wrote and read again read: " 111 y++ ls <- readIORef bitls+ let rev = (reverse ls)+ tickets = map snd rev+ (hd:tl) = map fst rev++ gc2 <- getGCCount+ if gc1 /= gc2+ then putStrLn " [skipped] test couldn't be assessed properly due to GC."+ else do + -- print scrubbed+ assertBool "Only first succeeds" (all (/= hd) tl)+ assertBool "All but first fail" (all (== head tl) (tail tl))+ assertEqual "First should succeed, rest fail"+ (hd : tl)+ (True : replicate 9 False)+++-- | 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 total 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.+test_all_hammer_one :: (Show a, Num a, Eq a) => Int -> Int -> a -> Assertion+test_all_hammer_one threads iters seed = do+ ref <- newIORef seed+ logs::[[Bool]] <- forkJoin threads $ \_ -> + do checkGCStats+ let loop 0 _ _ !acc = return (reverse acc)+ loop n !ticket !expected !acc = do+ -- This line will result in boxing/unboxing and using extra memory locations:+-- let bumped = expected + 1 + bumped <- evaluate$ expected + 1+ (res,tick) <- casIORef ref ticket bumped+ case res of+ True -> do+ when (iters < 30) $+ dbgPrint 1$ " Succeed CAS, old tick "++show ticket++" new "++show tick++", wrote "++show bumped+ loop (n-1) tick bumped (True:acc)+ False -> do+ let v = peekTicket tick+ when (iters < 30) $+ dbgPrint 1 $ + " Fizzled CAS with ticket: "++show ticket ++" containing "++show v+++ ", expected: "++ show expected +++ " (#"++show (unsafeName expected)++"): " + ++ " found " ++ show v ++ " (#"++show (unsafeName v)++", ticket "++show tick++")"+ loop (n-1) tick v (False:acc)++ tick0 <- readForCAS ref+ loop iters tick0 (peekTicket tick0) []++ numGcs <- getGCCount+ let successes = map (length . filter id) logs+ total_success = sum successes+ bool2char True = '1'+ bool2char False = '0'+ -- EACH thread may fail on a single GC (in theory)+ expected_success = iters - (threads * fromIntegral numGcs)+ msg = ("Runs "++show (map length logs)++" (GCs "++show numGcs++"), had enough successes?: "+ ++show successes++" >= "++ show expected_success ++"\n"+ ++(unlines $ map (dotdot 80 . (" "++) . map bool2char) logs) )+ dbgPrint 1 msg+ assertBool msg+ (total_success >= expected_success)+++----------------------------------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------------------------------++checkGCStats :: IO ()+checkGCStats = return ()+ -- do b <- getGCStatsEnabled+ -- unless b $ error "Cannot run tests without +RTS -T !!"++dotdot :: Int -> String -> String+dotdot len chars = + if length chars > len+ then take len chars ++ "..."+ else chars++printBits :: [Bool] -> IO ()+printBits = print . map pb+ where pb True = '1' + pb False = '0'++forkJoin :: Int -> (Int -> IO b) -> IO [b]+forkJoin numthreads action = + do+ answers <- sequence (replicate numthreads newEmptyMVar) -- padding?+ dbgPrint 1 $ printf "Forking %d threads.\n" numthreads+ + forM_ (zip [0..] answers) $ \ (ix,mv) -> + forkIO (action ix >>= putMVar mv)++ -- Reading answers:+ ls <- mapM readMVar answers+ dbgPrint 1 $ printf "All %d thread(s) completed\n" numthreads+ return ls++-- TODO: Here's an idea. Describe a structure of forking and joining threads for+-- tests, then we can stress test it by running different interleavings explicitly.+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 :: IO a -> IO a +timeit ioact = do + start <- getCurrentTime+ res <- ioact+ end <- getCurrentTime+ putStrLn$ " Time elapsed: " ++ show (diffUTCTime end start)+ return res++{-# NOINLINE unsafeName #-}+unsafeName :: a -> Int+unsafeName x = unsafePerformIO $ do + sn <- makeStableName x+ return (hashStableName sn)+++----------------------------------------------------------------------------------------------------+{-++-- UNFINISHED+-- 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)++---------------------------------------------------------------------------------------------------- +-- This version uses a non-scalar type for CAS. It instead+-- manipulates the tail pointers of a simple linked-list.++#if 0+data List k = Null | Cons Int (k (List k))++type ListA = List A.CASRef+type ListB = List B.CASRef+type ListC = List C.CASRef++-- testCAS4 :: CASable ref Int => List ref -> IO [Bool]+testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO ()+testCAS4 iters ref = do + forkJoin numCapabilities $ do+ -- From each thread, attempt to extend the list 'iters' times:+ ref' <- readCASable ref+ nl <- newIORef Null+ loop iters (Cons (-1) nl) ref'+ return ()++ return ()+ where + loop 0 _ _ = return ()+ loop n new (Cons _ tl) = do+ tl' <- readCASable tl+ case tl' of + Null -> do (b,v) <- cas tl tl' new+ if b then loop (n-1) v+ else loop v+ cons -> loop cons tl'+ loop n _ Null = error "too short"+#endif+++----------------------------------------------------------------------------------------------------+-- 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 ()+++----------------------------------------------------------------------------------------------------+++++-- 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+-}++++----------------------------------------------------------------------------------------------------+-- DEBUGGING+----------------------------------------------------------------------------------------------------++-- | Debugging flag shared by all accelerate-backend-kit modules.+-- This is activated by setting the environment variable DEBUG=1..5+dbg :: Int+dbg = case lookup "DEBUG" unsafeEnv of+ Nothing -> defaultDbg+ Just "" -> defaultDbg+ Just "0" -> defaultDbg+ Just s ->+ trace (" ! Responding to env Var: DEBUG="++s)$+ case reads s of+ ((n,_):_) -> n+ [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s++defaultDbg :: Int+defaultDbg = 0++unsafeEnv :: [(String,String)]+unsafeEnv = unsafePerformIO getEnvironment++-- | Print if the debug level is at or above a threshold.+dbgPrint :: Int -> String -> IO ()+dbgPrint lvl str = if dbg < lvl then return () else do+ hPutStrLn stderr str+ hFlush stderr++-- My own forM for numeric ranges (not requiring deforestation optimizations).+-- Inclusive start, exclusive end.+{-# INLINE for_ #-}+for_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+for_ start end _fn | start > end = error "for_: start is greater than end"+for_ start end fn = loop start+ where+ loop !i | i == end = return ()+ | otherwise = do fn i; loop (i+1)
+ testing/runTest.hs view
@@ -0,0 +1,13 @@++import GHC.Conc+import System.Process+import System.Exit++-- Run the testing executable with different thread settings.+main = do+-- p <- getNumProcessors+ putStrLn "[TestHarness] Calling compiled test-atomic-primops executable..."+ ExitSuccess <- system "./dist/build/test-atomic-primops/test-atomic-primops +RTS -N1"+ ExitSuccess <- system$"./dist/build/test-atomic-primops/test-atomic-primops +RTS -N"+-- ExitSuccess <- system$"./dist/build/test-atomic-primops/test-atomic-primops +RTS -N"++show p+ return ()
+ testing/test-atomic-primops.cabal view
@@ -0,0 +1,22 @@++-- Trying a completely separate .cabal for testing.++Name: test-atomic-primops+Version: 0.1.0.0+Build-type: Simple+Cabal-version: >=1.8++Executable test-atomic-primops+ main-is: Test.hs+ ghc-options: -O2 -threaded -rtsopts++ build-depends: base, ghc-prim, primitive, containers, random,+ -- For Testing:+ atomic-primops,+ time, HUnit, test-framework, test-framework-hunit+-- test-framework-th++Test-Suite test-atomic-primops-runner+ type: exitcode-stdio-1.0+ main-is: runTest.hs+ build-depends: base, process