{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{- |
Adding the finalizer to a ForeignPtr seems to be the only way
that warrants execution of the finalizer (not too early and not never).
However, the normal ForeignPtr finalizers must be independent from Haskell runtime.
In contrast to ForeignPtr finalizers,
addFinalizer adds finalizers to boxes, that are optimized away.
Thus finalizers are run too early or not at all.
Concurrent.ForeignPtr and using threaded execution
is the only way to get finalizers in Haskell IO.
-}
module Synthesizer.LLVM.ForeignPtr where

import qualified LLVM.DSL.Execution as Exec
import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV
import qualified LLVM.Extra.Marshal as Marshal
import qualified LLVM.ExecutionEngine as EE
import qualified LLVM.Core as LLVM

import qualified Foreign.ForeignPtr as FPtr
import qualified Foreign.Concurrent as FC
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.StablePtr (newStablePtr, freeStablePtr)
import Foreign.Ptr (nullPtr)


newAux :: IO () -> IO (ForeignPtr ())
newAux :: IO () -> IO (ForeignPtr ())
newAux = Ptr () -> IO () -> IO (ForeignPtr ())
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
FC.newForeignPtr Ptr ()
forall a. Ptr a
nullPtr


makeFinalizer :: (EE.ExecutionEngine, IO ()) -> IO (IO ())
makeFinalizer :: (ExecutionEngine, IO ()) -> IO (IO ())
makeFinalizer (ExecutionEngine
ee, IO ()
finalizer) = do
   StablePtr ExecutionEngine
stable <- ExecutionEngine -> IO (StablePtr ExecutionEngine)
forall a. a -> IO (StablePtr a)
newStablePtr ExecutionEngine
ee
   IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
finalizer IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StablePtr ExecutionEngine -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr ExecutionEngine
stable

type MemoryPtr struct = ForeignPtr (EE.Stored struct)

newInit :: Exec.Finalizer a -> IO (LLVM.Ptr a) -> IO (MemoryPtr a)
newInit :: forall a. Finalizer a -> IO (Ptr a) -> IO (MemoryPtr a)
newInit (ExecutionEngine
ee, Ptr a -> IO ()
stop) IO (Ptr a)
start = do
   Ptr a
state <- IO (Ptr a)
start
   Ptr (Stored a) -> IO () -> IO (MemoryPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
FC.newForeignPtr (Ptr a -> Ptr (Stored a)
forall a. Ptr a -> Ptr (Stored a)
EE.castToStoredPtr Ptr a
state)
      (IO () -> IO (MemoryPtr a)) -> IO (IO ()) -> IO (MemoryPtr a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ExecutionEngine, IO ()) -> IO (IO ())
makeFinalizer (ExecutionEngine
ee, Ptr a -> IO ()
stop Ptr a
state)

newParam ::
   (Marshal.C b) =>
   Exec.Finalizer a ->
   (LLVM.Ptr (Marshal.Struct b) -> IO (LLVM.Ptr a)) ->
   b -> IO (MemoryPtr a)
newParam :: forall b a.
C b =>
Finalizer a
-> (Ptr (Struct b) -> IO (Ptr a)) -> b -> IO (MemoryPtr a)
newParam Finalizer a
stop Ptr (Struct b) -> IO (Ptr a)
start b
b =
   Finalizer a -> IO (Ptr a) -> IO (MemoryPtr a)
forall a. Finalizer a -> IO (Ptr a) -> IO (MemoryPtr a)
newInit Finalizer a
stop (b -> (Ptr (Struct b) -> IO (Ptr a)) -> IO (Ptr a)
forall a b. C a => a -> (Ptr (Struct a) -> IO b) -> IO b
Marshal.with b
b Ptr (Struct b) -> IO (Ptr a)
start)

newParamMV ::
   (MarshalMV.C b) =>
   Exec.Finalizer a ->
   (LLVM.Ptr (MarshalMV.Struct b) -> IO (LLVM.Ptr a)) ->
   b -> IO (MemoryPtr a)
newParamMV :: forall b a.
C b =>
Finalizer a
-> (Ptr (Struct b) -> IO (Ptr a)) -> b -> IO (MemoryPtr a)
newParamMV Finalizer a
stop Ptr (Struct b) -> IO (Ptr a)
start b
b =
   Finalizer a -> IO (Ptr a) -> IO (MemoryPtr a)
forall a. Finalizer a -> IO (Ptr a) -> IO (MemoryPtr a)
newInit Finalizer a
stop (b -> (Ptr (Struct b) -> IO (Ptr a)) -> IO (Ptr a)
forall a b. C a => a -> (Ptr (Struct a) -> IO b) -> IO b
MarshalMV.with b
b Ptr (Struct b) -> IO (Ptr a)
start)

new ::
   (Marshal.C a, Marshal.Struct a ~ struct) =>
   IO () -> a -> IO (MemoryPtr struct)
new :: forall a struct.
(C a, Struct a ~ struct) =>
IO () -> a -> IO (MemoryPtr struct)
new IO ()
finalizer a
a = do
   MemoryPtr struct
ptr <- IO (MemoryPtr struct)
forall a. Storable a => IO (ForeignPtr a)
FPtr.mallocForeignPtr
   MemoryPtr struct -> IO () -> IO ()
forall a. ForeignPtr a -> IO () -> IO ()
FC.addForeignPtrFinalizer MemoryPtr struct
ptr IO ()
finalizer
   MemoryPtr struct -> (Ptr struct -> IO ()) -> IO ()
forall struct a. MemoryPtr struct -> (Ptr struct -> IO a) -> IO a
with MemoryPtr struct
ptr ((Ptr struct -> IO ()) -> IO ()) -> (Ptr struct -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Ptr struct -> a -> IO ()) -> a -> Ptr struct -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr struct -> a -> IO ()
forall a struct.
(C a, Struct a ~ struct, Marshal struct) =>
Ptr struct -> a -> IO ()
Marshal.poke a
a
   MemoryPtr struct -> IO (MemoryPtr struct)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MemoryPtr struct
ptr


with :: MemoryPtr struct -> (LLVM.Ptr struct -> IO a) -> IO a
with :: forall struct a. MemoryPtr struct -> (Ptr struct -> IO a) -> IO a
with MemoryPtr struct
fptr Ptr struct -> IO a
act = MemoryPtr struct -> (Ptr (Stored struct) -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr MemoryPtr struct
fptr ((Ptr (Stored struct) -> IO a) -> IO a)
-> (Ptr (Stored struct) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr struct -> IO a
act (Ptr struct -> IO a)
-> (Ptr (Stored struct) -> Ptr struct)
-> Ptr (Stored struct)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (Stored struct) -> Ptr struct
forall a. Ptr (Stored a) -> Ptr a
EE.castFromStoredPtr