{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.Storable.ChunkIterator where

import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector.Base as SVB

import qualified LLVM.Core as LLVM

import Data.Word (Word)
import Foreign.Storable (Storable, poke)
import Foreign.Ptr (FunPtr, Ptr, nullPtr)

import Control.Monad (liftM2)

import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)


{-
FFI declarations must not have constraints.
Thus we put them in the iterator datatype.
-}
data T a = (Storable a) => Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))


foreign import ccall "&nextChunk"
   nextCallBack :: FunPtr (StablePtr (T a) -> LLVM.Ptr Word -> IO (Ptr a))

foreign export ccall "nextChunk"
   next :: StablePtr (T a) -> Ptr Word -> IO (Ptr a)


new :: (Storable a) => SVL.Vector a -> IO (StablePtr (T a))
new :: forall a. Storable a => Vector a -> IO (StablePtr (T a))
new Vector a
sig =
   T a -> IO (StablePtr (T a))
forall a. a -> IO (StablePtr a)
newStablePtr (T a -> IO (StablePtr (T a))) -> IO (T a) -> IO (StablePtr (T a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
   (IORef [Vector a] -> IORef (Vector a) -> T a)
-> IO (IORef [Vector a]) -> IO (IORef (Vector a)) -> IO (T a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 IORef [Vector a] -> IORef (Vector a) -> T a
forall a. Storable a => IORef [Vector a] -> IORef (Vector a) -> T a
Cons
      ([Vector a] -> IO (IORef [Vector a])
forall a. a -> IO (IORef a)
newIORef (Vector a -> [Vector a]
forall a. Vector a -> [Vector a]
SVL.chunks Vector a
sig))
      (Vector a -> IO (IORef (Vector a))
forall a. a -> IO (IORef a)
newIORef ([Char] -> Vector a
forall a. HasCallStack => [Char] -> a
error [Char]
"first chunk must be fetched with nextChunk"))

dispose :: StablePtr (T a) -> IO ()
dispose :: forall a. StablePtr (T a) -> IO ()
dispose = StablePtr (T a) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr

next :: StablePtr (T a) -> Ptr Word -> IO (Ptr a)
next :: forall a. StablePtr (T a) -> Ptr Word -> IO (Ptr a)
next StablePtr (T a)
stable Ptr Word
lenPtr =
   StablePtr (T a) -> IO (T a)
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (T a)
stable IO (T a) -> (T a -> IO (Ptr a)) -> IO (Ptr a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \T a
state ->
   case T a
state of
      Cons IORef [Vector a]
listRef IORef (Vector a)
chunkRef -> do
         [Vector a]
xt <- IORef [Vector a] -> IO [Vector a]
forall a. IORef a -> IO a
readIORef IORef [Vector a]
listRef
         case [Vector a]
xt of
            [] -> Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
forall a. Ptr a
nullPtr
            (Vector a
x:[Vector a]
xs) ->
               {- We have to maintain a pointer to the current chunk
                  in order to protect it against garbage collection -}
               IORef (Vector a) -> Vector a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Vector a)
chunkRef Vector a
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               IORef [Vector a] -> [Vector a] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Vector a]
listRef [Vector a]
xs IO () -> IO (Ptr a) -> IO (Ptr a)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Vector a -> (Ptr a -> Int -> IO (Ptr a)) -> IO (Ptr a)
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector a
x
                  (\Ptr a
p Int
l -> Ptr Word -> Word -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word
lenPtr (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) IO () -> IO (Ptr a) -> IO (Ptr a)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
p)