diff options
Diffstat (limited to 'testsuite/tests/concurrent/prog003/CASList.hs')
| -rw-r--r-- | testsuite/tests/concurrent/prog003/CASList.hs | 254 |
1 files changed, 0 insertions, 254 deletions
diff --git a/testsuite/tests/concurrent/prog003/CASList.hs b/testsuite/tests/concurrent/prog003/CASList.hs deleted file mode 100644 index 0c4c7a0186..0000000000 --- a/testsuite/tests/concurrent/prog003/CASList.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE BangPatterns,CPP #-} -module CASList where - -import Control.Monad -import Data.IORef -import Control.Concurrent -import Control.Concurrent.Chan -import System.Environment -import Data.Time - --- #define USE_UNPACK --- #define USE_STRICT - -#if defined(USE_UNPACK) -#define UNPACK(p) {-# UNPACK #-} !(p) -#elif defined(USE_STRICT) -#define UNPACK(p) !(p) -#else -#define UNPACK(p) p -#endif - -data List a = Node { val :: a - , next :: UNPACK(IORef (List a)) } - | DelNode { next :: UNPACK(IORef (List a)) } - | Null - | Head { next :: UNPACK(IORef (List a)) } deriving Eq - -data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))), - tailList :: UNPACK(IORef (IORef (List a))) } - -{-# INLINE myNext #-} -myNext :: List a -> IORef (List a) -myNext Node{next = n} = n -myNext DelNode{next = n} = n -myNext Head{next = n} = n -myNext _ = error "myNext" - --- we assume a static head pointer, pointing to the first node which must be Head --- the deleted field of Head is always False, it's only there to make some of the code --- more uniform --- tail points to the last node which must be Null - - -type Iterator a = IORef (IORef (List a)) - - -------------------------------------------- --- auxiliary functions - - - -while b cmd = if b then do {cmd; while b cmd} - else return () - -repeatUntil cmd = do { b <- cmd; if b then return () - else repeatUntil cmd } - -atomCAS :: Eq a => IORef a -> a -> a -> IO Bool -atomCAS ptr old new = - atomicModifyIORef ptr (\ cur -> if cur == old - then (new, True) - else (cur, False)) - -atomicWrite :: IORef a -> a -> IO () -atomicWrite ptr x = - atomicModifyIORef ptr (\ _ -> (x,())) - - ----------------------------------------------- --- functions operating on lists - - --- we create a new list -newList :: IO (ListHandle a) -newList = - do null <- newIORef Null - hd <- newIORef (Head {next = null }) - hdPtr <- newIORef hd - tailPtr <- newIORef null - return (ListHandle {headList = hdPtr, tailList = tailPtr}) - - --- we add a new node, by overwriting the null tail node --- we only need to adjust tailList but not headList because --- of the static Head --- we return the location of the newly added node -addToTail :: Eq a => ListHandle a -> a -> IO () -addToTail (ListHandle {tailList = tailPtrPtr}) x = - do null <- newIORef Null - repeatUntil - (do tailPtr <- readIORef tailPtrPtr - b <- atomCAS tailPtr Null (Node {val = x, next = null}) - return b ) - -- we atomically update the tail - -- (by spinning on the tailPtr) - atomicWrite tailPtrPtr null - - -find :: Eq a => ListHandle a -> a -> IO Bool -find (ListHandle { headList = head }) x = - let go !prevPtr = - do prevNode <- readIORef prevPtr - let curPtr = myNext prevNode -- head/node/delnode have all next - curNode <- readIORef curPtr - case curNode of - Node {val = y, next = nextNode } -> - if (x == y) - then -- node found and alive - return True - else go curPtr -- continue - Null -> return False -- reached end of list - DelNode {next = nextNode } -> - -- atomically delete curNode by setting the next of prevNode to next of curNode - -- if this fails we simply move ahead - case prevNode of - Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode, - next = nextNode}) - if b then go prevPtr - else go curPtr - Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode}) - if b then go prevPtr - else go curPtr - DelNode {} -> go curPtr -- if parent deleted simply move ahead - {- - correct as well, but a deleted parent deleting a child is (for certain cases) a useless operation - do atomicModifyIORef prevPtr ( \ cur -> (cur{next = nextNode},True)) - go prevPtr - -} - - in do startPtr <- readIORef head - go startPtr - - - - -delete :: Eq a => ListHandle a -> a -> IO Bool -delete (ListHandle { headList = head }) x = - let go prevPtr = - do do prevNode <- readIORef prevPtr - let curPtr = next prevNode -- head/node/delnode have all next - curNode <- readIORef curPtr - case curNode of - Node {val = y, next = nextNode } -> - if (x == y) - then -- node found and alive - do b <- atomCAS curPtr curNode (DelNode {next = nextNode}) - if b then return True - else go prevPtr -- spin - else go curPtr -- continue - Null -> return False -- reached end of list - DelNode {next = nextNode } -> - -- atomically delete curNode by setting the next of prevNode to next of curNode - -- if this fails we simply move ahead - case prevNode of - Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode, - next = nextNode}) - if b then go prevPtr - else go curPtr - Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode}) - if b then go prevPtr - else go curPtr - DelNode {} -> go curPtr -- if parent deleted simply move ahead - - in do startPtr <- readIORef head - go startPtr - - - --- the iterator always points to the PREVIOUS node, --- recall that there's a static dummy new Head --- Assumption: iterators are private, --- ie they won't be shared among threads -newIterator :: ListHandle a -> IO (Iterator a) -newIterator (ListHandle {headList = hd}) = - do hdPtr <- readIORef hd - it <- newIORef hdPtr - return it - --- we iterate through the list and return the first "not deleted" node --- we delink deleted nodes --- there's no need to adjust headList, tailList --- cause headList has a static Head and --- tailList points to Null -iterateList :: Eq a => Iterator a -> IO (Maybe (IORef (List a))) -iterateList itPtrPtr = - let go prevPtr = - do do prevNode <- readIORef prevPtr - let curPtr = next prevNode -- head/node/delnode have all next - curNode <- readIORef curPtr - case curNode of - Node {} -> do writeIORef itPtrPtr curPtr - -- adjust iterator - return (Just curPtr) - Null -> return Nothing -- reached end of list - DelNode {next = nextNode} -> - -- atomically delete curNode by setting the next of prevNode to next of curNode - -- if this fails we simply move ahead - case prevNode of - Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode, - next = nextNode}) - if b then go prevPtr - else go curPtr - Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode}) - if b then go prevPtr - else go curPtr - DelNode {} -> go curPtr -- if parent deleted simply move ahead - - in do startPtr <- readIORef itPtrPtr - go startPtr - - ---printing and counting - -printList :: Show a => ListHandle a -> IO () -printList (ListHandle {headList = ptrPtr}) = - do startptr <- ( - do ptr <- readIORef ptrPtr - Head {next = startptr} <- readIORef ptr - return startptr) - printListHelp startptr - - -printListHelp :: Show a => IORef (List a) -> IO () -printListHelp curNodePtr = - do { curNode <- readIORef curNodePtr - ; case curNode of - Null -> putStr "Nil" - Node {val = curval, next = curnext} -> - do { putStr (show curval ++ " -> ") - ; printListHelp curnext } - DelNode {next = curnext} -> - do { putStr ("DEAD -> ") - ; printListHelp curnext } - } - -cntList :: Show a => ListHandle a -> IO Int -cntList (ListHandle {headList = ptrPtr}) = - do startptr <- ( - do ptr <- readIORef ptrPtr - Head {next = startptr} <- readIORef ptr - return startptr) - cntListHelp startptr 0 - - -cntListHelp :: Show a => IORef (List a) -> Int -> IO Int -cntListHelp curNodePtr i = - do { curNode <- readIORef curNodePtr - ; case curNode of - Null -> return i - Node {val = curval, next = curnext} -> - cntListHelp curnext (i+1) - DelNode {next = curnext} -> - cntListHelp curnext (i+1) - } |