diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/cbits/closures.c b/cbits/closures.c new file mode 100644 --- /dev/null +++ b/cbits/closures.c @@ -0,0 +1,615 @@ +/* ----------------------------------------------------------------------- + closures.c - Copyright (c) 2007, 2009, 2010 Red Hat, Inc. + Copyright (C) 2007, 2009, 2010 Free Software Foundation, Inc + Copyright (c) 2011 Plausible Labs Cooperative, Inc. + + Code to allocate and deallocate memory for closures. + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + ``Software''), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + DEALINGS IN THE SOFTWARE. + ----------------------------------------------------------------------- */ + +#if defined __linux__ && !defined _GNU_SOURCE +#define _GNU_SOURCE 1 +#endif + +#include +// #include // not in GHC's ffi.h + +#if !FFI_MMAP_EXEC_WRIT && !FFI_EXEC_TRAMPOLINE_TABLE +# if __gnu_linux__ +/* This macro indicates it may be forbidden to map anonymous memory + with both write and execute permission. Code compiled when this + option is defined will attempt to map such pages once, but if it + fails, it falls back to creating a temporary file in a writable and + executable filesystem and mapping pages from it into separate + locations in the virtual memory space, one location writable and + another executable. */ +# define FFI_MMAP_EXEC_WRIT 1 +# define HAVE_MNTENT 1 +# endif +# if defined(X86_WIN32) || defined(X86_WIN64) || defined(__OS2__) +/* Windows systems may have Data Execution Protection (DEP) enabled, + which requires the use of VirtualMalloc/VirtualFree to alloc/free + executable memory. */ +# define FFI_MMAP_EXEC_WRIT 1 +# endif +#endif + +#if FFI_MMAP_EXEC_WRIT && !defined FFI_MMAP_EXEC_SELINUX +# ifdef __linux__ +/* When defined to 1 check for SELinux and if SELinux is active, + don't attempt PROT_EXEC|PROT_WRITE mapping at all, as that + might cause audit messages. */ +# define FFI_MMAP_EXEC_SELINUX 1 +# endif +#endif + +#if FFI_CLOSURES + +# if FFI_EXEC_TRAMPOLINE_TABLE + +// Per-target implementation; It's unclear what can reasonable be shared between two OS/architecture implementations. + +# elif FFI_MMAP_EXEC_WRIT /* !FFI_EXEC_TRAMPOLINE_TABLE */ + +#define USE_LOCKS 1 +#define USE_DL_PREFIX 1 +#ifdef __GNUC__ +#ifndef USE_BUILTIN_FFS +#define USE_BUILTIN_FFS 1 +#endif +#endif + +/* We need to use mmap, not sbrk. */ +#define HAVE_MORECORE 0 + +/* We could, in theory, support mremap, but it wouldn't buy us anything. */ +#define HAVE_MREMAP 0 + +/* We have no use for this, so save some code and data. */ +#define NO_MALLINFO 1 + +/* We need all allocations to be in regular segments, otherwise we + lose track of the corresponding code address. */ +#define DEFAULT_MMAP_THRESHOLD MAX_SIZE_T + +/* Don't allocate more than a page unless needed. */ +#define DEFAULT_GRANULARITY ((size_t)malloc_getpagesize) + +#if FFI_CLOSURE_TEST +/* Don't release single pages, to avoid a worst-case scenario of + continuously allocating and releasing single pages, but release + pairs of pages, which should do just as well given that allocations + are likely to be small. */ +#define DEFAULT_TRIM_THRESHOLD ((size_t)malloc_getpagesize) +#endif + +#include +#include +#include +#include +#ifndef _MSC_VER +#include +#endif +#include +#include +#if !defined(X86_WIN32) && !defined(X86_WIN64) +#ifdef HAVE_MNTENT +#include +#endif /* HAVE_MNTENT */ +#include +#include + +/* We don't want sys/mman.h to be included after we redefine mmap and + dlmunmap. */ +#include +#define LACKS_SYS_MMAN_H 1 + +#if FFI_MMAP_EXEC_SELINUX +#include +#include + +static int selinux_enabled = -1; + +static int +selinux_enabled_check (void) +{ + struct statfs sfs; + FILE *f; + char *buf = NULL; + size_t len = 0; + + if (statfs ("/selinux", &sfs) >= 0 + && (unsigned int) sfs.f_type == 0xf97cff8cU) + return 1; + f = fopen ("/proc/mounts", "r"); + if (f == NULL) + return 0; + while (getline (&buf, &len, f) >= 0) + { + char *p = strchr (buf, ' '); + if (p == NULL) + break; + p = strchr (p + 1, ' '); + if (p == NULL) + break; + if (strncmp (p + 1, "selinuxfs ", 10) == 0) + { + free (buf); + fclose (f); + return 1; + } + } + free (buf); + fclose (f); + return 0; +} + +#define is_selinux_enabled() (selinux_enabled >= 0 ? selinux_enabled \ + : (selinux_enabled = selinux_enabled_check ())) + +#else + +#define is_selinux_enabled() 0 + +#endif /* !FFI_MMAP_EXEC_SELINUX */ + +#elif defined (__CYGWIN__) || defined(__INTERIX) + +#include + +/* Cygwin is Linux-like, but not quite that Linux-like. */ +#define is_selinux_enabled() 0 + +#endif /* !defined(X86_WIN32) && !defined(X86_WIN64) */ + +/* Declare all functions defined in dlmalloc.c as static. */ +static void *dlmalloc(size_t); +static void dlfree(void*); +static void *dlcalloc(size_t, size_t) MAYBE_UNUSED; +static void *dlrealloc(void *, size_t) MAYBE_UNUSED; +static void *dlmemalign(size_t, size_t) MAYBE_UNUSED; +static void *dlvalloc(size_t) MAYBE_UNUSED; +static int dlmallopt(int, int) MAYBE_UNUSED; +static size_t dlmalloc_footprint(void) MAYBE_UNUSED; +static size_t dlmalloc_max_footprint(void) MAYBE_UNUSED; +static void** dlindependent_calloc(size_t, size_t, void**) MAYBE_UNUSED; +static void** dlindependent_comalloc(size_t, size_t*, void**) MAYBE_UNUSED; +static void *dlpvalloc(size_t) MAYBE_UNUSED; +static int dlmalloc_trim(size_t) MAYBE_UNUSED; +static size_t dlmalloc_usable_size(void*) MAYBE_UNUSED; +static void dlmalloc_stats(void) MAYBE_UNUSED; + +#if !(defined(X86_WIN32) || defined(X86_WIN64) || defined(__OS2__)) || defined (__CYGWIN__) || defined(__INTERIX) +/* Use these for mmap and munmap within dlmalloc.c. */ +static void *dlmmap(void *, size_t, int, int, int, off_t); +static int dlmunmap(void *, size_t); +#endif /* !(defined(X86_WIN32) || defined(X86_WIN64) || defined(__OS2__)) || defined (__CYGWIN__) || defined(__INTERIX) */ + +#define mmap dlmmap +#define munmap dlmunmap + +#include "dlmalloc.c" + +#undef mmap +#undef munmap + +#if !(defined(X86_WIN32) || defined(X86_WIN64) || defined(__OS2__)) || defined (__CYGWIN__) || defined(__INTERIX) + +/* A mutex used to synchronize access to *exec* variables in this file. */ +static pthread_mutex_t open_temp_exec_file_mutex = PTHREAD_MUTEX_INITIALIZER; + +/* A file descriptor of a temporary file from which we'll map + executable pages. */ +static int execfd = -1; + +/* The amount of space already allocated from the temporary file. */ +static size_t execsize = 0; + +/* Open a temporary file name, and immediately unlink it. */ +static int +open_temp_exec_file_name (char *name) +{ + int fd = mkstemp (name); + + if (fd != -1) + unlink (name); + + return fd; +} + +/* Open a temporary file in the named directory. */ +static int +open_temp_exec_file_dir (const char *dir) +{ + static const char suffix[] = "/ffiXXXXXX"; + int lendir = strlen (dir); + char *tempname = __builtin_alloca (lendir + sizeof (suffix)); + + if (!tempname) + return -1; + + memcpy (tempname, dir, lendir); + memcpy (tempname + lendir, suffix, sizeof (suffix)); + + return open_temp_exec_file_name (tempname); +} + +/* Open a temporary file in the directory in the named environment + variable. */ +static int +open_temp_exec_file_env (const char *envvar) +{ + const char *value = getenv (envvar); + + if (!value) + return -1; + + return open_temp_exec_file_dir (value); +} + +#ifdef HAVE_MNTENT +/* Open a temporary file in an executable and writable mount point + listed in the mounts file. Subsequent calls with the same mounts + keep searching for mount points in the same file. Providing NULL + as the mounts file closes the file. */ +static int +open_temp_exec_file_mnt (const char *mounts) +{ + static const char *last_mounts; + static FILE *last_mntent; + + if (mounts != last_mounts) + { + if (last_mntent) + endmntent (last_mntent); + + last_mounts = mounts; + + if (mounts) + last_mntent = setmntent (mounts, "r"); + else + last_mntent = NULL; + } + + if (!last_mntent) + return -1; + + for (;;) + { + int fd; + struct mntent mnt; + char buf[MAXPATHLEN * 3]; + + if (getmntent_r (last_mntent, &mnt, buf, sizeof (buf)) == NULL) + return -1; + + if (hasmntopt (&mnt, "ro") + || hasmntopt (&mnt, "noexec") + || access (mnt.mnt_dir, W_OK)) + continue; + + fd = open_temp_exec_file_dir (mnt.mnt_dir); + + if (fd != -1) + return fd; + } +} +#endif /* HAVE_MNTENT */ + +/* Instructions to look for a location to hold a temporary file that + can be mapped in for execution. */ +static struct +{ + int (*func)(const char *); + const char *arg; + int repeat; +} open_temp_exec_file_opts[] = { + { open_temp_exec_file_env, "TMPDIR", 0 }, + { open_temp_exec_file_dir, "/tmp", 0 }, + { open_temp_exec_file_dir, "/var/tmp", 0 }, + { open_temp_exec_file_dir, "/dev/shm", 0 }, + { open_temp_exec_file_env, "HOME", 0 }, +#ifdef HAVE_MNTENT + { open_temp_exec_file_mnt, "/etc/mtab", 1 }, + { open_temp_exec_file_mnt, "/proc/mounts", 1 }, +#endif /* HAVE_MNTENT */ +}; + +/* Current index into open_temp_exec_file_opts. */ +static int open_temp_exec_file_opts_idx = 0; + +/* Reset a current multi-call func, then advances to the next entry. + If we're at the last, go back to the first and return nonzero, + otherwise return zero. */ +static int +open_temp_exec_file_opts_next (void) +{ + if (open_temp_exec_file_opts[open_temp_exec_file_opts_idx].repeat) + open_temp_exec_file_opts[open_temp_exec_file_opts_idx].func (NULL); + + open_temp_exec_file_opts_idx++; + if (open_temp_exec_file_opts_idx + == (sizeof (open_temp_exec_file_opts) + / sizeof (*open_temp_exec_file_opts))) + { + open_temp_exec_file_opts_idx = 0; + return 1; + } + + return 0; +} + +/* Return a file descriptor of a temporary zero-sized file in a + writable and exexutable filesystem. */ +static int +open_temp_exec_file (void) +{ + int fd; + + do + { + fd = open_temp_exec_file_opts[open_temp_exec_file_opts_idx].func + (open_temp_exec_file_opts[open_temp_exec_file_opts_idx].arg); + + if (!open_temp_exec_file_opts[open_temp_exec_file_opts_idx].repeat + || fd == -1) + { + if (open_temp_exec_file_opts_next ()) + break; + } + } + while (fd == -1); + + return fd; +} + +/* Map in a chunk of memory from the temporary exec file into separate + locations in the virtual memory address space, one writable and one + executable. Returns the address of the writable portion, after + storing an offset to the corresponding executable portion at the + last word of the requested chunk. */ +static void * +dlmmap_locked (void *start, size_t length, int prot, int flags, off_t offset) +{ + void *ptr; + + if (execfd == -1) + { + open_temp_exec_file_opts_idx = 0; + retry_open: + execfd = open_temp_exec_file (); + if (execfd == -1) + return MFAIL; + } + + offset = execsize; + + if (ftruncate (execfd, offset + length)) + return MFAIL; + + flags &= ~(MAP_PRIVATE | MAP_ANONYMOUS); + flags |= MAP_SHARED; + + ptr = mmap (NULL, length, (prot & ~PROT_WRITE) | PROT_EXEC, + flags, execfd, offset); + if (ptr == MFAIL) + { + if (!offset) + { + close (execfd); + goto retry_open; + } + ftruncate (execfd, offset); + return MFAIL; + } + else if (!offset + && open_temp_exec_file_opts[open_temp_exec_file_opts_idx].repeat) + open_temp_exec_file_opts_next (); + + start = mmap (start, length, prot, flags, execfd, offset); + + if (start == MFAIL) + { + munmap (ptr, length); + ftruncate (execfd, offset); + return start; + } + + mmap_exec_offset ((char *)start, length) = (char*)ptr - (char*)start; + + execsize += length; + + return start; +} + +/* Map in a writable and executable chunk of memory if possible. + Failing that, fall back to dlmmap_locked. */ +static void * +dlmmap (void *start, size_t length, int prot, + int flags, int fd, off_t offset) +{ + void *ptr; + + assert (start == NULL && length % malloc_getpagesize == 0 + && prot == (PROT_READ | PROT_WRITE) + && flags == (MAP_PRIVATE | MAP_ANONYMOUS) + && fd == -1 && offset == 0); + +#if FFI_CLOSURE_TEST + printf ("mapping in %zi\n", length); +#endif + + if (execfd == -1 && !is_selinux_enabled ()) + { + ptr = mmap (start, length, prot | PROT_EXEC, flags, fd, offset); + + if (ptr != MFAIL || (errno != EPERM && errno != EACCES)) + /* Cool, no need to mess with separate segments. */ + return ptr; + + /* If MREMAP_DUP is ever introduced and implemented, try mmap + with ((prot & ~PROT_WRITE) | PROT_EXEC) and mremap with + MREMAP_DUP and prot at this point. */ + } + + if (execsize == 0 || execfd == -1) + { + pthread_mutex_lock (&open_temp_exec_file_mutex); + ptr = dlmmap_locked (start, length, prot, flags, offset); + pthread_mutex_unlock (&open_temp_exec_file_mutex); + + return ptr; + } + + return dlmmap_locked (start, length, prot, flags, offset); +} + +/* Release memory at the given address, as well as the corresponding + executable page if it's separate. */ +static int +dlmunmap (void *start, size_t length) +{ + /* We don't bother decreasing execsize or truncating the file, since + we can't quite tell whether we're unmapping the end of the file. + We don't expect frequent deallocation anyway. If we did, we + could locate pages in the file by writing to the pages being + deallocated and checking that the file contents change. + Yuck. */ + msegmentptr seg = segment_holding (gm, start); + void *code; + +#if FFI_CLOSURE_TEST + printf ("unmapping %zi\n", length); +#endif + + if (seg && (code = add_segment_exec_offset (start, seg)) != start) + { + int ret = munmap (code, length); + if (ret) + return ret; + } + + return munmap (start, length); +} + +#if FFI_CLOSURE_FREE_CODE +/* Return segment holding given code address. */ +static msegmentptr +segment_holding_code (mstate m, char* addr) +{ + msegmentptr sp = &m->seg; + for (;;) { + if (addr >= add_segment_exec_offset (sp->base, sp) + && addr < add_segment_exec_offset (sp->base, sp) + sp->size) + return sp; + if ((sp = sp->next) == 0) + return 0; + } +} +#endif + +#endif /* !(defined(X86_WIN32) || defined(X86_WIN64) || defined(__OS2__)) || defined (__CYGWIN__) || defined(__INTERIX) */ + +/* Allocate a chunk of memory with the given size. Returns a pointer + to the writable address, and sets *CODE to the executable + corresponding virtual address. */ +void * +ffi_closure_alloc (size_t size, void **code) +{ + void *ptr; + + if (!code) + return NULL; + + ptr = dlmalloc (size); + + if (ptr) + { + msegmentptr seg = segment_holding (gm, ptr); + + *code = add_segment_exec_offset (ptr, seg); + } + + return ptr; +} + +/* Release a chunk of memory allocated with ffi_closure_alloc. If + FFI_CLOSURE_FREE_CODE is nonzero, the given address can be the + writable or the executable address given. Otherwise, only the + writable address can be provided here. */ +void +ffi_closure_free (void *ptr) +{ +#if FFI_CLOSURE_FREE_CODE + msegmentptr seg = segment_holding_code (gm, ptr); + + if (seg) + ptr = sub_segment_exec_offset (ptr, seg); +#endif + + dlfree (ptr); +} + + +#if FFI_CLOSURE_TEST +/* Do some internal sanity testing to make sure allocation and + deallocation of pages are working as intended. */ +int main () +{ + void *p[3]; +#define GET(idx, len) do { p[idx] = dlmalloc (len); printf ("allocated %zi for p[%i]\n", (len), (idx)); } while (0) +#define PUT(idx) do { printf ("freeing p[%i]\n", (idx)); dlfree (p[idx]); } while (0) + GET (0, malloc_getpagesize / 2); + GET (1, 2 * malloc_getpagesize - 64 * sizeof (void*)); + PUT (1); + GET (1, 2 * malloc_getpagesize); + GET (2, malloc_getpagesize / 2); + PUT (1); + PUT (0); + PUT (2); + return 0; +} +#endif /* FFI_CLOSURE_TEST */ +# else /* ! FFI_MMAP_EXEC_WRIT */ + +/* On many systems, memory returned by malloc is writable and + executable, so just use it. */ + +#include + +void * +ffi_closure_alloc (size_t size, void **code) +{ + if (!code) + return NULL; + + return *code = malloc (size); +} + +void +ffi_closure_free (void *ptr) +{ + free (ptr); +} + +# endif /* ! FFI_MMAP_EXEC_WRIT */ +#endif /* FFI_CLOSURES */ diff --git a/include/hs_libffi_closure.h b/include/hs_libffi_closure.h new file mode 100644 --- /dev/null +++ b/include/hs_libffi_closure.h @@ -0,0 +1,4 @@ +#include + +void * hs_ffi_closure_alloc (size_t size, void **code); +void hs_ffi_closure_free (void *ptr); diff --git a/libffi-dynamic.cabal b/libffi-dynamic.cabal new file mode 100644 --- /dev/null +++ b/libffi-dynamic.cabal @@ -0,0 +1,54 @@ +name: libffi-dynamic +version: 0.0.0.1 +stability: experimental + +cabal-version: >= 1.6 +build-type: Simple + +author: James Cook +maintainer: James Cook +license: PublicDomain +homepage: /dev/null + +category: Foreign +synopsis: LibFFI interface with dynamic bidirectional + type-driven binding generation +description: LibFFI interface with support for importing and + exporting function types inferred at compile time, + constructed at runtime, or a combination of both. + +source-repository head + type: git + location: git://github.com/mokus0/libffi-dynamic.git + +Library + hs-source-dirs: src + exposed-modules: Foreign.Dynamic + Foreign.Wrapper + Foreign.LibFFI.Dynamic + Foreign.LibFFI.Dynamic.Base + Foreign.LibFFI.Dynamic.CIF + Foreign.LibFFI.Dynamic.Closure + Foreign.LibFFI.Dynamic.FFIType + Foreign.LibFFI.Dynamic.Type + ghc-options: -fwarn-unused-binds -fwarn-unused-imports + build-depends: base >= 3 && < 5, + contravariant, + hashable, + intern + extra-libraries: ffi + + -- Custom build of libffi's closure allocator, so we can use + -- ffi_closure_free on code pointers. + -- also, GHC's ffi_closure_alloc just doesn't work on Mac OS + -- anyway because it appears to be build without FFI_MMAP_EXEC_WRIT. + c-sources: cbits/closures.c + cc-options: -DFFI_CLOSURES=1 + -DFFI_MMAP_EXEC_WRIT=1 + -DMAYBE_UNUSED= + -DFFI_CLOSURE_FREE_CODE=1 + -Dffi_closure_alloc=hs_ffi_closure_alloc + -Dffi_closure_free=hs_ffi_closure_free + + include-dirs: include + install-includes: hs_libffi_closure.h diff --git a/src/Foreign/Dynamic.hs b/src/Foreign/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Dynamic.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +module Foreign.Dynamic + ( Dyn, mkDyn, consDyn + , importDyn + , importDynWithABI + , importDynWithCIF + , importDynWithCall + + , Dynamic, dynamic, dyn + ) where + +import Control.Exception +import Foreign.LibFFI.Dynamic.CIF +import Foreign.LibFFI.Dynamic.FFIType +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +type Call t = Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO () +type WithArgs = Int -> (Ptr (Ptr ()) -> IO ()) -> IO () + +newtype Dyn a b = Dyn + { prepDynamic :: Int -> WithArgs -> Call a -> b + } + +instance Functor (Dyn a) where + fmap f (Dyn prep) = Dyn (\n withArgs call -> f (prep n withArgs call)) + +mkDyn :: InRet a b -> Dyn (IO a) (IO b) +mkDyn ret = Dyn + { prepDynamic = \n withArgs call -> + withInRet ret (withArgs n . call) + } + +infixr 5 `consDyn` + +consDyn :: OutArg a b -> Dyn c d -> Dyn (a -> c) (b -> d) +consDyn arg dyn = dyn + { prepDynamic = \i withArgs call x -> + let withMoreArgs n action = + withOutArg arg x $ \p -> + withArgs n $ \args -> do + pokeElemOff args i (castPtr p) + action args + in prepDynamic dyn (i+1) withMoreArgs call + } + +importDyn :: SigType a => Dyn a b -> FunPtr a -> b +importDyn = importDynWithCIF cif + +importDynWithABI :: SigType a => ABI -> Dyn a b -> FunPtr a -> b +importDynWithABI = importDynWithCIF . cifWithABI + +importDynWithCIF :: CIF a -> Dyn a b -> FunPtr a -> b +importDynWithCIF = importDynWithCall . callWithCIF + +importDynWithCall :: (FunPtr a -> Ptr (SigReturn a) -> Ptr (Ptr ()) -> IO ()) -> Dyn a b -> FunPtr a -> b +importDynWithCall !call !dyn = + prepDynamic dyn 0 withArgs . call + where + withArgs n = bracket (mallocArray n) free + +dynamic :: Dynamic a => FunPtr a -> a +dynamic = importDyn stdDyn + +dyn :: Dynamic a => Dyn a a +dyn = stdDyn + +class SigType a => Dynamic a where + stdDyn :: Dyn a a + +instance RetType a => Dynamic (IO a) where + stdDyn = mkDyn inRet + +instance (ArgType a, Dynamic b) => Dynamic (a -> b) where + stdDyn = consDyn outArg stdDyn diff --git a/src/Foreign/LibFFI/Dynamic.hs b/src/Foreign/LibFFI/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic.hs @@ -0,0 +1,19 @@ +module Foreign.LibFFI.Dynamic + ( module Foreign.LibFFI.Dynamic.Base + , module Foreign.LibFFI.Dynamic.CIF + , module Foreign.LibFFI.Dynamic.Closure + , module Foreign.LibFFI.Dynamic.FFIType + , module Foreign.LibFFI.Dynamic.Type + + , module Foreign.Dynamic + , module Foreign.Wrapper + ) where + +import Foreign.LibFFI.Dynamic.Base +import Foreign.LibFFI.Dynamic.CIF +import Foreign.LibFFI.Dynamic.Closure +import Foreign.LibFFI.Dynamic.FFIType +import Foreign.LibFFI.Dynamic.Type + +import Foreign.Dynamic +import Foreign.Wrapper diff --git a/src/Foreign/LibFFI/Dynamic/Base.hsc b/src/Foreign/LibFFI/Dynamic/Base.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic/Base.hsc @@ -0,0 +1,10 @@ +module Foreign.LibFFI.Dynamic.Base where + +import Foreign.C.Types + +#include + +sizeOfClosure = (#size ffi_closure) :: CSize + +newtype FFI_Status = FFI_Status CInt + diff --git a/src/Foreign/LibFFI/Dynamic/CIF.hsc b/src/Foreign/LibFFI/Dynamic/CIF.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic/CIF.hsc @@ -0,0 +1,162 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Foreign.LibFFI.Dynamic.CIF + ( ABI(..) + , defaultABI + + , SomeCIF(..) + , getCIF + + , CIF(..) + , toSomeCIF + , cif + , cifWithABI + + , abi + , retType + , argTypes, nArgs + , cifFlags + + , SigType, SigReturn + , retTypeOf, argTypesOf + , call, callWithABI, callWithCIF + ) where + +import Control.Applicative +import Data.Hashable +import Data.Interned +import Data.List +import Foreign.LibFFI.Dynamic.Base +import Foreign.LibFFI.Dynamic.FFIType +import Foreign.LibFFI.Dynamic.Type +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe + +#include + +newtype ABI = ABI CInt + deriving (Eq, Ord, Show, Storable) + +instance Hashable ABI where + hashWithSalt salt (ABI x) = + hashWithSalt salt (fromIntegral x :: Int) + +defaultABI = ABI (#const FFI_DEFAULT_ABI) + +newtype SomeCIF = SomeCIF (Ptr SomeCIF) + deriving (Eq, Ord, Show) + +instance Interned SomeCIF where + data Description SomeCIF = Sig ABI SomeType [SomeType] + deriving (Eq, Show) + type Uninterned SomeCIF = Description SomeCIF + + describe = id + identify _ (Sig abi ret args) = unsafePerformIO $ do + -- these should not be freed as long as the returned @a@ is reachable + cif <- SomeCIF <$> mallocBytes (#size ffi_cif) + + let nArgs = fromIntegral (length args) + argTypes <- newArray args + + -- TODO: check return code + ffi_prep_cif cif abi nArgs ret argTypes + + return cif + + cache = cifCache + +{-# NOINLINE cifCache #-} +cifCache :: Cache SomeCIF +cifCache = mkCache + +instance Hashable (Description SomeCIF) where + hashWithSalt salt (Sig abi ret args) = + foldl' hashWithSalt (hashWithSalt salt abi) (ret : args) + +foreign import ccall ffi_prep_cif :: SomeCIF -> ABI -> CInt -> SomeType -> Ptr SomeType -> IO FFI_Status + +getCIF :: ABI -> SomeType -> [SomeType] -> SomeCIF +getCIF abi retType argTypes = intern (Sig abi retType argTypes) + +class SigType t where + type SigReturn t + + retTypeOf' :: p t -> SomeType + argTypesOf' :: p t -> [SomeType] + +retTypeOf :: SigType t => p t -> SomeType +retTypeOf = retTypeOf' + +argTypesOf :: SigType t => p t -> [SomeType] +argTypesOf = argTypesOf' + +instance FFIType t => SigType (IO t) where + type SigReturn (IO t) = t + + retTypeOf' = ffiTypeOf_ . (const Nothing :: p (IO b) -> Maybe b) + argTypesOf' _ = [] + +instance (FFIType a, SigType b) => SigType (a -> b) where + type SigReturn (a -> b) = SigReturn b + + retTypeOf' = retTypeOf . (const Nothing :: p (a -> b) -> Maybe b) + argTypesOf' p + = ffiTypeOf_ ((const Nothing :: p (a -> b) -> Maybe a) p) + : argTypesOf ((const Nothing :: p (a -> b) -> Maybe b) p) + +newtype CIF a = CIF SomeCIF + deriving (Eq, Ord, Show) + +toSomeCIF :: CIF a -> SomeCIF +toSomeCIF (CIF c) = c + +cif :: SigType t => CIF t +cif = cifWithABI defaultABI + +cifWithABI :: SigType t => ABI -> CIF t +cifWithABI abi = theCIF + where + theCIF = CIF (getCIF abi (retTypeOf theCIF) (argTypesOf theCIF)) + +call :: SigType t => FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO () +call = callWithCIF theCIF + where + {-# NOINLINE theCIF #-} + theCIF = cif + +callWithABI :: SigType t => ABI -> FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO () +callWithABI abi = callWithCIF theCIF + where + {-# NOINLINE theCIF #-} + theCIF = cifWithABI abi + +foreign import ccall "ffi_call" + callWithCIF :: CIF a -> FunPtr a -> Ptr (SigReturn a) -> Ptr (Ptr ()) -> IO () + +abi :: SomeCIF -> ABI +abi (SomeCIF p) = unsafePerformIO $ do + (#peek ffi_cif, abi) p + +retType :: SomeCIF -> SomeType +retType (SomeCIF p) = unsafePerformIO $ do + (#peek ffi_cif, rtype) p + +argTypes :: SomeCIF -> [SomeType] +argTypes cif@(SomeCIF p) = unsafePerformIO $ do + ts <- (#peek ffi_cif, arg_types) p :: IO (Ptr SomeType) + peekArray (nArgs cif) ts + +nArgs :: SomeCIF -> Int +nArgs (SomeCIF p) = unsafePerformIO $ do + n <- (#peek ffi_cif, nargs) p :: IO CUInt + return $! fromIntegral n + +cifFlags :: SomeCIF -> CUInt +cifFlags (SomeCIF p) = unsafePerformIO $ do + (#peek ffi_cif, flags) p diff --git a/src/Foreign/LibFFI/Dynamic/Closure.hs b/src/Foreign/LibFFI/Dynamic/Closure.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic/Closure.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Foreign.LibFFI.Dynamic.Closure where + +import Foreign.C.Types +import Foreign.LibFFI.Dynamic.Base +import Foreign.LibFFI.Dynamic.CIF +import Foreign.Ptr +import Foreign.Storable + +newtype Closure = Closure (Ptr Closure) +newtype Entry = Entry (FunPtr Entry) deriving (Eq, Ord, Show, Storable) + +foreign import ccall "hs_ffi_closure_alloc" + ffi_closure_alloc :: CSize -> Ptr Entry -> IO Closure +foreign import ccall "hs_ffi_closure_free" + ffi_closure_free :: Closure -> IO () + +type FFI_Impl t a = CIF t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> Ptr a -> IO () + +foreign import ccall "wrapper" wrap_FFI_Impl :: FFI_Impl t a -> IO (FunPtr (FFI_Impl t a)) + +foreign import ccall ffi_prep_closure_loc :: Closure -> CIF t -> FunPtr (FFI_Impl t a) -> Ptr a -> Entry -> IO FFI_Status diff --git a/src/Foreign/LibFFI/Dynamic/FFIType.hsc b/src/Foreign/LibFFI/Dynamic/FFIType.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic/FFIType.hsc @@ -0,0 +1,366 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module Foreign.LibFFI.Dynamic.FFIType where + +import Data.Functor.Contravariant +import Data.Int +import Data.Word +import Foreign.C +import Foreign.LibFFI.Dynamic.Type +import Foreign.Marshal hiding (void) +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable + +#include + +class FFIType a where + ffiType :: Type a + +ffiTypeOf :: FFIType a => p a -> Type a +ffiTypeOf = const ffiType + +ffiTypeOf_ :: FFIType a => p a -> SomeType +ffiTypeOf_ = toSomeType . ffiTypeOf + +newtype InArg a b = InArg { peekArg :: Ptr a -> IO b } +instance Functor (InArg a) where + fmap f arg = InArg (fmap f . peekArg arg) + +castInArg :: InArg a c -> InArg b c +castInArg arg = InArg (peekArg arg . castPtr) + +withInArg :: InArg a b -> Ptr a -> (b -> IO t) -> IO t +withInArg arg p action = peekArg arg p >>= action + +newtype OutArg a b = OutArg { withOutArg :: forall t. b -> (Ptr a -> IO t) -> IO t } +instance Contravariant (OutArg a) where + contramap f arg = OutArg (withOutArg arg . f) + +castOutArg :: OutArg a c -> OutArg b c +castOutArg (OutArg f) = OutArg (\x k -> f x (k . castPtr)) + +composeInArgs :: InArg a (Ptr b) -> InArg b c -> InArg a c +composeInArgs arg1 arg2 = InArg $ \p -> peekArg arg1 p >>= peekArg arg2 + +composeOutArgs :: OutArg b c -> OutArg a (Ptr b) -> OutArg a c +composeOutArgs f g = OutArg $ \x -> withOutArg f x . flip (withOutArg g) + +class FFIType a => ArgType a where + inArg :: InArg a a + default inArg :: Storable a => InArg a a + inArg = InArg peek + + outArg :: OutArg a a + default outArg :: Storable a => OutArg a a + outArg = OutArg with + +data InRet a b = InRet + { allocaRet :: !(forall t. (Ptr a -> IO t) -> IO t) + , peekRet :: !(Ptr a -> IO b) + } +instance Functor (InRet a) where + fmap f ret = ret { peekRet = fmap f . peekRet ret } + +castInRet :: InRet a c -> InRet b c +castInRet ret = InRet + { allocaRet = \k -> allocaRet ret (k . castPtr) + , peekRet = peekRet ret . castPtr + } + +withInRet :: InRet a b -> (Ptr a -> IO t) -> IO b +withInRet ret action = allocaRet ret $ \p -> do + action p + peekRet ret p + +-- OutRet does not need alloc operation because allocation +-- is done by libffi's generated wrappers. +newtype OutRet a b = OutRet { pokeRet :: Ptr a -> b -> IO () } +instance Contravariant (OutRet a) where + contramap f ret = OutRet (\p -> pokeRet ret p . f) + +castOutRet :: OutRet a c -> OutRet b c +castOutRet ret = OutRet (pokeRet ret . castPtr) + +class FFIType a => RetType a where + inRet :: InRet a a + default inRet :: Storable a => InRet a a + inRet = InRet alloca peek + + outRet :: OutRet a a + default outRet :: Storable a => OutRet a a + outRet = OutRet poke + +instance FFIType () where ffiType = void +instance RetType () where + inRet = InRet ($ nullPtr) (\_ -> return ()) + outRet = OutRet (\_ _ -> return ()) + +type BoolRepr = + $( case #{const sizeof(bool)} of + 1 -> [t| Word8 |] + 2 -> [t| Word16 |] + 4 -> [t| Word32 |] + 8 -> [t| Word64 |] + _ -> fail "Bool is weird" + ) + +instance FFIType Bool where + ffiType = castType (ffiType :: Type BoolRepr) + +instance RetType Bool where + inRet = castInRet (fmap fromWord inRet) + where + fromWord :: Word -> Bool + fromWord = (0 /=) + + outRet = castOutRet (contramap toWord outRet) + where + toWord :: Bool -> Word + toWord False = 0 + toWord True = 1 + +instance ArgType Bool where + inArg = castInArg (fmap fromRepr inArg) + where + fromRepr :: BoolRepr -> Bool + fromRepr = (0 /=) + + outArg = castOutArg (contramap toRepr outArg) + where + toRepr :: Bool -> BoolRepr + toRepr False = 0 + toRepr True = 1 + +instance FFIType (Ptr a) where ffiType = pointer +instance ArgType (Ptr a) +instance RetType (Ptr a) + +instance FFIType (FunPtr a) where ffiType = castType pointer +instance ArgType (FunPtr a) +instance RetType (FunPtr a) + +instance FFIType (StablePtr a) where ffiType = castType pointer +instance ArgType (StablePtr a) +instance RetType (StablePtr a) + +instance FFIType Float where ffiType = floating +instance ArgType Float +instance RetType Float + +instance FFIType Double where ffiType = floating +instance ArgType Double +instance RetType Double + +instance FFIType Int where ffiType = sint +instance ArgType Int +instance RetType Int + +inRetViaInt :: Integral a => InRet a a +inRetViaInt = castInRet (fmap (fromIntegral :: Integral a => Int -> a ) inRet) +inRetViaWord :: Integral a => InRet a a +inRetViaWord = castInRet (fmap (fromIntegral :: Integral a => Word -> a ) inRet) + +outRetViaInt :: Integral a => OutRet a a +outRetViaInt = castOutRet (contramap (fromIntegral :: Integral a => a -> Int) outRet) +outRetViaWord :: Integral a => OutRet a a +outRetViaWord = castOutRet (contramap (fromIntegral :: Integral a => a -> Word) outRet) + +instance FFIType Int8 where ffiType = sint8 +instance ArgType Int8 +instance RetType Int8 where + inRet = inRetViaInt + outRet = outRetViaInt + +instance FFIType Int16 where ffiType = sint16 +instance ArgType Int16 +instance RetType Int16 where + inRet = inRetViaInt + outRet = outRetViaInt + +instance FFIType Int32 where ffiType = sint32 +instance ArgType Int32 +instance RetType Int32 where + inRet = inRetViaInt + outRet = outRetViaInt + +instance FFIType Int64 where ffiType = sint64 +instance ArgType Int64 +instance RetType Int64 + +instance FFIType Word where ffiType = uint +instance ArgType Word +instance RetType Word + +instance FFIType Word8 where ffiType = uint8 +instance ArgType Word8 +instance RetType Word8 where + inRet = inRetViaWord + outRet = outRetViaWord + +instance FFIType Word16 where ffiType = uint16 +instance ArgType Word16 +instance RetType Word16 where + inRet = inRetViaWord + outRet = outRetViaWord + +instance FFIType Word32 where ffiType = uint32 +instance ArgType Word32 +instance RetType Word32 where + inRet = inRetViaWord + outRet = outRetViaWord + +instance FFIType Word64 where ffiType = uint64 +instance ArgType Word64 +instance RetType Word64 + +deriving instance FFIType CChar +deriving instance ArgType CChar +deriving instance RetType CChar + +deriving instance FFIType CSChar +deriving instance ArgType CSChar +deriving instance RetType CSChar + +deriving instance FFIType CUChar +deriving instance ArgType CUChar +deriving instance RetType CUChar + +deriving instance FFIType CShort +deriving instance ArgType CShort +deriving instance RetType CShort + +deriving instance FFIType CUShort +deriving instance ArgType CUShort +deriving instance RetType CUShort + +deriving instance FFIType CInt +deriving instance ArgType CInt +deriving instance RetType CInt + +deriving instance FFIType CUInt +deriving instance ArgType CUInt +deriving instance RetType CUInt + +deriving instance FFIType CLong +deriving instance ArgType CLong +deriving instance RetType CLong + +deriving instance FFIType CULong +deriving instance ArgType CULong +deriving instance RetType CULong + +deriving instance FFIType CPtrdiff +deriving instance ArgType CPtrdiff +deriving instance RetType CPtrdiff + +deriving instance FFIType CSize +deriving instance ArgType CSize +deriving instance RetType CSize + +deriving instance FFIType CWchar +deriving instance ArgType CWchar +deriving instance RetType CWchar + +deriving instance FFIType CSigAtomic +deriving instance ArgType CSigAtomic +deriving instance RetType CSigAtomic + +deriving instance FFIType CLLong +deriving instance ArgType CLLong +deriving instance RetType CLLong + +deriving instance FFIType CULLong +deriving instance ArgType CULLong +deriving instance RetType CULLong + +deriving instance FFIType CIntPtr +deriving instance ArgType CIntPtr +deriving instance RetType CIntPtr + +deriving instance FFIType CUIntPtr +deriving instance ArgType CUIntPtr +deriving instance RetType CUIntPtr + +deriving instance FFIType CIntMax +deriving instance ArgType CIntMax +deriving instance RetType CIntMax + +deriving instance FFIType CUIntMax +deriving instance ArgType CUIntMax +deriving instance RetType CUIntMax + +deriving instance FFIType CClock +deriving instance ArgType CClock +deriving instance RetType CClock + +deriving instance FFIType CTime +deriving instance ArgType CTime +deriving instance RetType CTime + +deriving instance FFIType CUSeconds +deriving instance ArgType CUSeconds +deriving instance RetType CUSeconds + +deriving instance FFIType CSUSeconds +deriving instance ArgType CSUSeconds +deriving instance RetType CSUSeconds + +deriving instance FFIType CFloat +deriving instance ArgType CFloat +deriving instance RetType CFloat + +deriving instance FFIType CDouble +deriving instance ArgType CDouble +deriving instance RetType CDouble + +outByRef :: OutArg a b -> OutArg (Ptr a) b +outByRef arg = composeOutArgs arg outArg + +stringArg :: OutArg CString String +stringArg = outByRef (OutArg withCString) + +instance (FFIType a, FFIType b) + => FFIType (a, b) where + ffiType = t + where + t = Type $ struct + [ ffiTypeOf_ ((castType :: Type (a,b) -> Type a) t) + , ffiTypeOf_ ((castType :: Type (a,b) -> Type b) t) + ] + +instance (FFIType a, FFIType b, FFIType c) + => FFIType (a, b, c) where + ffiType = t + where + t = Type $ struct + [ ffiTypeOf_ ((castType :: Type (a,b,c) -> Type a) t) + , ffiTypeOf_ ((castType :: Type (a,b,c) -> Type b) t) + , ffiTypeOf_ ((castType :: Type (a,b,c) -> Type c) t) + ] + +instance (FFIType a, FFIType b, FFIType c, FFIType d) + => FFIType (a, b, c, d) where + ffiType = t + where + t = Type $ struct + [ ffiTypeOf_ ((castType :: Type (a,b,c,d) -> Type a) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d) -> Type b) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d) -> Type c) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d) -> Type d) t) + ] + +instance (FFIType a, FFIType b, FFIType c, FFIType d, FFIType e) + => FFIType (a, b, c, d, e) where + ffiType = t + where + t = Type $ struct + [ ffiTypeOf_ ((castType :: Type (a,b,c,d,e) -> Type a) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d,e) -> Type b) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d,e) -> Type c) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d,e) -> Type d) t) + , ffiTypeOf_ ((castType :: Type (a,b,c,d,e) -> Type e) t) + ] diff --git a/src/Foreign/LibFFI/Dynamic/Type.hsc b/src/Foreign/LibFFI/Dynamic/Type.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/LibFFI/Dynamic/Type.hsc @@ -0,0 +1,181 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Foreign.LibFFI.Dynamic.Type + ( SomeType(..), Type(..) + , toSomeType, castType + + , void + , pointer + , float, double, longdouble, floating + , sint8, sint16, sint32, sint64, sint + , uint8, uint16, uint32, uint64, uint + , struct + + , typeSize + , typeAlignment + , typeType + , typeIsStruct + , structElements + + , TypeDescription(..) + , describeType + , getType + ) where + +import Data.Hashable +import Data.Int +import Data.Interned +import Data.List +import Data.Word +import Foreign.C.Types +import Foreign.Marshal hiding (void) +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe + +#include + +newtype SomeType = SomeType (Ptr SomeType) deriving (Eq, Ord, Show, Storable) +instance Hashable SomeType where + hashWithSalt salt (SomeType p) = + hashWithSalt salt (fromIntegral (ptrToIntPtr p) :: Int) + +newtype Type t = Type SomeType deriving (Eq, Ord, Show, Storable) + +toSomeType :: Type a -> SomeType +toSomeType (Type t) = t + +castType :: Type a -> Type b +castType (Type t) = Type t + +sizeOf1 :: Storable a => p a -> Int +sizeOf1 = sizeOf . (undefined :: p a -> a) + +foreign import ccall "&ffi_type_void" void :: Type () +foreign import ccall "&ffi_type_pointer" pointer :: Type (Ptr a) + +foreign import ccall "&ffi_type_float" float :: Type Float +foreign import ccall "&ffi_type_double" double :: Type Double +foreign import ccall "&ffi_type_longdouble" longdouble :: Type Double + +floating :: Storable a => Type a +floating = t + where + t = case sizeOf1 t of + 4 -> castType float + 8 -> castType double + (#const sizeof(long double)) -> castType longdouble + _ -> error "floating: invalid size for floating point type" + +foreign import ccall "&ffi_type_sint8" sint8 :: Type Int8 +foreign import ccall "&ffi_type_sint16" sint16 :: Type Int16 +foreign import ccall "&ffi_type_sint32" sint32 :: Type Int32 +foreign import ccall "&ffi_type_sint64" sint64 :: Type Int64 + +sint :: Storable a => Type a +sint = t + where + t = case sizeOf1 t of + 1 -> castType sint8 + 2 -> castType sint16 + 4 -> castType sint32 + 8 -> castType sint64 + _ -> error "sint: invalid size for signed int type" + +foreign import ccall "&ffi_type_uint8" uint8 :: Type Word8 +foreign import ccall "&ffi_type_uint16" uint16 :: Type Word16 +foreign import ccall "&ffi_type_uint32" uint32 :: Type Word32 +foreign import ccall "&ffi_type_uint64" uint64 :: Type Word64 + +uint :: Storable a => Type a +uint = t + where + t = case sizeOf1 t of + 1 -> castType uint8 + 2 -> castType uint16 + 4 -> castType uint32 + 8 -> castType uint64 + _ -> error "uint: invalid size for unsigned int type" + +typeSize :: SomeType -> CSize +typeSize (SomeType p) = unsafePerformIO $ + (#peek ffi_type, size) p + +typeAlignment :: SomeType -> CUShort +typeAlignment (SomeType p) = unsafePerformIO $ + (#peek ffi_type, alignment) p + +typeType :: SomeType -> CUShort +typeType (SomeType p) = unsafePerformIO $ + (#peek ffi_type, type) p + +typeIsStruct :: SomeType -> Bool +typeIsStruct t = typeType t == #const FFI_TYPE_STRUCT + +structElements :: SomeType -> [SomeType] +structElements st@(SomeType t) + | typeIsStruct st = unsafePerformIO + ((#peek ffi_type, elements) t >>= loop) + | otherwise = [] + where + nextPtr p = plusPtr p (sizeOf p) + loop elems = do + e <- peek elems + return $! if e == SomeType nullPtr + then [] + else e : unsafePerformIO (loop (nextPtr elems)) + +mkStruct :: [SomeType] -> IO SomeType +mkStruct ts = do + t <- mallocBytes (#size ffi_type) + + (#poke ffi_type, size) t (0 :: CSize) + (#poke ffi_type, alignment) t (0 :: CShort) + (#poke ffi_type, type) t ((#const FFI_TYPE_STRUCT) :: CShort) + (#poke ffi_type, elements) t =<< newArray0 (SomeType nullPtr) ts + + return (SomeType t) + +newtype StructType = StructType {structType :: SomeType} + deriving (Eq, Ord, Show) + +instance Interned StructType where + data Description StructType = StructElems [SomeType] + deriving (Eq, Ord, Show) + + type Uninterned StructType = [SomeType] + + describe = StructElems + identify _ = StructType . unsafePerformIO . mkStruct + + cache = structTypeCache + +instance Uninternable StructType where + unintern (StructType t) = structElements t + +{-# NOINLINE structTypeCache #-} +structTypeCache :: Cache StructType +structTypeCache = mkCache + +instance Hashable (Description StructType) where + hashWithSalt salt (StructElems ts) = foldl' (\s -> hashWithSalt s . f) salt ts + where f (SomeType t) = fromIntegral (ptrToIntPtr t) :: Int + +struct :: [SomeType] -> SomeType +struct = structType . intern + +data TypeDescription + = Prim SomeType + | Struct [TypeDescription] + deriving (Eq, Ord, Show) + +describeType :: SomeType -> TypeDescription +describeType t + | typeIsStruct t = Struct (map describeType (structElements t)) + | otherwise = Prim t + +getType :: TypeDescription -> SomeType +getType (Prim t) = t +getType (Struct ts) = struct (map getType ts) diff --git a/src/Foreign/Wrapper.hs b/src/Foreign/Wrapper.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Wrapper.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +module Foreign.Wrapper + ( Wrap, mkWrap, consWrap + , exportWrap + , exportWrapWithABI + , exportWrapWithCIF + + , Wrapper, wrap, wrapper + ) where + +import Foreign.LibFFI.Dynamic.Base +import Foreign.LibFFI.Dynamic.CIF +import Foreign.LibFFI.Dynamic.Closure +import Foreign.LibFFI.Dynamic.FFIType +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +newtype Wrap a b = Wrap + { prepWrapper :: a -> Ptr (Ptr ()) -> Ptr (SigReturn b) -> IO () + } + +mkWrap :: OutRet a b -> Wrap (IO b) (IO a) +mkWrap ret = Wrap + { prepWrapper = \fun _ p -> fun >>= pokeRet ret p + } + +infixr 5 `consWrap` + +consWrap :: InArg a b -> Wrap c d -> Wrap (b -> c) (a -> d) +consWrap arg wrap = wrap + { prepWrapper = + \fun args ret -> do + arg0 <- peek args + withInArg arg (castPtr arg0) + (\arg -> prepWrapper wrap + (fun arg) + (plusPtr args (sizeOf args)) + ret) + } + +fromEntry :: Entry -> FunPtr a +fromEntry (Entry p) = castFunPtr p + +exportWrap :: SigType b => Wrap a b -> a -> IO (FunPtr b) +exportWrap = exportWrapWithABI defaultABI + +exportWrapWithABI :: SigType b => ABI -> Wrap a b -> a -> IO (FunPtr b) +exportWrapWithABI = exportWrapWithCIF . cifWithABI + +exportWrapWithCIF :: CIF b -> Wrap a b -> a -> IO (FunPtr b) +exportWrapWithCIF !cif !wrap !fun = do + impl <- wrap_FFI_Impl $ \_ ret args _ -> prepWrapper wrap fun args ret + + alloca $ \entryPtr -> do + closure <- ffi_closure_alloc sizeOfClosure entryPtr + entry <- peek entryPtr + + ffi_prep_closure_loc closure cif impl nullPtr entry + + return (fromEntry entry) + +wrapper :: Wrapper a => a -> IO (FunPtr a) +wrapper = exportWrap stdWrap + +class SigType a => Wrapper a where + stdWrap :: Wrap a a + +wrap :: Wrapper a => Wrap a a +wrap = stdWrap + +instance RetType a => Wrapper (IO a) where + stdWrap = mkWrap outRet + +instance (ArgType a, Wrapper b) => Wrapper (a -> b) where + stdWrap = consWrap inArg stdWrap