module LLVM.Extra.Representation (
Memory(load, store, decompose, compose), modify, castStorablePtr,
MemoryRecord, MemoryElement, memoryElement,
loadRecord, storeRecord, decomposeRecord, composeRecord,
loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,
newForeignPtrInit, newForeignPtrParam,
newForeignPtr, withForeignPtr,
malloc, free,
) where
import qualified LLVM.Core as LLVM
import LLVM.Core
(MakeValueTuple,
Struct, getElementPtr0,
extractvalue, insertvalue,
Value, valueOf, Vector,
IsType, IsSized,
CodeGenFunction, )
import LLVM.Util.Loop (Phi, )
import qualified Foreign.Marshal.Utils as Marshal
import qualified Foreign.ForeignPtr as FPtr
import qualified Foreign.Concurrent as FC
import Foreign.Storable (Storable, poke, )
import Foreign.Ptr (Ptr, castPtr, FunPtr, )
import Data.TypeLevel.Num (d0, d1, d2, D4, )
import Data.Word (Word32, Word64, )
import Control.Monad (ap, )
import Control.Applicative (pure, liftA2, liftA3, )
import qualified Control.Applicative as App
import Data.Tuple.HT (fst3, snd3, thd3, )
class (Phi llvmValue, IsType llvmStruct) =>
Memory llvmValue llvmStruct | llvmValue -> llvmStruct where
load :: Value (Ptr llvmStruct) -> CodeGenFunction r llvmValue
load ptr = decompose =<< LLVM.load ptr
store :: llvmValue -> Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())
store r ptr = flip LLVM.store ptr =<< compose r
decompose :: Value llvmStruct -> CodeGenFunction r llvmValue
compose :: llvmValue -> CodeGenFunction r (Value llvmStruct)
modify ::
(Memory llvmValue llvmStruct) =>
(llvmValue -> CodeGenFunction r llvmValue) ->
Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())
modify f ptr =
flip store ptr =<< f =<< load ptr
type MemoryRecord r o v = MemoryElement r o v v
data MemoryElement r o v x =
MemoryElement {
loadElement :: Value (Ptr o) -> CodeGenFunction r x,
storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (Value ()),
extractElement :: Value o -> CodeGenFunction r x,
insertElement :: v -> Value o -> CodeGenFunction r (Value o)
}
memoryElement ::
(Memory x llvmStruct,
LLVM.GetValue o n llvmStruct,
LLVM.GetElementPtr o (n, ()) llvmStruct) =>
(v -> x) -> n -> MemoryElement r o v x
memoryElement field n =
MemoryElement {
loadElement = \ptr -> load =<< getElementPtr0 ptr (n, ()),
storeElement = \ptr v -> store (field v) =<< getElementPtr0 ptr (n, ()),
extractElement = \o -> decompose =<< extractvalue o n,
insertElement = \v o -> flip (insertvalue o) n =<< compose (field v)
}
instance Functor (MemoryElement r o v) where
fmap f m =
MemoryElement {
loadElement = fmap f . loadElement m,
storeElement = storeElement m,
extractElement = fmap f . extractElement m,
insertElement = insertElement m
}
instance App.Applicative (MemoryElement r o v) where
pure x =
MemoryElement {
loadElement = \ _ptr -> return x,
storeElement = \ _ptr _v ->
return (error "MemoryElement: undefined value" :: Value ()),
extractElement = \ _o -> return x,
insertElement = \ _v o -> return o
}
f <*> x =
MemoryElement {
loadElement = \ptr -> loadElement f ptr `ap` loadElement x ptr,
storeElement = \ptr y -> storeElement f ptr y >> storeElement x ptr y,
extractElement = \o -> extractElement f o `ap` extractElement x o,
insertElement = \y o -> insertElement f y o >>= insertElement x y
}
loadRecord ::
MemoryRecord r o llvmValue ->
Value (Ptr o) -> CodeGenFunction r llvmValue
loadRecord = loadElement
storeRecord ::
MemoryRecord r o llvmValue ->
llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())
storeRecord m y ptr = storeElement m ptr y
decomposeRecord ::
MemoryRecord r o llvmValue ->
Value o -> CodeGenFunction r llvmValue
decomposeRecord m =
extractElement m
composeRecord ::
(IsType o) =>
MemoryRecord r o llvmValue ->
llvmValue -> CodeGenFunction r (Value o)
composeRecord m v =
insertElement m v (LLVM.value LLVM.undef)
pairMemory ::
(Memory al as, Memory bl bs,
IsSized as sas, IsSized bs sbs) =>
MemoryRecord r (Struct (as, (bs, ()))) (al, bl)
pairMemory =
liftA2 (,)
(memoryElement fst d0)
(memoryElement snd d1)
instance
(Memory al as, Memory bl bs,
IsSized as sas, IsSized bs sbs) =>
Memory (al, bl) (Struct (as, (bs, ()))) where
load = loadRecord pairMemory
store = storeRecord pairMemory
decompose = decomposeRecord pairMemory
compose = composeRecord pairMemory
tripleMemory ::
(Memory al as, Memory bl bs, Memory cl cs,
IsSized as sas, IsSized bs sbs, IsSized cs scs) =>
MemoryRecord r (Struct (as, (bs, (cs, ())))) (al, bl, cl)
tripleMemory =
liftA3 (,,)
(memoryElement fst3 d0)
(memoryElement snd3 d1)
(memoryElement thd3 d2)
instance
(Memory al as, Memory bl bs, Memory cl cs,
IsSized as sas, IsSized bs sbs, IsSized cs scs) =>
Memory (al, bl, cl) (Struct (as, (bs, (cs, ())))) where
load = loadRecord tripleMemory
store = storeRecord tripleMemory
decompose = decomposeRecord tripleMemory
compose = composeRecord tripleMemory
instance (LLVM.IsFirstClass a) => Memory (Value a) a where
load = LLVM.load
store = LLVM.store
decompose = return
compose = return
instance Memory () (Struct ()) where
load _ = return ()
store _ _ = return (error "().store: no result" :: Value ())
decompose _ = return ()
compose _ = return (LLVM.value LLVM.undef)
castStorablePtr ::
(MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>
Ptr haskellValue -> Ptr llvmStruct
castStorablePtr = castPtr
loadNewtype ::
(Memory a o) =>
(a -> llvmValue) ->
Value (Ptr o) -> CodeGenFunction r llvmValue
loadNewtype wrap ptr =
fmap wrap $ load ptr
storeNewtype ::
(Memory a o) =>
(llvmValue -> a) ->
llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())
storeNewtype unwrap y ptr =
store (unwrap y) ptr
decomposeNewtype ::
(Memory a o) =>
(a -> llvmValue) ->
Value o -> CodeGenFunction r llvmValue
decomposeNewtype wrap y =
fmap wrap $ decompose y
composeNewtype ::
(Memory a o) =>
(llvmValue -> a) ->
llvmValue -> CodeGenFunction r (Value o)
composeNewtype unwrap y =
compose (unwrap y)
type Importer f = FunPtr f -> f
foreign import ccall safe "dynamic" derefStartPtr ::
Importer (IO (Ptr a))
newForeignPtrInit ::
FunPtr (Ptr a -> IO ()) ->
FunPtr (IO (Ptr a)) ->
IO (FPtr.ForeignPtr a)
newForeignPtrInit stop start =
FPtr.newForeignPtr stop =<< derefStartPtr start
foreign import ccall safe "dynamic" derefStartParamPtr ::
Importer (Ptr b -> IO (Ptr a))
newForeignPtrParam ::
(Storable b, MakeValueTuple b bl, Memory bl bp) =>
FunPtr (Ptr a -> IO ()) ->
FunPtr (Ptr bp -> IO (Ptr a)) ->
b -> IO (FPtr.ForeignPtr a)
newForeignPtrParam stop start b =
FPtr.newForeignPtr stop =<<
Marshal.with b (derefStartParamPtr start . castStorablePtr)
newForeignPtr ::
Storable a =>
IO () ->
a -> IO (FPtr.ForeignPtr a)
newForeignPtr finalizer a = do
ptr <- FPtr.mallocForeignPtr
FC.addForeignPtrFinalizer ptr finalizer
FPtr.withForeignPtr ptr (flip poke a)
return ptr
withForeignPtr ::
(Storable a, MakeValueTuple a al, Memory al ap) =>
FPtr.ForeignPtr a -> (Ptr ap -> IO b) -> IO b
withForeignPtr fp func =
FPtr.withForeignPtr fp (func . castStorablePtr)
type Aligned a = Struct (a, (Ptr (Vector D4 Float), ()))
type AlignedPtr a = Ptr (Aligned a)
malloc :: (IsSized a s) => CodeGenFunction r (Value (Ptr a))
malloc =
let m :: (IsSized a s) =>
CodeGenFunction r (Value (Ptr (Struct (Vector D4 Float, (Aligned a, ())))))
m = LLVM.malloc
in do p <- m
p1 <- getElementPtr0 p (d1, ())
p1int <- LLVM.ptrtoint p1
p16int <- LLVM.and (valueOf (16) :: Value Word64) (p1int :: Value Word64)
p16 <- LLVM.inttoptr p16int
v <- getElementPtr0 p (d0, ())
store v =<< getElementPtr0 (p16 `asTypeOf` p1) (d1, ())
getElementPtr0 p16 (d0, ())
free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())
free p =
LLVM.free =<<
load =<<
(LLVM.bitcastUnify ::
(IsSized a sa) =>
Value (Ptr a) ->
CodeGenFunction r (Value (Ptr (AlignedPtr a)))) =<<
LLVM.getElementPtr p (1 :: Word32, ())