summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-10-18 10:03:26 +0200
committerAndy Wingo <wingo@pobox.com>2013-10-18 11:39:35 +0200
commit27337b6373954e1a975d97d0bf06b5c03d65b64d (patch)
tree33dba0fa3b9c0c7121e5c106556a6a6116efb37f
parent9dff1df97f7021b1d2edd5dd73d1ca426def943b (diff)
downloadguile-27337b6373954e1a975d97d0bf06b5c03d65b64d.tar.gz
Subrs are RTL programs
* libguile/gsubr.c: Define RTL stubs instead of stack VM stubs. (SUBR_STUB_CODE, get_subr_stub_code): Adapt to return a uint32_t* pointer instead of a SCM value. (create_subr): Create RTL procedures instead of stack VM procedures. For RTL procedures, the function pointer, name, and generic address pointer go inline to the procedure, as free variables. (scm_i_primitive_arity, scm_i_primitive_call_ip): New helpers. (scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic) (scm_c_define_gsubr_with_generic): Adapt to create_gsubr being renamed to create_subr. Remove gsubr test code. * libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): Only RTL programs can be primitives now. (SCM_SUBRF, SCM_SUBR_NAME, SCM_SUBR_GENERIC): These fields are now in the RTL free variables, not the object table. * libguile/programs.c (scm_i_rtl_program_name): (scm_i_rtl_program_documentation): (scm_i_rtl_program_properties): (scm_i_rtl_program_minimum_arity): Implement these appropriately for primitives, which lack debugging information. (scm_primitive_p, scm_primitive_call_ip): New helpers. * libguile/snarf.h: Remove static allocation for subrs. Since there is nothing to allocate besides the program itself, which needs runtime relocation, static allocation is not a win. * system/vm/program.scm: Fix up various arity-related things for primitives, which don't use ELF arity info. * test-suite/tests/eval.test ("stack involving a primitive"): Add an XFAIL until we get just one VM.
-rw-r--r--libguile/gsubr.c819
-rw-r--r--libguile/gsubr.h23
-rw-r--r--libguile/programs.c37
-rw-r--r--libguile/programs.h3
-rw-r--r--libguile/snarf.h41
-rw-r--r--module/system/vm/program.scm38
-rw-r--r--test-suite/tests/eval.test6
7 files changed, 223 insertions, 744 deletions
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 84846cf35..4e061e340 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 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
@@ -40,8 +40,6 @@
* and rest arguments.
*/
-/* #define GSUBR_TEST */
-
/* OK here goes nothing: we're going to define VM assembly trampolines for
@@ -75,131 +73,79 @@
read-only data.
*/
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
-#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
-#endif
-
/* A: req; B: opt; C: rest */
#define A(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, nreq, 0, 0)
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0, \
+ 0
#define B(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 0)
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0
#define C() \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, 0, 0, 1)
+ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0, \
+ 0
#define AB(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 0)
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nreq + nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nreq + nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0)
#define AC(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, nreq, 0, 1)
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0
#define BC(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 1)
+ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0, \
+ 0
#define ABC(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 1)
-
-#define META(start, end, nreq, nopt, rest) \
- META_HEADER, \
- /* 0 */ scm_op_make_eol, /* bindings */ \
- /* 1 */ scm_op_make_eol, /* sources */ \
- /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
- /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
- /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \
- /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
- /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \
- /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
- /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
- /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \
- /* 27 */ scm_op_cons, /* make a pair for the properties */ \
- /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
- /* 31 */ scm_op_return /* and return */ \
- /* 32 */
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + nopt + 1), \
+ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
+ 0
+
/*
(defun generate-bytecode (n)
"Generate bytecode for N arguments"
(interactive "p")
- (insert (format "/\* %d arguments *\/\n " n))
+ (insert (format "/\* %d arguments *\/\n " n))
(let ((nreq n))
(while (<= 0 nreq)
(let ((nopt (- n nreq)))
(insert
(if (< 0 nreq)
(if (< 0 nopt)
- (format "AB(%d,%d), " nreq nopt)
- (format "A(%d), " nreq))
+ (format " AB(%d,%d)," nreq nopt)
+ (format " A(%d)," nreq))
(if (< 0 nopt)
- (format "B(%d), " nopt)
- (format "A(0), "))))
+ (format " B(%d)," nopt)
+ (format " A(0),"))))
(setq nreq (1- nreq))))
- (insert "\n ")
+ (insert "\n ")
(setq nreq (1- n))
(while (<= 0 nreq)
(let ((nopt (- n nreq 1)))
(insert
(if (< 0 nreq)
(if (< 0 nopt)
- (format "ABC(%d,%d), " nreq nopt)
- (format "AC(%d), " nreq))
+ (format " ABC(%d,%d)," nreq nopt)
+ (format " AC(%d)," nreq))
(if (< 0 nopt)
- (format "BC(%d), " nopt)
- (format "C(), "))))
+ (format " BC(%d)," nopt)
+ (format " C(),"))))
(setq nreq (1- nreq))))
(insert "\n\n ")))
@@ -211,621 +157,156 @@
(generate-bytecode i)
(setq i (1+ i)))))
*/
-static const struct
-{
- scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
- const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- /* C-u 1 0 M-x generate-bytecodes RET */
- /* 0 arguments */
- A(0),
-
- /* 1 arguments */
- A(1), B(1),
- C(),
-
- /* 2 arguments */
- A(2), AB(1,1), B(2),
- AC(1), BC(1),
-
- /* 3 arguments */
- A(3), AB(2,1), AB(1,2), B(3),
- AC(2), ABC(1,1), BC(2),
-
- /* 4 arguments */
- A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
- AC(3), ABC(2,1), ABC(1,2), BC(3),
-
- /* 5 arguments */
- A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
- AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
-
- /* 6 arguments */
- A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
- AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
-
- /* 7 arguments */
- A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
- AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
-
- /* 8 arguments */
- A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
- AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
-
- /* 9 arguments */
- A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
- AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),
-
- /* 10 arguments */
- A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
- AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9)
- }
-};
-
-#undef A
-#undef B
-#undef C
-#undef AB
-#undef AC
-#undef BC
-#undef ABC
-#undef OBJCODE_HEADER
-#undef META_HEADER
-#undef META
-
-/*
- ;; (nargs * nargs) + nopt + rest * (nargs + 1)
- (defun generate-objcode-cells-helper (n)
- "Generate objcode cells for N arguments"
- (interactive "p")
- (insert (format " /\* %d arguments *\/\n" n))
- (let ((nreq n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq)))
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 16 4 4 32)
- (+ (* n n) nopt))))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq nreq (1- nreq))))
- (insert "\n")
- (setq nreq (1- n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq 1)))
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 16 4 4 32)
- (+ (* n n) nopt n 1))))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq nreq (1- nreq))))
- (insert "\n")))
-
- (defun generate-objcode-cells (n)
- "Generate objcode cells for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (<= i n)
- (generate-objcode-cells-helper i)
- (setq i (1+ i)))))
-*/
-
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
-{
- scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[121 * 2]; /* 11*11 double cells */
-} objcode_cells = {
- 0,
- /* C-u 1 0 M-x generate-objcode-cells RET */
- {
- /* 0 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
-
- /* 1 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 2 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
- { 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 + 512) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 3 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 4 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 5 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 6 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 7 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 8 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 9 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 10 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-/*
- (defun generate-objcode (n)
- "Generate objcode for N arguments"
- (interactive "p")
- (insert (format " /\* %d arguments *\/\n" n))
- (let ((i (* n n)))
- (while (< i (* (1+ n) (1+ n)))
- (insert (format " SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
- (setq i (1+ i)))
- (insert "\n")))
-
- (defun generate-objcodes (n)
- "Generate objcodes for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (<= i n)
- (generate-objcode i)
- (setq i (1+ i)))))
-*/
-static const SCM scm_subr_objcode_trampolines[121] = {
- /* C-u 1 0 M-x generate-objcodes RET */
+static const scm_t_uint32 subr_stub_code[] = {
+ /* C-u 1 0 M-x generate-bytecodes RET */
/* 0 arguments */
- SCM_PACK (objcode_cells.cells+0),
+ A(0),
/* 1 arguments */
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
+ A(1), B(1),
+ C(),
/* 2 arguments */
- 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),
+ A(2), AB(1,1), B(2),
+ AC(1), BC(1),
/* 3 arguments */
- SCM_PACK (objcode_cells.cells+18),
- SCM_PACK (objcode_cells.cells+20),
- SCM_PACK (objcode_cells.cells+22),
- SCM_PACK (objcode_cells.cells+24),
- SCM_PACK (objcode_cells.cells+26),
- SCM_PACK (objcode_cells.cells+28),
- SCM_PACK (objcode_cells.cells+30),
+ A(3), AB(2,1), AB(1,2), B(3),
+ AC(2), ABC(1,1), BC(2),
/* 4 arguments */
- SCM_PACK (objcode_cells.cells+32),
- SCM_PACK (objcode_cells.cells+34),
- SCM_PACK (objcode_cells.cells+36),
- SCM_PACK (objcode_cells.cells+38),
- SCM_PACK (objcode_cells.cells+40),
- SCM_PACK (objcode_cells.cells+42),
- SCM_PACK (objcode_cells.cells+44),
- SCM_PACK (objcode_cells.cells+46),
- SCM_PACK (objcode_cells.cells+48),
+ A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
+ AC(3), ABC(2,1), ABC(1,2), BC(3),
/* 5 arguments */
- SCM_PACK (objcode_cells.cells+50),
- SCM_PACK (objcode_cells.cells+52),
- SCM_PACK (objcode_cells.cells+54),
- SCM_PACK (objcode_cells.cells+56),
- SCM_PACK (objcode_cells.cells+58),
- SCM_PACK (objcode_cells.cells+60),
- SCM_PACK (objcode_cells.cells+62),
- SCM_PACK (objcode_cells.cells+64),
- SCM_PACK (objcode_cells.cells+66),
- SCM_PACK (objcode_cells.cells+68),
- SCM_PACK (objcode_cells.cells+70),
+ A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
+ AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
/* 6 arguments */
- SCM_PACK (objcode_cells.cells+72),
- SCM_PACK (objcode_cells.cells+74),
- SCM_PACK (objcode_cells.cells+76),
- SCM_PACK (objcode_cells.cells+78),
- SCM_PACK (objcode_cells.cells+80),
- SCM_PACK (objcode_cells.cells+82),
- SCM_PACK (objcode_cells.cells+84),
- SCM_PACK (objcode_cells.cells+86),
- SCM_PACK (objcode_cells.cells+88),
- SCM_PACK (objcode_cells.cells+90),
- SCM_PACK (objcode_cells.cells+92),
- SCM_PACK (objcode_cells.cells+94),
- SCM_PACK (objcode_cells.cells+96),
+ A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
+ AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
/* 7 arguments */
- SCM_PACK (objcode_cells.cells+98),
- SCM_PACK (objcode_cells.cells+100),
- SCM_PACK (objcode_cells.cells+102),
- SCM_PACK (objcode_cells.cells+104),
- SCM_PACK (objcode_cells.cells+106),
- SCM_PACK (objcode_cells.cells+108),
- SCM_PACK (objcode_cells.cells+110),
- SCM_PACK (objcode_cells.cells+112),
- SCM_PACK (objcode_cells.cells+114),
- SCM_PACK (objcode_cells.cells+116),
- SCM_PACK (objcode_cells.cells+118),
- SCM_PACK (objcode_cells.cells+120),
- SCM_PACK (objcode_cells.cells+122),
- SCM_PACK (objcode_cells.cells+124),
- SCM_PACK (objcode_cells.cells+126),
+ A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
+ AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
/* 8 arguments */
- SCM_PACK (objcode_cells.cells+128),
- SCM_PACK (objcode_cells.cells+130),
- SCM_PACK (objcode_cells.cells+132),
- SCM_PACK (objcode_cells.cells+134),
- SCM_PACK (objcode_cells.cells+136),
- SCM_PACK (objcode_cells.cells+138),
- SCM_PACK (objcode_cells.cells+140),
- SCM_PACK (objcode_cells.cells+142),
- SCM_PACK (objcode_cells.cells+144),
- SCM_PACK (objcode_cells.cells+146),
- SCM_PACK (objcode_cells.cells+148),
- SCM_PACK (objcode_cells.cells+150),
- SCM_PACK (objcode_cells.cells+152),
- SCM_PACK (objcode_cells.cells+154),
- SCM_PACK (objcode_cells.cells+156),
- SCM_PACK (objcode_cells.cells+158),
- SCM_PACK (objcode_cells.cells+160),
+ A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
+ AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
/* 9 arguments */
- SCM_PACK (objcode_cells.cells+162),
- SCM_PACK (objcode_cells.cells+164),
- SCM_PACK (objcode_cells.cells+166),
- SCM_PACK (objcode_cells.cells+168),
- SCM_PACK (objcode_cells.cells+170),
- SCM_PACK (objcode_cells.cells+172),
- SCM_PACK (objcode_cells.cells+174),
- SCM_PACK (objcode_cells.cells+176),
- SCM_PACK (objcode_cells.cells+178),
- SCM_PACK (objcode_cells.cells+180),
- SCM_PACK (objcode_cells.cells+182),
- SCM_PACK (objcode_cells.cells+184),
- SCM_PACK (objcode_cells.cells+186),
- SCM_PACK (objcode_cells.cells+188),
- SCM_PACK (objcode_cells.cells+190),
- SCM_PACK (objcode_cells.cells+192),
- SCM_PACK (objcode_cells.cells+194),
- SCM_PACK (objcode_cells.cells+196),
- SCM_PACK (objcode_cells.cells+198),
+ A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
+ AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),
/* 10 arguments */
- SCM_PACK (objcode_cells.cells+200),
- SCM_PACK (objcode_cells.cells+202),
- SCM_PACK (objcode_cells.cells+204),
- SCM_PACK (objcode_cells.cells+206),
- SCM_PACK (objcode_cells.cells+208),
- SCM_PACK (objcode_cells.cells+210),
- SCM_PACK (objcode_cells.cells+212),
- SCM_PACK (objcode_cells.cells+214),
- SCM_PACK (objcode_cells.cells+216),
- SCM_PACK (objcode_cells.cells+218),
- SCM_PACK (objcode_cells.cells+220),
- SCM_PACK (objcode_cells.cells+222),
- SCM_PACK (objcode_cells.cells+224),
- SCM_PACK (objcode_cells.cells+226),
- SCM_PACK (objcode_cells.cells+228),
- SCM_PACK (objcode_cells.cells+230),
- SCM_PACK (objcode_cells.cells+232),
- SCM_PACK (objcode_cells.cells+234),
- SCM_PACK (objcode_cells.cells+236),
- SCM_PACK (objcode_cells.cells+238),
- SCM_PACK (objcode_cells.cells+240)
+ A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
+ AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9),
};
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+
/* (nargs * nargs) + nopt + rest * (nargs + 1) */
-#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
- scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
- + nopt + rest * (nreq + nopt + rest + 1)]
+#define SUBR_STUB_CODE(nreq,nopt,rest) \
+ &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)) * 4]
-SCM
-scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
- unsigned int rest)
+static const scm_t_uint32*
+get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
{
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
- return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
+ return SUBR_STUB_CODE (nreq, nopt, rest);
}
static SCM
-create_gsubr (int define, const char *name,
- unsigned int nreq, unsigned int nopt, unsigned int rest,
- SCM (*fcn) (), SCM *generic_loc)
+create_subr (int define, const char *name,
+ unsigned int nreq, unsigned int nopt, unsigned int rest,
+ SCM (*fcn) (), SCM *generic_loc)
{
- SCM ret;
- SCM sname;
- SCM table;
+ SCM ret, sname;
scm_t_bits flags;
+ scm_t_bits nfree = generic_loc ? 3 : 2;
- /* make objtable */
sname = scm_from_utf8_symbol (name);
- table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
- SCM_SIMPLE_VECTOR_SET (table, 1, sname);
- if (generic_loc)
- SCM_SIMPLE_VECTOR_SET (table, 2,
- scm_from_pointer (generic_loc, NULL));
- /* make program */
- ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
- table, SCM_BOOL_F);
-
- /* set flags */
+ 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);
+ 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);
+ if (generic_loc)
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 2,
+ scm_from_pointer (generic_loc, NULL));
- /* define, if needed */
if (define)
scm_define (sname, ret);
- /* et voila. */
return ret;
}
+/* Given an RTL primitive, determine its minimum arity. This is
+ possible because each RTL primitive is 4 32-bit words long, and they
+ are laid out contiguously in an ordered pattern. */
+int
+scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
+{
+ const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (prim);
+ unsigned idx, nargs, base, next;
+
+ if (code < subr_stub_code)
+ return 0;
+ if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
+ return 0;
+
+ idx = (code - subr_stub_code) / 4;
+
+ nargs = -1;
+ next = 0;
+ do
+ {
+ base = next;
+ nargs++;
+ next = (nargs + 1) * (nargs + 1);
+ }
+ while (idx >= next);
+
+ *rest = (next - idx) < (idx - base);
+ *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
+ *opt = *rest ? idx - (next - nargs) : idx - base;
+
+ return 1;
+}
+
+int
+scm_i_primitive_call_ip (SCM subr)
+{
+ const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (subr);
+
+ /* A stub is 4 32-bit words long, or 16 bytes. The call will be one
+ instruction, in either the fourth, third, or second word. Return a
+ byte offset from the entry. */
+ return code[3] ? 12 : code[2] ? 8 : 4;
+}
+
SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_gsubr (0, name, req, opt, rst, fcn, NULL);
+ return create_subr (0, name, req, opt, rst, fcn, NULL);
}
SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_gsubr (1, name, req, opt, rst, fcn, NULL);
+ return create_subr (1, name, req, opt, rst, fcn, NULL);
}
SCM
@@ -836,7 +317,7 @@ scm_c_make_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_gsubr (0, name, req, opt, rst, fcn, gf);
+ return create_subr (0, name, req, opt, rst, fcn, gf);
}
SCM
@@ -847,38 +328,12 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM (*fcn)(),
SCM *gf)
{
- return create_gsubr (1, name, req, opt, rst, fcn, gf);
+ return create_subr (1, name, req, opt, rst, fcn, gf);
}
-
-#ifdef GSUBR_TEST
-/* A silly example, taking 2 required args, 1 optional, and
- a scm_list of rest args
- */
-SCM
-gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
-{
- scm_puts_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
- scm_display(req1, scm_cur_outp);
- scm_puts_unlocked ("\n req2: ", scm_cur_outp);
- scm_display(req2, scm_cur_outp);
- scm_puts_unlocked ("\n opt: ", scm_cur_outp);
- scm_display(opt, scm_cur_outp);
- scm_puts_unlocked ("\n rest: ", scm_cur_outp);
- scm_display(rst, scm_cur_outp);
- scm_newline(scm_cur_outp);
- return SCM_UNSPECIFIED;
-}
-#endif
-
-
void
scm_init_gsubr()
{
-#ifdef GSUBR_TEST
- scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
-#endif
-
#include "libguile/gsubr.x"
}
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 5adffa4fe..6bdfe6baf 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -4,7 +4,7 @@
#define SCM_GSUBR_H
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2011 Free Software Foundation, Inc.
+ * 2010, 2011, 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
@@ -30,36 +30,33 @@
-SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
- unsigned int nopt,
- unsigned int rest);
-
-
/* Subrs
*/
/* Max number of args to the C procedure backing a gsubr */
#define SCM_GSUBR_MAX 10
-#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
+#define SCM_PRIMITIVE_P(x) (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
-#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
+#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) \
- ((SCM (*) (void)) \
- SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))
+ ((SCM (*) (void)) \
+ SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 0)))
-#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_NAME(x) (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 1))
#define SCM_SUBR_GENERIC(x) \
- ((SCM *) \
- SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
+ ((SCM *) SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 2)))
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
+SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
+SCM_INTERNAL int scm_i_primitive_call_ip (SCM subr);
+
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, scm_t_subr fcn);
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
diff --git a/libguile/programs.c b/libguile/programs.c
index 5039d2a2b..c10dede10 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -116,6 +116,9 @@ scm_i_rtl_program_name (SCM program)
{
static SCM rtl_program_name = SCM_BOOL_F;
+ if (SCM_PRIMITIVE_P (program))
+ return SCM_SUBR_NAME (program);
+
if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
rtl_program_name =
scm_c_private_variable ("system vm program", "rtl-program-name");
@@ -128,6 +131,9 @@ scm_i_rtl_program_documentation (SCM program)
{
static SCM rtl_program_documentation = SCM_BOOL_F;
+ if (SCM_PRIMITIVE_P (program))
+ return SCM_BOOL_F;
+
if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
rtl_program_documentation =
scm_c_private_variable ("system vm program",
@@ -141,6 +147,14 @@ scm_i_rtl_program_properties (SCM program)
{
static SCM rtl_program_properties = SCM_BOOL_F;
+ if (SCM_PRIMITIVE_P (program))
+ {
+ SCM name = scm_i_rtl_program_name (program);
+ if (scm_is_false (name))
+ return SCM_EOL;
+ return scm_acons (scm_sym_name, name, SCM_EOL);
+ }
+
if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
rtl_program_properties =
scm_c_private_variable ("system vm program", "rtl-program-properties");
@@ -219,6 +233,26 @@ SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_primitive_p
+{
+ return scm_from_bool (SCM_PRIMITIVE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
+ (SCM prim),
+ "")
+#define FUNC_NAME s_scm_primitive_p
+{
+ SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
+
+ return scm_from_int (scm_i_primitive_call_ip (prim));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program),
"")
@@ -487,6 +521,9 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
static SCM rtl_program_minimum_arity = SCM_BOOL_F;
SCM l;
+ if (SCM_PRIMITIVE_P (program))
+ return scm_i_primitive_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",
diff --git a/libguile/programs.h b/libguile/programs.h
index 275570cd1..1ecc35d9a 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -44,6 +44,9 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM free
SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
+SCM_INTERNAL SCM scm_primitive_p (SCM obj);
+SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim);
+
SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 3931570f4..7843ac8da 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -4,7 +4,7 @@
#define SCM_SNARF_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2004, 2006, 2009, 2010, 2011, 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
@@ -96,48 +96,9 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
-#ifdef SCM_SUPPORT_STATIC_ALLOCATION
-
-/* Static subr allocation. */
-/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
-#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
-SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
-SCM_SNARF_HERE( \
- static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
- SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \
- (scm_t_bits) &FNAME); /* the subr */ \
- SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
- /* FIXME: directly be the foreign */ \
- SCM_BOOL_F); \
- /* FIXME: be immutable. grr */ \
- SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
- SCM_BOOL_F, \
- SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
- SCM_BOOL_F); \
- SCM FNAME ARGLIST \
-) \
-SCM_SNARF_INIT( \
- /* Initialize the foreign. */ \
- scm_i_paste (FNAME, __raw_objtable)[1] = scm_i_paste (FNAME, __subr_foreign); \
- /* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __name); \
- /* Initialize the objcode trampoline. */ \
- SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
- scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
- \
- /* Define the subr. */ \
- scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
-) \
-SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
-
-#else /* !SCM_SUPPORT_STATIC_ALLOCATION */
-
/* Always use the generic subr case. */
#define SCM_DEFINE SCM_DEFINE_GSUBR
-#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
-
#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 86db41180..4466504de 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -198,7 +198,8 @@
;; returns list of list of bindings
;; (list-ref ret N) == bindings bound to the Nth local slot
(define (program-bindings-by-index prog)
- (cond ((program-bindings prog) => collapse-locals)
+ (cond ((rtl-program? prog) '())
+ ((program-bindings prog) => collapse-locals)
(else '())))
(define (program-bindings-for-ip prog ip)
@@ -291,14 +292,29 @@
;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list."
- (if (rtl-program? prog)
+ (cond
+ ((primitive? prog)
+ (match (procedure-minimum-arity prog)
+ (#f #f)
+ ((nreq nopt rest?)
+ (let ((start (primitive-call-ip prog)))
+ ;; Assume that there is only one IP for the call.
+ (and (or (not ip) (= start ip))
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ()))))))))
+ ((rtl-program? prog)
+ (let ((pc (and ip (+ (rtl-program-code prog) ip))))
(or-map (lambda (arity)
- (and #t
+ (and (or (not pc)
+ (and (<= (arity-low-pc arity) pc)
+ (< pc (arity-high-pc arity))))
(arity-arguments-alist arity)))
- (or (find-program-arities (rtl-program-code prog)) '()))
- (let ((arity (program-arity prog ip)))
- (and arity
- (arity->arguments-alist prog arity)))))
+ (or (find-program-arities (rtl-program-code prog)) '()))))
+ (else
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments-alist prog arity))))))
(define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list."
@@ -325,6 +341,14 @@
(define (program-arguments-alists prog)
(cond
+ ((primitive? prog)
+ (match (procedure-minimum-arity prog)
+ (#f '())
+ ((nreq nopt rest?)
+ (list
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ())))))))
((rtl-program? prog)
(map arity-arguments-alist
(or (find-program-arities (rtl-program-code prog)) '())))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 24afe2da0..a0221b81b 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 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
@@ -349,7 +349,9 @@
(define tag (make-prompt-tag "foo"))
(with-test-prefix "stacks"
- (pass-if "stack involving a primitive"
+ ;; FIXME: Until we get one VM, a call to an RTL primitive from the
+ ;; stack VM will result in the primitive being on the stack twice.
+ (expect-fail "stack involving a primitive"
;; The primitive involving the error must appear exactly once on the
;; stack.
(let* ((stack (make-tagged-trimmed-stack tag '(#t)))