-/* Copyright (C) 2010-2014 Free Software Foundation, Inc.
+/* Copyright (C) 2010-2013 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
/* The cell representing the null pointer. */
static SCM null_pointer;
-#if SIZEOF_VOID_P == 4
-# define scm_to_uintptr scm_to_uint32
-# define scm_from_uintptr scm_from_uint32
-#elif SIZEOF_VOID_P == 8
-# define scm_to_uintptr scm_to_uint64
-# define scm_from_uintptr scm_from_uint64
-#else
-# error unsupported pointer size
-#endif
-
/* Raise a null pointer dereference error. */
static void
static SCM pointer_weak_refs = SCM_BOOL_F;
-static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static void
register_weak_reference (SCM from, SCM to)
{
- scm_i_pthread_mutex_lock (&weak_refs_lock);
- scm_hashq_set_x (pointer_weak_refs, from, to);
- scm_i_pthread_mutex_unlock (&weak_refs_lock);
+ scm_weak_table_putq_x (pointer_weak_refs, from, to);
}
static void
pointer_finalizer_trampoline (void *ptr, void *data)
{
scm_t_pointer_finalizer finalizer = data;
- finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
+ finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
}
SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
void *c_finalizer;
scm_t_uintptr c_address;
- c_address = scm_to_uintptr (address);
+ c_address = scm_to_uintptr_t (address);
if (SCM_UNBNDP (finalizer))
c_finalizer = NULL;
else
{
SCM_VALIDATE_POINTER (1, pointer);
- return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
}
#undef FUNC_NAME
SCM ret;
ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
- if (SCM_NIMP (ret))
+ if (SCM_HEAP_OBJECT_P (ret))
register_weak_reference (ret, scm);
return ret;
blen = scm_to_size_t (len);
ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset,
- blen, btype);
- register_weak_reference (ret, pointer);
+ blen, btype, pointer);
+
return ret;
}
#undef FUNC_NAME
void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<pointer 0x", port);
- scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_puts
_unlocked ("#<pointer 0x", port);
+ scm_uintprint (scm_to_uintptr_t (scm_pointer_address (pointer)), 16, port);
+ scm_putc_unlocked ('>', port);
}
\f
{
/* a struct */
size_t off = 0;
+ size_t align = scm_to_size_t (scm_alignof(type));
while (scm_is_pair (type))
{
off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
off += scm_to_size_t (scm_sizeof (scm_car (type)));
type = scm_cdr (type);
}
- return scm_from_size_t (off);
+ return scm_from_size_t (ROUND_UP(off, align));
}
else
scm_wrong_type_arg (FUNC_NAME, 1, type);
\f
-/* Pre-generate trampolines for less than 10 arguments. */
+/* We support calling foreign functions with up to 100 arguments. */
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40)
-#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0)
-#else
-#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0)
-#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0)
-#endif
+#define CODE(nreq) \
+ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
+ SCM_PACK_OP_12_12 (foreign_call, 0, 1)
-#define GEN_CODE(M, nreq) \
- OBJCODE_HEADER (M), \
- /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \
- /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \
- /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \
- /* 7 */ M (scm_op_nop), \
- /* 8 */ META (M, 3, 7, nreq)
-
-#define META(M, start, end, nreq) \
- META_HEADER (M), \
- /* 0 */ M (scm_op_make_eol), /* bindings */ \
- /* 1 */ M (scm_op_make_eol), /* sources */ \
- /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \
- /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
- /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
- /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \
- /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \
- /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
- /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
- /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \
- /* 28 */ M (scm_op_return), /* and return */ \
- /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
- /* 32 */
-
-#define M_STATIC(x) (x)
-#define CODE(nreq) GEN_CODE (M_STATIC, nreq)
-
-static const struct
-{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
- CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
- }
-};
+#define CODE_10(n) \
+ CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \
+ CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9)
-static SCM
-make_objcode_trampoline (unsigned int nargs)
-{
- const int size = sizeof (struct scm_objcode) + 8
- + sizeof (struct scm_objcode) + 32;
- SCM bytecode = scm_c_make_bytevector (size);
- scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
- int i = 0;
-
-#define M_DYNAMIC(x) (bytes[i++] = (x))
- GEN_CODE (M_DYNAMIC, nargs);
-#undef M_DYNAMIC
-
- if (i != size)
- scm_syserror ("make_objcode_trampoline");
- return scm_bytecode_to_native_objcode (bytecode);
-}
+static const scm_t_uint32 foreign_stub_code[] =
+ {
+ CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40),
+ CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90)
+ };
-#undef GEN_CODE
-#undef META
-#undef M_STATIC
#undef CODE
-#undef OBJCODE_HEADER
-#undef META_HEADER
-
-/*
- (defun generate-objcode-cells (n)
- "Generate objcode cells for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (< i n)
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 8 4 4 32) i)))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq i (1+ i)))))
-*/
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
+#undef CODE_10
-static const struct
+static const scm_t_uint32 *
+get_foreign_stub_code (unsigned int nargs)
{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[10 * 2]; /* 10 double cells */
-} objcode_cells = {
- 0,
- /* C-u 1 0 M-x generate-objcode-cells RET */
- {
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-static const SCM objcode_trampolines[10] = {
- SCM_PACK (objcode_cells.cells+0),
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
- SCM_PACK (objcode_cells.cells+8),
- SCM_PACK (objcode_cells.cells+10),
- SCM_PACK (objcode_cells.cells+12),
- SCM_PACK (objcode_cells.cells+14),
- SCM_PACK (objcode_cells.cells+16),
- SCM_PACK (objcode_cells.cells+18),
-};
-
-static SCM large_objcode_trampolines = SCM_UNDEFINED;
-static scm_i_pthread_mutex_t large_objcode_trampolines_mutex =
- SCM_I_PTHREAD_MUTEX_INITIALIZER;
+ if (nargs >= 100)
+ scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
+ SCM_EOL);
-static SCM
-get_objcode_trampoline (unsigned int nargs)
+ return &foreign_stub_code[nargs * 2];
+}
+
+/* Given a foreign procedure, determine its minimum arity. */
+int
+scm_i_foreign_arity (SCM foreign, int *req, int *opt, int *rest)
{
- SCM objcode;
+ const scm_t_uint32 *code = SCM_PROGRAM_CODE (foreign);
- if (nargs < 10)
- objcode = objcode_trampolines[nargs];
- else if (nargs < 128)
- {
- scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex);
- if (SCM_UNBNDP (large_objcode_trampolines))
- large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED);
- objcode = scm_c_vector_ref (large_objcode_trampolines, nargs);
- if (SCM_UNBNDP (objcode))
- scm_c_vector_set_x (large_objcode_trampolines, nargs,
- objcode = make_objcode_trampoline (nargs));
- scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex);
- }
- else
- scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented",
- SCM_EOL);
+ if (code < foreign_stub_code)
+ return 0;
+ if (code > (foreign_stub_code
+ + (sizeof(foreign_stub_code) / sizeof(scm_t_uint32))))
+ return 0;
+
+ *req = (code - foreign_stub_code) / 2;
+ *opt = 0;
+ *rest = 0;
- return objcode;
+ return 1;
}
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
ffi_cif *c_cif;
- SCM objcode, table, ret;
+ SCM ret;
+ scm_t_bits nfree = 2;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_FOREIGN;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- objcode = get_objcode_trampoline (c_cif->nargs);
-
- table = scm_c_make_vector (2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
- SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
- ret = scm_make_program (objcode, table, SCM_BOOL_F);
+
+ ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs));
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
return ret;
}
size_t i;
SCM proc, *argv, result;
- proc = PTR2SCM (data);
+ proc = SCM_PACK_POINTER (data);
argv = alloca (cif->nargs * sizeof (*argv));
closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
- invoke_closure, SCM2PTR (proc),
+ invoke_closure, SCM_UNPACK_POINTER (proc),
executable);
if (err != FFI_OK)
{
"scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
NULL);
- pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*
HCoop / bpt / guile.git / blobdiff