module CodeGen.X86.FFI where
import Control.Monad
import Control.Exception (evaluate)
import Foreign
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import System.IO.Unsafe
import CodeGen.X86.Asm
import CodeGen.X86.CodeGen
#define PAGE_SIZE 4096
#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS)
import System.Win32.Types
import System.Win32.Mem
import Foreign.Marshal.Alloc
#endif
foreign import ccall "dynamic" callWord64 :: FunPtr Word64 -> Word64
foreign import ccall "dynamic" callWord32 :: FunPtr Word32 -> Word32
foreign import ccall "dynamic" callWord16 :: FunPtr Word16 -> Word16
foreign import ccall "dynamic" callWord8 :: FunPtr Word8 -> Word8
foreign import ccall "dynamic" callWord :: FunPtr Word -> Word
foreign import ccall "dynamic" callInt64 :: FunPtr Int64 -> Int64
foreign import ccall "dynamic" callInt32 :: FunPtr Int32 -> Int32
foreign import ccall "dynamic" callInt16 :: FunPtr Int16 -> Int16
foreign import ccall "dynamic" callInt8 :: FunPtr Int8 -> Int8
foreign import ccall "dynamic" callInt :: FunPtr Int -> Int
foreign import ccall "dynamic" callBool :: FunPtr Bool -> Bool
foreign import ccall "dynamic" callIOUnit :: FunPtr (IO ()) -> IO ()
foreign import ccall "dynamic" callWord64_Word64 :: FunPtr (Word64 -> Word64) -> Word64 -> Word64
foreign import ccall "dynamic" callPtr_Word64 :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64
foreign import ccall "dynamic" callPtr_Word :: FunPtr (Ptr a -> Word) -> Ptr a -> Word
foreign import ccall "dynamic" callPtr_Int64 :: FunPtr (Ptr a -> Int64) -> Ptr a -> Int64
foreign import ccall "dynamic" callPtr_Int :: FunPtr (Ptr a -> Int) -> Ptr a -> Int
unsafeCallForeignPtr0 call p = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p)) <* touchForeignPtr p
unsafeCallForeignPtr1 call p a = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) a) <* touchForeignPtr p
unsafeCallForeignPtrIO0 call p = call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) <* touchForeignPtr p
class Callable a where unsafeCallForeignPtr :: ForeignPtr a -> a
instance Callable Word64 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord64
instance Callable Word32 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord32
instance Callable Word16 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord16
instance Callable Word8 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord8
instance Callable Word where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord
instance Callable Int64 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt64
instance Callable Int32 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt32
instance Callable Int16 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt16
instance Callable Int8 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt8
instance Callable Int where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt
instance Callable Bool where unsafeCallForeignPtr = unsafeCallForeignPtr0 callBool
instance Callable (IO ()) where unsafeCallForeignPtr = unsafeCallForeignPtrIO0 callIOUnit
instance Callable (Word64 -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callWord64_Word64
instance Callable (Ptr a -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word64
instance Callable (Ptr a -> Word) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word
instance Callable (Ptr a -> Int64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int64
instance Callable (Ptr a -> Int) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int
#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS)
foreign import ccall "static malloc.h _aligned_malloc" c_aligned_malloc :: CSize -> CSize -> IO (Ptr a)
foreign import ccall "static malloc.h _aligned_free" c_aligned_free :: Ptr a -> IO ()
foreign import ccall "static malloc.h &_aligned_free" ptr_aligned_free :: FunPtr (Ptr a -> IO ())
#elif defined (linux_HOST_OS)
foreign import ccall "static stdlib.h memalign" memalign :: CSize -> CSize -> IO (Ptr a)
foreign import ccall "static stdlib.h &free" stdfree :: FunPtr (Ptr a -> IO ())
foreign import ccall "static sys/mman.h mprotect" mprotect :: Ptr a -> CSize -> CInt -> IO CInt
#elif defined (darwin_HOST_OS) || defined (freebsd_HOST_OS) || defined (openbsd_HOST_OS) || defined (netbsd_HOST_OS)
foreign import ccall "static stdlib.h posix_memalign" posix_memalign :: Ptr (Ptr a) -> CSize -> CSize -> IO CInt
foreign import ccall "static stdlib.h &free" stdfree :: FunPtr (Ptr a -> IO ())
foreign import ccall "static sys/mman.h mprotect" mprotect :: Ptr a -> CSize -> CInt -> IO CInt
#endif
#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS)
flag_PAGE_EXECUTE_READWRITE :: Word32
flag_PAGE_EXECUTE_READWRITE = 0x40
compile :: Callable a => Code -> a
compile x = unsafeCallForeignPtr $ unsafePerformIO $ do
let (bytes, fromIntegral -> size) = buildTheCode x
arr <- c_aligned_malloc (fromIntegral size) PAGE_SIZE
_ <- virtualProtect (castPtr arr) (fromIntegral size) flag_PAGE_EXECUTE_READWRITE
forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr
newForeignPtr ptr_aligned_free arr
#elif defined linux_HOST_OS
compile :: Callable a => Code -> a
compile x = unsafeCallForeignPtr $ unsafePerformIO $ do
let (bytes, fromIntegral -> size) = buildTheCode x
arr <- memalign PAGE_SIZE size
_ <- mprotect arr size 0x7
forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr
newForeignPtr stdfree arr
#elif defined (darwin_HOST_OS) || defined (freebsd_HOST_OS) || defined (openbsd_HOST_OS) || defined (netbsd_HOST_OS)
posixMemAlign
:: CSize
-> CSize
-> IO (Ptr a)
posixMemAlign alignment size0 =
alloca $ \pp -> do
let a = max alignment 8
size = mod (size0 + a 1) a
res <- posix_memalign pp alignment size
case res of
0 -> peek pp
_ -> error "posix_memalign failed"
compile :: Callable a => Code -> a
compile x = unsafeCallForeignPtr $ unsafePerformIO $ do
let (bytes, fromIntegral -> size) = buildTheCode x
arr <- posixMemAlign PAGE_SIZE size
_ <- mprotect arr size 0x7
forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr
newForeignPtr stdfree arr
#endif
foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64))
class CallableHs a where createHsPtr :: a -> IO (FunPtr a)
instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64
hsPtr :: CallableHs a => a -> FunPtr a
hsPtr x = unsafePerformIO $ createHsPtr x