{-# OPTIONS -fglasgow-exts -fbang-patterns #-}
module Data.CompactMap.Buffer where


import Foreign (Ptr,Storable(..),plusPtr, castPtr)

import Data.CompactMap.MemoryMap
import Data.CompactMap.Types

import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr, castForeignPtr)
import Foreign.Concurrent
import Data.IORef


newBuffer :: Int -> IO Buffer
newBuffer initSize
    = do aligned <- alignSize initSize
         dataPtr <- mmap aligned [Read,Write] [Anonymous,Private,NoReserve]
         fptr   <- newIORef =<< newForeignPtr dataPtr (munmap dataPtr initSize)
         old    <- newIORef []
         posRef <- newFastMutInt 0
         size   <- newFastMutInt aligned
         return $ Buffer{ bufferData = fptr
                        , bufferOld  = old
                        , bufferPos  = posRef
                        , bufferSize = size }

withBytes :: Buffer -> Int -> (Ptr a -> IO b) -> IO b
withBytes !Buffer{bufferPos=bufferPos,bufferData=bufferData,bufferSize=bufferSize,bufferOld=bufferOld} !bytesNeeded fn
    = do !currentPos <- readFastMutInt bufferPos
         !currentSize <- readFastMutInt bufferSize
         !oldPtr <- readIORef bufferData
         if currentSize >= currentPos + bytesNeeded
            then do writeFastMutInt bufferPos (currentPos+bytesNeeded)
                    withForeignPtr (castForeignPtr oldPtr) $ \ptr -> fn $! (ptr `plusPtr` currentPos)
            else do let minSize = max bytesNeeded currentSize
                        newSize = minSize + minSize `div` 4 -- Add 25% to the buffer.
                    aligned <- alignSize newSize
                    --putStrLn $ "Expanding from " ++ show currentSize ++ " to " ++ show aligned
                    !newPtr <- mmap aligned [Read,Write] [Anonymous,Private,NoReserve]
                    fptr <- newForeignPtr newPtr (munmap newPtr aligned)
                    writeIORef bufferData fptr
                    modifyIORef bufferOld (oldPtr:)
                    writeFastMutInt bufferPos bytesNeeded
                    writeFastMutInt bufferSize aligned
                    fn $! (castPtr newPtr)

touchBuffer :: Buffer -> IO ()
touchBuffer buffer
    = do touchForeignPtr =<< readIORef (bufferData buffer)
         ls <- readIORef (bufferOld buffer)
         mapM_ touchForeignPtr ls