{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, ScopedTypeVariables #-}
-- TypeFamilies, FlexibleInstances

-- | Michael and Scott lock-free, single-ended queues.
-- 
-- This is a straightforward implementation of classic Michael & Scott Queues.
-- Pseudocode for this algorithm can be found here:
-- 
--   <http://www.cs.rochester.edu/research/synchronization/pseudocode/queues.html>

-- Uncomment this if desired.  Needs more testing:
-- #define RECHECK_ASSUMPTIONS

module Data.Concurrent.Queue.MichaelScott
 (
   -- The convention here is to directly provide the concrete
   -- operations as well as providing the typeclass instances.
   LinkedQueue(), newQ, nullQ, pushL, tryPopR, 
 )
  where

import Data.IORef (readIORef, newIORef)
import System.IO (stderr)

#ifdef DEBUG
import Data.ByteString.Char8 (hPutStrLn, pack)
#endif

-- import GHC.Types (Word(W#))
import GHC.IORef(IORef(IORef))
import GHC.STRef(STRef(STRef))

import qualified Data.Concurrent.Deque.Class as C
import Data.Atomics (readForCAS, casIORef, Ticket, peekTicket)

-- GHC 7.8 changed some primops
import GHC.Base  hiding ((==#), sameMutVar#)
import GHC.Exts hiding ((==#), sameMutVar#)
import qualified GHC.Exts as Exts
(==#) :: Int# -> Int# -> Bool
==# :: Int# -> Int# -> Bool
(==#) Int#
x Int#
y = case Int#
x Int# -> Int# -> Int#
Exts.==# Int#
y of { Int#
0# -> Bool
False; Int#
_ -> Bool
True }

sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool
sameMutVar# :: forall s a. MutVar# s a -> MutVar# s a -> Bool
sameMutVar# MutVar# s a
x MutVar# s a
y = case forall d a. MutVar# d a -> MutVar# d a -> Int#
Exts.sameMutVar# MutVar# s a
x MutVar# s a
y of { Int#
0# -> Bool
False; Int#
_ -> Bool
True }


-- Considering using the Queue class definition:
-- import Data.MQueue.Class

data LinkedQueue a = LQ 
    { forall a. LinkedQueue a -> IORef (Pair a)
head :: {-# UNPACK #-} !(IORef (Pair a))
    , forall a. LinkedQueue a -> IORef (Pair a)
tail :: {-# UNPACK #-} !(IORef (Pair a))
    }

data Pair a = Null | Cons a {-# UNPACK #-}!(IORef (Pair a))

{-# INLINE pairEq #-}
-- | This only checks that the node type is the same and in the case of a Cons Pair
-- checks that the underlying MutVar#s are pointer-equal. This suffices to check
-- equality since each IORef is never used in multiple Pair values.
pairEq :: Pair a -> Pair a -> Bool
pairEq :: forall a. Pair a -> Pair a -> Bool
pairEq Pair a
Null       Pair a
Null        = Bool
True
pairEq (Cons a
_ (IORef (STRef MutVar# RealWorld (Pair a)
mv1)))
       (Cons a
_ (IORef (STRef MutVar# RealWorld (Pair a)
mv2))) = forall s a. MutVar# s a -> MutVar# s a -> Bool
sameMutVar# MutVar# RealWorld (Pair a)
mv1 MutVar# RealWorld (Pair a)
mv2
pairEq Pair a
_          Pair a
_           = Bool
False

-- | Push a new element onto the queue.  Because the queue can grow,
--   this always succeeds.
pushL :: forall a . LinkedQueue a -> a  -> IO ()
pushL :: forall a. LinkedQueue a -> a -> IO ()
pushL q :: LinkedQueue a
q@(LQ IORef (Pair a)
headPtr IORef (Pair a)
tailPtr) a
val = do
   IORef (Pair a)
r <- forall a. a -> IO (IORef a)
newIORef forall a. Pair a
Null
   let newp :: Pair a
newp = forall a. a -> IORef (Pair a) -> Pair a
Cons a
val IORef (Pair a)
r   -- Create the new cell that stores val.
       -- Enqueue loop: repeatedly read the tail pointer and attempt to extend the last pair.
       loop :: IO ()
       loop :: IO ()
loop = do 
        Ticket (Pair a)
tailTicket <- forall a. IORef a -> IO (Ticket a)
readForCAS IORef (Pair a)
tailPtr -- [Re]read the tailptr from the queue structure.
        case forall a. Ticket a -> a
peekTicket Ticket (Pair a)
tailTicket of
          -- The head and tail pointers should never themselves be NULL:
          Pair a
Null -> forall a. HasCallStack => [Char] -> a
error [Char]
"push: LinkedQueue invariants broken.  Internal error."
          Cons a
_ IORef (Pair a)
nextPtr -> do
             Ticket (Pair a)
nextTicket <- forall a. IORef a -> IO (Ticket a)
readForCAS IORef (Pair a)
nextPtr

     -- The algorithm can reread tailPtr here to make sure it is still good:
     -- [UPDATE: This is actually a necessary part of the algorithm's "hand-over-hand"
     --  locking, NOT an optimization.]
#ifdef RECHECK_ASSUMPTIONS
      -- There's a possibility for an infinite loop here with StableName based ptrEq.
      -- (And at one point I observed such an infinite loop.)
      -- But with one based on reallyUnsafePtrEquality# we should be ok.
             (tailTicket', tail') <- readForCAS tailPtr   -- ANDREAS: used atomicModifyIORef here
             if not (pairEq tail tail') then loop
              else case next of 
#else
             case forall a. Ticket a -> a
peekTicket Ticket (Pair a)
nextTicket of 
#endif
               -- Here tail points (or pointed!) to the last node.  Try to link our new node.
               Pair a
Null -> do (Bool
b,Ticket (Pair a)
newtick) <- forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef (Pair a)
nextPtr Ticket (Pair a)
nextTicket Pair a
newp
                          case Bool
b of 
                            Bool
True -> do 
                              --------------------Exit Loop------------------
                              -- After the loop, enqueue is done.  Try to swing the tail.
                              -- If we fail, that is ok.  Whoever came in after us deserves it.
                              (Bool, Ticket (Pair a))
_ <- forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef (Pair a)
tailPtr Ticket (Pair a)
tailTicket Pair a
newp
                              forall (m :: * -> *) a. Monad m => a -> m a
return ()
                              -----------------------------------------------
                            Bool
False -> IO ()
loop 
               nxt :: Pair a
nxt@(Cons a
_ IORef (Pair a)
_) -> do 
                  -- Someone has beat us by extending the tail.  Here we
                  -- might have to do some community service by updating the tail ptr.
                  (Bool, Ticket (Pair a))
_ <- forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef (Pair a)
tailPtr Ticket (Pair a)
tailTicket Pair a
nxt
                  IO ()
loop 

   IO ()
loop -- Start the loop.

-- Andreas's checked this invariant in several places
-- Check for: head /= tail, and head->next == NULL
checkInvariant :: String -> LinkedQueue a -> IO ()
checkInvariant :: forall a. [Char] -> LinkedQueue a -> IO ()
checkInvariant [Char]
s (LQ IORef (Pair a)
headPtr IORef (Pair a)
tailPtr) = 
  do Pair a
head <- forall a. IORef a -> IO a
readIORef IORef (Pair a)
headPtr
     Pair a
tail <- forall a. IORef a -> IO a
readIORef IORef (Pair a)
tailPtr
     if (Bool -> Bool
not (forall a. Pair a -> Pair a -> Bool
pairEq Pair a
head Pair a
tail))
       then case Pair a
head of 
              Pair a
Null -> forall a. HasCallStack => [Char] -> a
error ([Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" checkInvariant: LinkedQueue invariants broken.  Internal error.")
              Cons a
_ IORef (Pair a)
next -> do
                Pair a
next' <- forall a. IORef a -> IO a
readIORef IORef (Pair a)
next
                case Pair a
next' of 
                  Pair a
Null -> forall a. HasCallStack => [Char] -> a
error ([Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" checkInvariant: next' should not be null")
                  Pair a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       else forall (m :: * -> *) a. Monad m => a -> m a
return ()
            
-- | Attempt to pop an element from the queue if one is available.
--   tryPop will return semi-promptly (depending on contention), but
--   will return 'Nothing' if the queue is empty.
tryPopR :: forall a . LinkedQueue a -> IO (Maybe a)
-- FIXME -- this version
-- TODO -- add some kind of backoff.  This should probably at least
-- yield after a certain number of failures.
tryPopR :: forall a. LinkedQueue a -> IO (Maybe a)
tryPopR q :: LinkedQueue a
q@(LQ IORef (Pair a)
headPtr IORef (Pair a)
tailPtr) = Int -> IO (Maybe a)
loop Int
0
 where
  loop :: Int -> IO (Maybe a)
#ifdef DEBUG
   --  loop 10 = do hPutStrLn stderr (pack "tryPopR: tried ~10 times!!");  loop 11 -- This one happens a lot on -N32
  loop 25   = do hPutStrLn stderr (pack "tryPopR: tried ~25 times!!");   loop 26
  loop 50   = do hPutStrLn stderr (pack "tryPopR: tried ~50 times!!");   loop 51
  loop 100  = do hPutStrLn stderr (pack "tryPopR: tried ~100 times!!");  loop 101
  loop 1000 = do hPutStrLn stderr (pack "tryPopR: tried ~1000 times!!"); loop 1001
#endif
  loop :: Int -> IO (Maybe a)
loop !Int
tries = do 
    Ticket (Pair a)
headTicket <- forall a. IORef a -> IO (Ticket a)
readForCAS IORef (Pair a)
headPtr
    Ticket (Pair a)
tailTicket <- forall a. IORef a -> IO (Ticket a)
readForCAS IORef (Pair a)
tailPtr
    case forall a. Ticket a -> a
peekTicket Ticket (Pair a)
headTicket of 
      Pair a
Null -> forall a. HasCallStack => [Char] -> a
error [Char]
"tryPopR: LinkedQueue invariants broken.  Internal error."
      head :: Pair a
head@(Cons a
_ IORef (Pair a)
next) -> do
        Ticket (Pair a)
nextTicket' <- forall a. IORef a -> IO (Ticket a)
readForCAS IORef (Pair a)
next
#ifdef RECHECK_ASSUMPTIONS
        -- As with push, double-check our information is up-to-date. (head,tail,next consistent)
        head' <- readIORef headPtr -- ANDREAS: used atomicModifyIORef headPtr (\x -> (x,x))
        if not (pairEq head head') then loop (tries+1) else do 
#else
        let head' :: Pair a
head' = Pair a
head
        do 
#endif                 
	  -- Is queue empty or tail falling behind?:
          if forall a. Pair a -> Pair a -> Bool
pairEq Pair a
head (forall a. Ticket a -> a
peekTicket Ticket (Pair a)
tailTicket) then do 
          -- if ptrEq head tail then do 
	    case forall a. Ticket a -> a
peekTicket Ticket (Pair a)
nextTicket' of -- Is queue empty?
              Pair a
Null -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- Queue is empty, couldn't dequeue
	      next' :: Pair a
next'@(Cons a
_ IORef (Pair a)
_) -> do
  	        -- Tail is falling behind.  Try to advance it:
	        forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef (Pair a)
tailPtr Ticket (Pair a)
tailTicket Pair a
next'
		Int -> IO (Maybe a)
loop (Int
triesforall a. Num a => a -> a -> a
+Int
1)
           
	   else do -- head /= tail
	      -- No need to deal with Tail.  Read value before CAS.
	      -- Otherwise, another dequeue might free the next node
	      case forall a. Ticket a -> a
peekTicket Ticket (Pair a)
nextTicket' of 
	        Pair a
Null -> forall a. HasCallStack => [Char] -> a
error [Char]
"tryPop: Internal error.  Next should not be null if head/=tail."
--	        Null -> loop (tries+1)
		next' :: Pair a
next'@(Cons a
value IORef (Pair a)
_) -> do 
                  -- Try to swing Head to the next node
		  (Bool
b,Ticket (Pair a)
_) <- forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef (Pair a)
headPtr Ticket (Pair a)
headTicket Pair a
next'
                  case Bool
b of
                    -- [2013.04.24] Looking at the STG, I can't see a way to get rid of the allocation on this Just:
                    Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
value) -- Dequeue done; exit loop.
                    Bool
False -> Int -> IO (Maybe a)
loop (Int
triesforall a. Num a => a -> a -> a
+Int
1) -- ANDREAS: observed this loop being taken >1M times
          
-- | Create a new queue.
newQ :: IO (LinkedQueue a)
newQ :: forall a. IO (LinkedQueue a)
newQ = do 
  IORef (Pair a)
r <- forall a. a -> IO (IORef a)
newIORef forall a. Pair a
Null
  let newp :: Pair a
newp = forall a. a -> IORef (Pair a) -> Pair a
Cons (forall a. HasCallStack => [Char] -> a
error [Char]
"LinkedQueue: Used uninitialized magic value.") IORef (Pair a)
r
  IORef (Pair a)
hd <- forall a. a -> IO (IORef a)
newIORef Pair a
newp
  IORef (Pair a)
tl <- forall a. a -> IO (IORef a)
newIORef Pair a
newp
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. IORef (Pair a) -> IORef (Pair a) -> LinkedQueue a
LQ IORef (Pair a)
hd IORef (Pair a)
tl)

-- | Is the queue currently empty?  Beware that this can be a highly transient state.
nullQ :: LinkedQueue a -> IO Bool
nullQ :: forall a. LinkedQueue a -> IO Bool
nullQ (LQ IORef (Pair a)
headPtr IORef (Pair a)
tailPtr) = do 
    Pair a
head <- forall a. IORef a -> IO a
readIORef IORef (Pair a)
headPtr
    Pair a
tail <- forall a. IORef a -> IO a
readIORef IORef (Pair a)
tailPtr
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Pair a -> Pair a -> Bool
pairEq Pair a
head Pair a
tail)



--------------------------------------------------------------------------------
--   Instance(s) of abstract deque interface
--------------------------------------------------------------------------------

-- instance DequeClass (Deque T T S S Grow Safe) where 
instance C.DequeClass LinkedQueue where 
  newQ :: forall a. IO (LinkedQueue a)
newQ    = forall a. IO (LinkedQueue a)
newQ
  nullQ :: forall a. LinkedQueue a -> IO Bool
nullQ   = forall a. LinkedQueue a -> IO Bool
nullQ
  pushL :: forall a. LinkedQueue a -> a -> IO ()
pushL   = forall a. LinkedQueue a -> a -> IO ()
pushL
  tryPopR :: forall a. LinkedQueue a -> IO (Maybe a)
tryPopR = forall a. LinkedQueue a -> IO (Maybe a)
tryPopR
  leftThreadSafe :: forall elt. LinkedQueue elt -> Bool
leftThreadSafe LinkedQueue elt
_  = Bool
True
  rightThreadSafe :: forall elt. LinkedQueue elt -> Bool
rightThreadSafe LinkedQueue elt
_ = Bool
True

--------------------------------------------------------------------------------