mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Foreign procedures are RTL programs
* libguile/foreign.c: Convert to using RTL stubs. Because RTL code has
different GC characteristics than objcode -- it's mostly assumed that
RTL code will never go away -- we go ahead and pre-generate code for
100 arguments. This is actually less memory than the stack VM code,
and doesn't require any relocations at load-time: bonus! We'll cross
the >=100 args bridge if we ever come to it.
(get_foreign_stub_code) New function.
(scm_i_foreign_arity): New helper, like scm_i_primitive_arity.
(cif_to_procedure): Rework to make RTL programs.
* libguile/foreign.h: Declare scm_pointer_to_scm and
scm_scm_to_pointer. Declare new internal helpers.
* libguile/gsubr.c (create_subr): Refactor to set the flags when the
object is allocated.
* libguile/instructions.h: Define SCM_PACK_RTL_12_12.
* libguile/programs.c (scm_i_rtl_program_minimum_arity): Dispatch to
scm_i_foreign_arity if the procedure has the FOREIGN flag.
* libguile/programs.h (SCM_F_PROGRAM_IS_FOREIGN)
(SCM_PROGRAM_IS_FOREIGN): New interfaces.
* test-suite/tests/foreign.test ("procedure->pointer"): Add a test for
foreign arities.
This commit is contained in:
Andy Wingo
parent
d724a36562
commit
b0ca878cae
7 changed files with 63 additions and 162 deletions
|
|
@ -763,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_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1), \
|
||||
SCM_PACK_RTL_12_12 (scm_rtl_op_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 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)
|
||||
|
||||
#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,
|
||||
static const scm_t_uint32 foreign_stub_code[] =
|
||||
{
|
||||
CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
|
||||
CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
|
||||
}
|
||||
};
|
||||
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)
|
||||
};
|
||||
|
||||
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_objcode (bytecode, SCM_UNDEFINED);
|
||||
}
|
||||
|
||||
#undef GEN_CODE
|
||||
#undef META
|
||||
#undef M_STATIC
|
||||
#undef CODE
|
||||
#undef OBJCODE_HEADER
|
||||
#undef META_HEADER
|
||||
#undef CODE_10
|
||||
|
||||
/*
|
||||
(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))
|
||||
|
||||
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;
|
||||
|
||||
static SCM
|
||||
get_objcode_trampoline (unsigned int nargs)
|
||||
{
|
||||
SCM objcode;
|
||||
|
||||
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",
|
||||
if (nargs >= 100)
|
||||
scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
|
||||
SCM_EOL);
|
||||
|
||||
return objcode;
|
||||
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)
|
||||
{
|
||||
const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (foreign);
|
||||
|
||||
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 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_rtl_program | (nfree << 16) | flags, nfree + 2);
|
||||
SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs));
|
||||
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
|
||||
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#ifndef SCM_FOREIGN_H
|
||||
#define SCM_FOREIGN_H
|
||||
|
||||
/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 2010, 2011, 2012, 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
|
||||
|
|
@ -60,6 +60,8 @@ SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);
|
|||
SCM_API SCM scm_alignof (SCM type);
|
||||
SCM_API SCM scm_sizeof (SCM type);
|
||||
SCM_API SCM scm_pointer_address (SCM pointer);
|
||||
SCM_API SCM scm_pointer_to_scm (SCM pointer);
|
||||
SCM_API SCM scm_scm_to_pointer (SCM scm);
|
||||
SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
|
||||
SCM offset, SCM len);
|
||||
SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
|
||||
|
|
@ -96,6 +98,8 @@ SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr,
|
|||
SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
|
||||
SCM arg_types);
|
||||
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);
|
||||
SCM_INTERNAL int scm_i_foreign_arity (SCM foreign,
|
||||
int *req, int *opt, int *rest);
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -236,10 +236,10 @@ create_subr (int define, const char *name,
|
|||
|
||||
sname = scm_from_utf8_symbol (name);
|
||||
|
||||
ret = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
|
||||
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
|
||||
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
|
||||
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
|
||||
|
||||
ret = scm_words (scm_tc7_rtl_program | (nfree << 16) | flags, nfree + 2);
|
||||
SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
|
||||
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
|
||||
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 2001, 2009, 2012, 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
|
||||
|
|
@ -32,6 +32,7 @@ enum scm_rtl_opcode
|
|||
#define SCM_PACK_RTL_8_8_8(op,a,b,c) ((op) | ((a) << 8) | ((b) << 16) | ((c) << 24))
|
||||
#define SCM_PACK_RTL_8_16(op,a,b) ((op) | ((a) << 8) | ((b) << 16))
|
||||
#define SCM_PACK_RTL_16_8(op,a,b) ((op) | ((a) << 8) | ((b) << 24))
|
||||
#define SCM_PACK_RTL_12_12(op,a,b) ((op) | ((a) << 8) | ((b) << 20))
|
||||
#define SCM_PACK_RTL_24(op,a) ((op) | ((a) << 8))
|
||||
|
||||
#define SCM_UNPACK_RTL_8_8_8(op,a,b,c) \
|
||||
|
|
|
|||
|
|
@ -524,6 +524,9 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
|
|||
if (SCM_PRIMITIVE_P (program))
|
||||
return scm_i_primitive_arity (program, req, opt, rest);
|
||||
|
||||
if (SCM_PROGRAM_IS_FOREIGN (program))
|
||||
return scm_i_foreign_arity (program, req, opt, rest);
|
||||
|
||||
if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
|
||||
rtl_program_minimum_arity =
|
||||
scm_c_private_variable ("system vm program",
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
|
|||
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
|
||||
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
|
||||
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
|
||||
#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
|
||||
|
||||
#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
|
||||
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
|
||||
|
|
@ -75,6 +76,7 @@ SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
|
|||
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
|
||||
#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_CONTINUATION)
|
||||
#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
|
||||
#define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_FOREIGN)
|
||||
|
||||
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
|
||||
|
||||
|
|
|
|||
|
|
@ -333,6 +333,11 @@
|
|||
(gc) (gc) (gc)
|
||||
(every (cut = <> 9)
|
||||
(map (lambda (f) (f 2)) procs)))
|
||||
(throw 'unresolved)))
|
||||
|
||||
(pass-if "arity"
|
||||
(if (and qsort (defined? 'procedure->pointer))
|
||||
(equal? '(4 0 #f) (procedure-minimum-arity qsort))
|
||||
(throw 'unresolved))))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue