[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-256-gd691ac2
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-256-gd691ac2 |
|
Date: |
Fri, 18 Oct 2013 16:42:43 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d691ac206906d2539cb94667fd10854aafc8955a
The branch, master has been updated
via d691ac206906d2539cb94667fd10854aafc8955a (commit)
via 8bd261baaa96eba005517eef5fb8d5d08f22720a (commit)
via b0ca878cae82ebb2028783aff6e27352b70810d8 (commit)
from d724a36562357c86f2b4c21b46992abf9598b4d1 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d691ac206906d2539cb94667fd10854aafc8955a
Author: Andy Wingo <address@hidden>
Date: Fri Oct 18 18:44:11 2013 +0200
Continuations are RTL stubs
* libguile/continuations.h:
* libguile/continuations.c: Reimplement continuations and the call_cc
stub as RTL programs.
* libguile/programs.c (scm_i_rtl_program_minimum_arity): Add a case for
continuations.
* libguile/vm-engine.c (rtl_vm_debug_engine): Always call the abort
continuation hook with the number of non-procedure locals. Fix
compose-continuation argument count. Enable call/cc.
commit 8bd261baaa96eba005517eef5fb8d5d08f22720a
Author: Andy Wingo <address@hidden>
Date: Fri Oct 18 18:41:59 2013 +0200
(language tree-il analyze) works better with RTL programs
* module/system/vm/program.scm (program-arguments-alists): Export this
interface. Fall back to grovelling through procedure-minimum-arity if
the program has no arities, as might be the case for continuations.
* module/language/tree-il/analyze.scm (validate-arity): Use
program-arguments-alists instead of the program-arities interface, to
cover both stack VM and RTL programs.
commit b0ca878cae82ebb2028783aff6e27352b70810d8
Author: Andy Wingo <address@hidden>
Date: Fri Oct 18 17:41:33 2013 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
libguile/continuations.c | 120 ++++-----------------
libguile/continuations.h | 4 +-
libguile/foreign.c | 202 ++++++++---------------------------
libguile/foreign.h | 6 +-
libguile/gsubr.c | 4 +-
libguile/instructions.h | 3 +-
libguile/programs.c | 10 ++
libguile/programs.h | 2 +
libguile/vm-engine.c | 47 +++++---
module/language/tree-il/analyze.scm | 12 ++-
module/system/vm/program.scm | 16 ++-
test-suite/tests/foreign.test | 5 +
12 files changed, 143 insertions(+), 288 deletions(-)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index fe7618f..58a1936 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011,
2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 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
@@ -58,107 +58,35 @@ static scm_t_bits tc16_continuation;
-/* scm_i_make_continuation will return a procedure whose objcode contains an
- instruction to reinstate the continuation. Here, as in gsubr.c and smob.c,
we
- define the form of that trampoline function.
+/* scm_i_make_continuation will return a procedure whose code will
+ reinstate the continuation. Here, as in gsubr.c, we define the form
+ of that trampoline function.
*/
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
-#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
-#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-#define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
-
-#if defined (SCM_ALIGNED) && 0
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
-static const type sym[]
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
-static SCM_ALIGNED (alignment) const type sym[]
-#define SCM_STATIC_OBJCODE(sym) \
- SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
- { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
- { SCM_BOOL_F, SCM_PACK (0) } \
- }; \
- static const SCM sym = SCM_PACK (sym##__cells); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
-#else
-#define SCM_STATIC_OBJCODE(sym) \
-static SCM sym; \
-static scm_t_uint8 *sym##_bytecode; \
-SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless
(sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
- memcpy (sym##_bytecode, sym##_bytecode__unaligned,
sizeof(sym##_bytecode__unaligned));) \
-SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
- (scm_t_bits)sym##_bytecode, \
- SCM_UNPACK (SCM_BOOL_F), \
- 0);) \
-static const scm_t_uint8 sym##_bytecode__unaligned[]
-#endif
+static const scm_t_uint32 continuation_stub_code[] =
+ {
+ SCM_PACK_RTL_24 (scm_rtl_op_continuation_call, 0)
+ };
+/* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
+ call/cc. */
-SCM_STATIC_OBJCODE (cont_objcode) = {
- /* This code is the same as in gsubr.c, except we use continuation_call
- instead of subr_call. */
- OBJCODE_HEADER (8, 19),
- /* leave args on the stack */
- /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */
- /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */
- /* 3 */ scm_op_nop, /* pad to 8 bytes */
- /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,
- /* 8 */
-
- /* We could put some meta-info to say that this proc is a continuation. Not
sure
- how to do that, though. */
- META_HEADER (19),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip
3 */
- /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
- /* 7 */ scm_op_make_int8_0, /* 0 optionals */
- /* 8 */ scm_op_make_true, /* and a rest arg */
- /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
- /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
- /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
- /* 18 */ scm_op_return /* and return */
- /* 19 */
-};
-
-
-SCM_STATIC_OBJCODE (call_cc_objcode) = {
- /* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
- call/cc. */
- OBJCODE_HEADER (8, 17),
- /* 0 */ scm_op_assert_nargs_ee, 0, 1, /* assert that nargs==1 */
- /* 3 */ scm_op_local_ref, 0, /* push the proc */
- /* 5 */ scm_op_tail_call_cc, /* and call/cc */
- /* 6 */ scm_op_nop, scm_op_nop, /* pad to 8 bytes */
- /* 8 */
-
- META_HEADER (17),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 3, scm_op_make_int8, 6, /* arity: from ip 0 to ip
6 */
- /* 6 */ scm_op_make_int8_1, /* the arity is 0 required args */
- /* 7 */ scm_op_list, 0, 3, /* make a list of those 5 vals */
- /* 10 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
- /* 13 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
- /* 16 */ scm_op_return /* and return */
- /* 17 */
-};
-
+static const scm_t_uint32 call_cc_code[] =
+ {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
+ };
static SCM
make_continuation_trampoline (SCM contregs)
{
- SCM ret = scm_make_program (cont_objcode,
- scm_c_make_vector (1, contregs),
- SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret,
- SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
+ SCM ret;
+ scm_t_bits nfree = 1;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
+
+ ret = scm_words (scm_tc7_rtl_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, continuation_stub_code);
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
return ret;
}
@@ -252,7 +180,7 @@ scm_i_call_with_current_continuation (SCM proc)
static SCM call_cc = SCM_BOOL_F;
if (scm_is_false (call_cc))
- call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
+ call_cc = scm_i_make_rtl_program (call_cc_code);
return scm_call_1 (call_cc, proc);
}
@@ -263,7 +191,7 @@ scm_i_continuation_to_frame (SCM continuation)
SCM contregs;
scm_t_contregs *cont;
- contregs = scm_c_vector_ref (scm_program_objects (continuation), 0);
+ contregs = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
cont = SCM_CONTREGS (contregs);
if (scm_is_true (cont->vm_cont))
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 29ea1c1..e7fa16d 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2012 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 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,7 +32,7 @@
#define SCM_CONTINUATIONP(x) \
- (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
+ (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
/* a continuation SCM is a non-immediate pointing to a heap cell with:
word 0: bits 0-15: smob type tag: scm_tc16_continuation.
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 76e43f3..ac7cf8c 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -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 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_objcode (bytecode, SCM_UNDEFINED);
-}
+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_RTL_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_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;
}
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 172fa24..fbb9764 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -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);
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 4e061e3..5dd767d 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -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);
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 81e7572..63bff7a 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -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) \
diff --git a/libguile/programs.c b/libguile/programs.c
index c10dede..a0decdd 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -524,6 +524,16 @@ 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_PROGRAM_IS_CONTINUATION (program))
+ {
+ *req = *opt = 0;
+ *rest = 1;
+ return 1;
+ }
+
if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
rtl_program_minimum_arity =
scm_c_private_variable ("system vm program",
diff --git a/libguile/programs.h b/libguile/programs.h
index 1ecc35d..f2518ca 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 095f0bc..e2f8745 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -849,7 +849,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
to pull all our state back from the ip/fp/sp.
*/
CACHE_REGISTER ();
- ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT());
+ ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT () - 1);
NEXT (0);
}
@@ -1252,7 +1252,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
scm_i_check_continuation (contregs);
vm_return_to_continuation (scm_i_contregs_vm (contregs),
scm_i_contregs_vm_cont (contregs),
- FRAME_LOCALS_COUNT (), fp);
+ FRAME_LOCALS_COUNT () - 1, fp);
scm_i_reinstate_continuation (contregs);
/* no NEXT */
@@ -1278,7 +1278,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SYNC_IP ();
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT (), fp,
+ vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT () -
1, fp,
¤t_thread->dynstack,
®isters);
CACHE_REGISTER ();
@@ -1333,14 +1333,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* call/cc _:24
*
* Capture the current continuation, and tail-apply the procedure in
- * local slot 0 to it. This instruction is part of the implementation
+ * local slot 1 to it. This instruction is part of the implementation
* of `call/cc', and is not generated by the compiler.
*/
VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
-#if 0
{
SCM vm_cont, cont;
scm_t_dynstack *dynstack;
+ int first;
VM_HANDLE_INTERRUPTS;
@@ -1353,23 +1353,34 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM_FRAME_MV_RETURN_ADDRESS (fp),
dynstack,
0);
- cont = scm_i_make_continuation (®isters, vm, vm_cont);
-
- fp[-1] = fp[0];
- fp[0] = cont;
- RESET_FRAME (2);
+ /* FIXME: Seems silly to capture the registers here, when they are
+ already captured in the registers local, which here we are
+ copying out to the heap; and likewise, the setjmp(®isters)
+ code already has the non-local return handler. But oh
+ well! */
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
+
+ if (first)
+ {
+ LOCAL_SET (0, LOCAL_REF (1));
+ LOCAL_SET (1, cont);
+ RESET_FRAME (2);
- APPLY_HOOK ();
+ APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
- goto apply;
+ if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
- NEXT (0);
+ ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ NEXT (0);
+ }
+ else
+ {
+ CACHE_REGISTER ();
+ ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT () - 1);
+ NEXT (0);
+ }
}
-#else
- abort();
-#endif
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 2f6e369..22287f6 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -950,13 +950,15 @@ given `tree-il' element."
(or (and (or (null? x) (pair? x))
(length x))
0))
- (cond ((program? proc)
+ (cond ((or (program? proc) (rtl-program? proc))
(values (procedure-name proc)
(map (lambda (a)
- (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
- (map car (arity:kw a))
- (arity:allow-other-keys? a)))
- (program-arities proc))))
+ (list (length (or (assq-ref a 'required) '()))
+ (length (or (assq-ref a 'optional) '()))
+ (and (assq-ref a 'rest) #t)
+ (map car (or (assq-ref a 'keyword) '()))
+ (assq-ref a 'allow-other-keys?)))
+ (program-arguments-alists proc))))
((procedure? proc)
(if (struct? proc)
;; An applicable struct.
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 4466504..2c8cd75 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -41,7 +41,8 @@
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
- program-arguments-alist program-lambda-list
+ program-arguments-alist program-arguments-alists
+ program-lambda-list
program-meta
program-objcode program? program-objects
@@ -340,8 +341,9 @@
0)))
(define (program-arguments-alists prog)
- (cond
- ((primitive? prog)
+ "Returns all arities of the given procedure, as a list of association
+lists."
+ (define (fallback)
(match (procedure-minimum-arity prog)
(#f '())
((nreq nopt rest?)
@@ -349,9 +351,13 @@
(arity->arguments-alist
prog
(list 0 0 nreq nopt rest? '(#f . ())))))))
+ (cond
+ ((primitive? prog) (fallback))
((rtl-program? prog)
- (map arity-arguments-alist
- (or (find-program-arities (rtl-program-code prog)) '())))
+ (let ((arities (find-program-arities (rtl-program-code prog))))
+ (if arities
+ (map arity-arguments-alist arities)
+ (fallback))))
((program? prog)
(map (lambda (arity) (arity->arguments-alist prog arity))
(or (program-arities prog) '())))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 8ba989e..c53c044 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -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))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-256-gd691ac2,
Andy Wingo <=