{-# 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.Multi.Value.Marshal as Marshal
import qualified LLVM.Core as LLVM

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

import Control.Monad ((<=<))

import qualified LLVM.DSL.Debug.StablePtr as DebugStable


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

type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)


foreign import ccall "&nextConstantExp"
   nextCallBack :: FunPtr (StablePtr (T a) -> MarshalPtr a -> IO Word)

foreign export ccall "nextConstantExp"
   next :: StablePtr (T a) -> MarshalPtr a -> IO Word


{- |
Events with subsequent duration 0 are ignored
(and for performance reasons it should not contain too many small values,
say below 100).
-}
new :: (Marshal.C a) => EventList.T NonNeg.Int a -> IO (StablePtr (T a))
new :: forall a. C a => T Int a -> IO (StablePtr (T a))
new T Int a
evs =
   String -> StablePtr (T a) -> IO (StablePtr (T a))
forall a. String -> StablePtr a -> IO (StablePtr a)
DebugStable.trace String
"new" (StablePtr (T a) -> IO (StablePtr (T a)))
-> IO (StablePtr (T a)) -> IO (StablePtr (T a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
   T a -> IO (StablePtr (T a))
forall a. a -> IO (StablePtr a)
newStablePtr (T a -> IO (StablePtr (T a)))
-> (IORef (T Int a) -> T a)
-> IORef (T Int a)
-> IO (StablePtr (T a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (T Int a) -> T a
forall a. C a => IORef (T Int a) -> T a
Cons
    (IORef (T Int a) -> IO (StablePtr (T a)))
-> IO (IORef (T Int a)) -> IO (StablePtr (T a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T Int a -> IO (IORef (T Int a))
forall a. a -> IO (IORef a)
newIORef
      ([(a, Int)] -> T Int a
forall body time. [(body, time)] -> T time body
EventList.fromPairList ([(a, Int)] -> T Int a) -> [(a, Int)] -> T Int a
forall a b. (a -> b) -> a -> b
$
       ((a, Int) -> Bool) -> [(a, Int)] -> [(a, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) (Int -> Bool) -> ((a, Int) -> Int) -> (a, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Int) -> Int
forall a b. (a, b) -> b
snd) ([(a, Int)] -> [(a, Int)]) -> [(a, Int)] -> [(a, Int)]
forall a b. (a -> b) -> a -> b
$
       T Int a -> [(a, Int)]
forall time body. T time body -> [(body, time)]
EventList.toPairList T Int a
evs)

dispose :: StablePtr (T a) -> IO ()
dispose :: forall a. StablePtr (T a) -> IO ()
dispose = StablePtr (T a) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr (StablePtr (T a) -> IO ())
-> (StablePtr (T a) -> IO (StablePtr (T a)))
-> StablePtr (T a)
-> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> StablePtr (T a) -> IO (StablePtr (T a))
forall a. String -> StablePtr a -> IO (StablePtr a)
DebugStable.trace String
"dispose"

next :: StablePtr (T a) -> MarshalPtr a -> IO Word
next :: forall a. StablePtr (T a) -> MarshalPtr a -> IO Word
next StablePtr (T a)
stable MarshalPtr a
eventPtr =
   String -> StablePtr (T a) -> IO (StablePtr (T a))
forall a. String -> StablePtr a -> IO (StablePtr a)
DebugStable.trace String
"next" StablePtr (T a)
stable IO (StablePtr (T a)) -> (StablePtr (T a) -> IO (T a)) -> IO (T a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
   StablePtr (T a) -> IO (T a)
forall a. StablePtr a -> IO a
deRefStablePtr IO (T a) -> (T a -> IO Word) -> IO Word
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 (T Int a)
listRef ->
         IORef (T Int a) -> IO (T Int a)
forall a. IORef a -> IO a
readIORef IORef (T Int a)
listRef IO (T Int a) -> (T Int a -> IO Word) -> IO Word
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
         IO Word -> (a -> Int -> T Int a -> IO Word) -> T Int a -> IO Word
forall c body time.
c -> (body -> time -> T time body -> c) -> T time body -> c
EventList.switchL
            (Word -> IO Word
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Word
0)
            (\a
body Int
time T Int a
xs ->
               IORef (T Int a) -> T Int a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (T Int a)
listRef T Int a
xs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               MarshalPtr a -> a -> IO ()
forall a struct.
(C a, Struct a ~ struct, Marshal struct) =>
Ptr struct -> a -> IO ()
Marshal.poke MarshalPtr a
eventPtr a
body IO () -> IO Word -> IO Word
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Word -> IO Word
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
time))