summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r--libguile/foreign.c205
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:
-*/