content: {-# 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
  -- | INEFFICIENT 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
  -- structures because it itself depends 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 because 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 INVALIDATED: CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!"
  	    -- Todo... weak 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:
  