EventIterator.hs

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

import qualified Data.EventList.Relative.BodyTime as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class

import Foreign.Storable (Storable, poke, )
import Foreign.StablePtr
          (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )
import Foreign.Ptr (FunPtr, Ptr, castPtr, )
import Data.IORef (IORef, newIORef, readIORef, writeIORef, )
import Data.Word (Word32, )

import Control.Monad ((<=<), )

import qualified Synthesizer.LLVM.Debug.StablePtr as DebugStable


{-
For problems on constraints, see ChunkIterator.
-}
data T a =
   (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>
   Cons (IORef (EventList.T NonNeg.Int a))

type MemoryPtr a = Ptr (Memory.Struct (Class.ValueTuple a))


foreign import ccall "&nextConstant"
   nextCallBack :: FunPtr (StablePtr (T a) -> MemoryPtr a -> IO Word32)

foreign export ccall "nextConstant"
   next :: StablePtr (T a) -> MemoryPtr a -> IO Word32


{- |
Events with subsequent duration 0 are ignored
(and for performance reasons it should not contain too many small values,
say below 100).
-}
new ::
   (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) =>
   EventList.T NonNeg.Int a -> IO (StablePtr (T a))
new evs =
   DebugStable.trace "new" =<<
   newStablePtr . Cons
    =<< newIORef
      (EventList.fromPairList $
       filter ((/=0) . snd) $
       EventList.toPairList evs)

dispose :: StablePtr (T a) -> IO ()
dispose = freeStablePtr <=< DebugStable.trace "dispose"

next :: StablePtr (T a) -> MemoryPtr a -> IO Word32
next stable eventPtr =
   DebugStable.trace "next" stable >>=
   deRefStablePtr >>= \state ->
   case state of
      Cons listRef ->
         readIORef listRef >>=
         EventList.switchL
            (return 0)
            (\body time xs ->
               writeIORef listRef xs >>
               poke (castPtr eventPtr) body >>
               return (fromIntegral time))