libffi-dynamic (empty) → 0.0.0.1
raw patch · 12 files changed
+1591/−0 lines, 12 filesdep +basedep +contravariantdep +hashablesetup-changed
Dependencies added: base, contravariant, hashable, intern
Files
- Setup.lhs +5/−0
- cbits/closures.c +615/−0
- include/hs_libffi_closure.h +4/−0
- libffi-dynamic.cabal +54/−0
- src/Foreign/Dynamic.hs +76/−0
- src/Foreign/LibFFI/Dynamic.hs +19/−0
- src/Foreign/LibFFI/Dynamic/Base.hsc +10/−0
- src/Foreign/LibFFI/Dynamic/CIF.hsc +162/−0
- src/Foreign/LibFFI/Dynamic/Closure.hs +23/−0
- src/Foreign/LibFFI/Dynamic/FFIType.hsc +366/−0
- src/Foreign/LibFFI/Dynamic/Type.hsc +181/−0
- src/Foreign/Wrapper.hs +76/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ cbits/closures.c view
@@ -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 <ffi.h>+// #include <ffi_common.h> // 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 <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+#include <errno.h>+#ifndef _MSC_VER+#include <unistd.h>+#endif+#include <string.h>+#include <stdio.h>+#if !defined(X86_WIN32) && !defined(X86_WIN64)+#ifdef HAVE_MNTENT+#include <mntent.h>+#endif /* HAVE_MNTENT */+#include <sys/param.h>+#include <pthread.h>++/* We don't want sys/mman.h to be included after we redefine mmap and+ dlmunmap. */+#include <sys/mman.h>+#define LACKS_SYS_MMAN_H 1++#if FFI_MMAP_EXEC_SELINUX+#include <sys/statfs.h>+#include <stdlib.h>++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 <sys/mman.h>++/* 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 <stdlib.h>++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 */
+ include/hs_libffi_closure.h view
@@ -0,0 +1,4 @@+#include <ffi.h>++void * hs_ffi_closure_alloc (size_t size, void **code);+void hs_ffi_closure_free (void *ptr);
+ libffi-dynamic.cabal view
@@ -0,0 +1,54 @@+name: libffi-dynamic+version: 0.0.0.1+stability: experimental++cabal-version: >= 1.6+build-type: Simple++author: James Cook <mokus@deepbondi.net>+maintainer: James Cook <mokus@deepbondi.net>+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
+ src/Foreign/Dynamic.hs view
@@ -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
+ src/Foreign/LibFFI/Dynamic.hs view
@@ -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
+ src/Foreign/LibFFI/Dynamic/Base.hsc view
@@ -0,0 +1,10 @@+module Foreign.LibFFI.Dynamic.Base where++import Foreign.C.Types++#include <ffi.h>++sizeOfClosure = (#size ffi_closure) :: CSize++newtype FFI_Status = FFI_Status CInt+
+ src/Foreign/LibFFI/Dynamic/CIF.hsc view
@@ -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 <ffi.h>++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
+ src/Foreign/LibFFI/Dynamic/Closure.hs view
@@ -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
+ src/Foreign/LibFFI/Dynamic/FFIType.hsc view
@@ -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 <stdbool.h>++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)+ ]
+ src/Foreign/LibFFI/Dynamic/Type.hsc view
@@ -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 <ffi.h>++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)
+ src/Foreign/Wrapper.hs view
@@ -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