diff options
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r-- | libguile/foreign.c | 205 |
1 files changed, 112 insertions, 93 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 927c46fad..1368cc9da 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1,41 +1,65 @@ -/* Copyright (C) 2010-2016 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ +/* Copyright 2010-2016,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ #if HAVE_CONFIG_H # include <config.h> #endif -#include <ffi.h> - -#include <alloca.h> #include <alignof.h> -#include <string.h> +#include <alloca.h> #include <assert.h> #include <errno.h> +#include <string.h> + +#include <ffi.h> -#include "libguile/_scm.h" -#include "libguile/bytevectors.h" -#include "libguile/instructions.h" -#include "libguile/threads.h" -#include "libguile/foreign.h" +#include "boolean.h" +#include "bytevectors.h" +#include "dynwind.h" +#include "eq.h" +#include "eval.h" +#include "extensions.h" +#include "finalizers.h" +#include "gsubr.h" +#include "instructions.h" +#include "intrinsics.h" +#include "keywords.h" +#include "list.h" +#include "modules.h" +#include "numbers.h" +#include "pairs.h" +#include "ports.h" +#include "stacks.h" +#include "symbols.h" +#include "threads.h" +#include "weak-table.h" +#include "version.h" + +#include "foreign.h" +/* Return the first integer greater than or equal to LEN such that + LEN % ALIGN == 0. Return LEN if ALIGN is zero. */ +#define ROUND_UP(len, align) \ + ((align) ? (((len) - 1UL) | ((align) - 1UL)) + 1UL : (len)) + SCM_SYMBOL (sym_void, "void"); SCM_SYMBOL (sym_float, "float"); SCM_SYMBOL (sym_double, "double"); @@ -116,7 +140,7 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0, #define FUNC_NAME s_scm_make_pointer { void *c_finalizer; - scm_t_uintptr c_address; + uintptr_t c_address; c_address = scm_to_uintptr_t (address); if (SCM_UNBNDP (finalizer)) @@ -166,7 +190,7 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, { SCM_VALIDATE_POINTER (1, pointer); - return scm_from_uintptr_t ((scm_t_uintptr) SCM_POINTER_VALUE (pointer)); + return scm_from_uintptr_t ((uintptr_t) SCM_POINTER_VALUE (pointer)); } #undef FUNC_NAME @@ -214,7 +238,7 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, #define FUNC_NAME s_scm_pointer_to_bytevector { SCM ret; - scm_t_int8 *ptr; + int8_t *ptr; size_t boffset, blen; scm_t_array_element_type btype; @@ -447,21 +471,21 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), case SCM_FOREIGN_TYPE_DOUBLE: return scm_from_size_t (alignof_type (double)); case SCM_FOREIGN_TYPE_UINT8: - return scm_from_size_t (alignof_type (scm_t_uint8)); + return scm_from_size_t (alignof_type (uint8_t)); case SCM_FOREIGN_TYPE_INT8: - return scm_from_size_t (alignof_type (scm_t_int8)); + return scm_from_size_t (alignof_type (int8_t)); case SCM_FOREIGN_TYPE_UINT16: - return scm_from_size_t (alignof_type (scm_t_uint16)); + return scm_from_size_t (alignof_type (uint16_t)); case SCM_FOREIGN_TYPE_INT16: - return scm_from_size_t (alignof_type (scm_t_int16)); + return scm_from_size_t (alignof_type (int16_t)); case SCM_FOREIGN_TYPE_UINT32: - return scm_from_size_t (alignof_type (scm_t_uint32)); + return scm_from_size_t (alignof_type (uint32_t)); case SCM_FOREIGN_TYPE_INT32: - return scm_from_size_t (alignof_type (scm_t_int32)); + return scm_from_size_t (alignof_type (int32_t)); case SCM_FOREIGN_TYPE_UINT64: - return scm_from_size_t (alignof_type (scm_t_uint64)); + return scm_from_size_t (alignof_type (uint64_t)); case SCM_FOREIGN_TYPE_INT64: - return scm_from_size_t (alignof_type (scm_t_int64)); + return scm_from_size_t (alignof_type (int64_t)); default: scm_wrong_type_arg (FUNC_NAME, 1, type); } @@ -511,21 +535,21 @@ SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), case SCM_FOREIGN_TYPE_DOUBLE: return scm_from_size_t (sizeof (double)); case SCM_FOREIGN_TYPE_UINT8: - return scm_from_size_t (sizeof (scm_t_uint8)); + return scm_from_size_t (sizeof (uint8_t)); case SCM_FOREIGN_TYPE_INT8: - return scm_from_size_t (sizeof (scm_t_int8)); + return scm_from_size_t (sizeof (int8_t)); case SCM_FOREIGN_TYPE_UINT16: - return scm_from_size_t (sizeof (scm_t_uint16)); + return scm_from_size_t (sizeof (uint16_t)); case SCM_FOREIGN_TYPE_INT16: - return scm_from_size_t (sizeof (scm_t_int16)); + return scm_from_size_t (sizeof (int16_t)); case SCM_FOREIGN_TYPE_UINT32: - return scm_from_size_t (sizeof (scm_t_uint32)); + return scm_from_size_t (sizeof (uint32_t)); case SCM_FOREIGN_TYPE_INT32: - return scm_from_size_t (sizeof (scm_t_int32)); + return scm_from_size_t (sizeof (int32_t)); case SCM_FOREIGN_TYPE_UINT64: - return scm_from_size_t (sizeof (scm_t_uint64)); + return scm_from_size_t (sizeof (uint64_t)); case SCM_FOREIGN_TYPE_INT64: - return scm_from_size_t (sizeof (scm_t_int64)); + return scm_from_size_t (sizeof (int64_t)); default: scm_wrong_type_arg (FUNC_NAME, 1, type); } @@ -802,29 +826,28 @@ SCM_DEFINE (scm_i_pointer_to_procedure, "pointer->procedure", 3, 0, 1, -static const scm_t_uint32 * +static const uint32_t * get_foreign_stub_code (unsigned int nargs, int with_errno) { size_t i; size_t code_len = with_errno ? 4 : 5; - scm_t_uint32 *code; - - code = scm_gc_malloc_pointerless (code_len * sizeof (scm_t_uint32), - "foreign code"); + uint32_t *ret, *code; if (nargs >= (1 << 24) + 1) scm_misc_error ("make-foreign-function", "too many arguments: ~a", scm_list_1 (scm_from_uint (nargs))); + ret = scm_i_alloc_primitive_code_with_instrumentation (code_len, &code); + i = 0; code[i++] = SCM_PACK_OP_24 (assert_nargs_ee, nargs + 1); code[i++] = SCM_PACK_OP_12_12 (foreign_call, 0, 1); code[i++] = SCM_PACK_OP_24 (handle_interrupts, 0); if (!with_errno) - code[i++] = SCM_PACK_OP_24 (reset_frame, 2); + code[i++] = SCM_PACK_OP_24 (reset_frame, 1); code[i++] = SCM_PACK_OP_24 (return_values, 0); - return code; + return ret; } static SCM @@ -848,7 +871,7 @@ cif_to_procedure (SCM cif, SCM func_ptr, int with_errno) /* Set *LOC to the foreign representation of X with TYPE. */ static void unpack (const ffi_type *type, void *loc, SCM x, int return_value_p) -#define FUNC_NAME "scm_i_foreign_call" +#define FUNC_NAME "foreign-call" { switch (type->type) { @@ -866,43 +889,43 @@ unpack (const ffi_type *type, void *loc, SCM x, int return_value_p) if (return_value_p) *(ffi_arg *) loc = scm_to_uint8 (x); else - *(scm_t_uint8 *) loc = scm_to_uint8 (x); + *(uint8_t *) loc = scm_to_uint8 (x); break; case FFI_TYPE_SINT8: if (return_value_p) *(ffi_arg *) loc = scm_to_int8 (x); else - *(scm_t_int8 *) loc = scm_to_int8 (x); + *(int8_t *) loc = scm_to_int8 (x); break; case FFI_TYPE_UINT16: if (return_value_p) *(ffi_arg *) loc = scm_to_uint16 (x); else - *(scm_t_uint16 *) loc = scm_to_uint16 (x); + *(uint16_t *) loc = scm_to_uint16 (x); break; case FFI_TYPE_SINT16: if (return_value_p) *(ffi_arg *) loc = scm_to_int16 (x); else - *(scm_t_int16 *) loc = scm_to_int16 (x); + *(int16_t *) loc = scm_to_int16 (x); break; case FFI_TYPE_UINT32: if (return_value_p) *(ffi_arg *) loc = scm_to_uint32 (x); else - *(scm_t_uint32 *) loc = scm_to_uint32 (x); + *(uint32_t *) loc = scm_to_uint32 (x); break; case FFI_TYPE_SINT32: if (return_value_p) *(ffi_arg *) loc = scm_to_int32 (x); else - *(scm_t_int32 *) loc = scm_to_int32 (x); + *(int32_t *) loc = scm_to_int32 (x); break; case FFI_TYPE_UINT64: - *(scm_t_uint64 *) loc = scm_to_uint64 (x); + *(uint64_t *) loc = scm_to_uint64 (x); break; case FFI_TYPE_SINT64: - *(scm_t_int64 *) loc = scm_to_int64 (x); + *(int64_t *) loc = scm_to_int64 (x); break; case FFI_TYPE_STRUCT: SCM_VALIDATE_POINTER (1, x); @@ -945,38 +968,38 @@ pack (const ffi_type * type, const void *loc, int return_value_p) case FFI_TYPE_UINT8: if (return_value_p) - return scm_from_uint8 ((scm_t_uint8) *(ffi_arg *) loc); + return scm_from_uint8 ((uint8_t) *(ffi_arg *) loc); else - return scm_from_uint8 (* (scm_t_uint8 *) loc); + return scm_from_uint8 (* (uint8_t *) loc); case FFI_TYPE_SINT8: if (return_value_p) - return scm_from_int8 ((scm_t_int8) *(ffi_arg *) loc); + return scm_from_int8 ((int8_t) *(ffi_arg *) loc); else - return scm_from_int8 (* (scm_t_int8 *) loc); + return scm_from_int8 (* (int8_t *) loc); case FFI_TYPE_UINT16: if (return_value_p) - return scm_from_uint16 ((scm_t_uint16) *(ffi_arg *) loc); + return scm_from_uint16 ((uint16_t) *(ffi_arg *) loc); else - return scm_from_uint16 (* (scm_t_uint16 *) loc); + return scm_from_uint16 (* (uint16_t *) loc); case FFI_TYPE_SINT16: if (return_value_p) - return scm_from_int16 ((scm_t_int16) *(ffi_arg *) loc); + return scm_from_int16 ((int16_t) *(ffi_arg *) loc); else - return scm_from_int16 (* (scm_t_int16 *) loc); + return scm_from_int16 (* (int16_t *) loc); case FFI_TYPE_UINT32: if (return_value_p) - return scm_from_uint32 ((scm_t_uint32) *(ffi_arg *) loc); + return scm_from_uint32 ((uint32_t) *(ffi_arg *) loc); else - return scm_from_uint32 (* (scm_t_uint32 *) loc); + return scm_from_uint32 (* (uint32_t *) loc); case FFI_TYPE_SINT32: if (return_value_p) - return scm_from_int32 ((scm_t_int32) *(ffi_arg *) loc); + return scm_from_int32 ((int32_t) *(ffi_arg *) loc); else - return scm_from_int32 (* (scm_t_int32 *) loc); + return scm_from_int32 (* (int32_t *) loc); case FFI_TYPE_UINT64: - return scm_from_uint64 (*(scm_t_uint64 *) loc); + return scm_from_uint64 (*(uint64_t *) loc); case FFI_TYPE_SINT64: - return scm_from_int64 (*(scm_t_int64 *) loc); + return scm_from_int64 (*(int64_t *) loc); case FFI_TYPE_STRUCT: { @@ -992,6 +1015,8 @@ pack (const ffi_type * type, const void *loc, int return_value_p) } +#define MAX(A, B) ((A) >= (B) ? (A) : (B)) + SCM scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret, const union scm_vm_stack_element *argv) @@ -1000,12 +1025,12 @@ scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret, objtable. */ ffi_cif *cif; void (*func) (void); - scm_t_uint8 *data; + uint8_t *data; void *rvalue; void **args; unsigned i; size_t arg_size; - scm_t_ptrdiff off; + ptrdiff_t off; cif = SCM_POINTER_VALUE (cif_scm); func = SCM_POINTER_VALUE (pointer_scm); @@ -1021,18 +1046,18 @@ scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret, /* Space for argument values, followed by return value. */ data = alloca (arg_size + cif->rtype->size - + max (sizeof (void *), cif->rtype->alignment)); + + MAX (sizeof (void *), cif->rtype->alignment)); /* Unpack ARGV to native values, setting ARGV pointers. */ for (i = 0, off = 0; i < cif->nargs; - off = (scm_t_uint8 *) args[i] - data + cif->arg_types[i]->size, + off = (uint8_t *) args[i] - data + cif->arg_types[i]->size, i++) { /* Suitably align the storage area for argument I. */ - args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off, + args[i] = (void *) ROUND_UP ((uintptr_t) data + off, cif->arg_types[i]->alignment); - assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0); + assert ((uintptr_t) args[i] % cif->arg_types[i]->alignment == 0); unpack (cif->arg_types[i], args[i], argv[cif->nargs - i - 1].as_scm, 0); } @@ -1040,8 +1065,8 @@ scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret, `armv5tel-*-linux-gnueabi', the return value has to be at least word-aligned, even if its type doesn't have any alignment requirement as is the case with `char'. */ - rvalue = (void *) ROUND_UP ((scm_t_uintptr) data + off, - max (sizeof (void *), cif->rtype->alignment)); + rvalue = (void *) ROUND_UP ((uintptr_t) data + off, + MAX (sizeof (void *), cif->rtype->alignment)); /* off we go! */ errno = 0; @@ -1142,7 +1167,7 @@ static void scm_init_foreign (void) { #ifndef SCM_MAGIC_SNARFER -#include "libguile/foreign.x" +#include "foreign.x" #endif scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID)); scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT)); @@ -1246,7 +1271,7 @@ scm_init_foreign (void) #elif SCM_SIZEOF_SCM_T_PTRDIFF == 4 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32) #else -# error unsupported sizeof (scm_t_ptrdiff) +# error unsupported sizeof (ptrdiff_t) #endif ); @@ -1256,7 +1281,7 @@ scm_init_foreign (void) #elif SCM_SIZEOF_INTPTR_T == 4 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32) #else -# error unsupported sizeof (scm_t_intptr) +# error unsupported sizeof (intptr_t) #endif ); @@ -1266,7 +1291,7 @@ scm_init_foreign (void) #elif SCM_SIZEOF_UINTPTR_T == 4 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32) #else -# error unsupported sizeof (scm_t_uintptr) +# error unsupported sizeof (uintptr_t) #endif ); @@ -1283,9 +1308,3 @@ scm_register_foreign (void) NULL); pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); } - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |