diff options
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r-- | libguile/foreign.c | 242 |
1 files changed, 58 insertions, 184 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 01af90019..5ee225da4 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -65,16 +65,6 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error"); /* 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 @@ -89,22 +79,19 @@ static SCM cif_to_procedure (SCM cif, SCM func_ptr); 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, @@ -128,7 +115,7 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 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 @@ -176,7 +163,7 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, { 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 @@ -201,7 +188,7 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, 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; @@ -273,8 +260,8 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, 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 @@ -326,9 +313,9 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0, 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); } @@ -547,13 +534,14 @@ SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), { /* 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); @@ -775,182 +763,68 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, -/* 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_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ - 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_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; } @@ -1171,7 +1045,7 @@ invoke_closure (ffi_cif *cif, void *ret, void **args, void *data) size_t i; SCM proc, *argv, result; - proc = PTR2SCM (data); + proc = SCM_PACK_POINTER (data); argv = alloca (cif->nargs * sizeof (*argv)); @@ -1202,7 +1076,7 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, 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) { @@ -1368,7 +1242,7 @@ scm_register_foreign (void) "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); } /* |