mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

Subrs are RTL programs

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-10-18 10:03:26 +02:00
parent 9dff1df97f
commit 27337b6373
7 changed files with 227 additions and 748 deletions
Download patch file Download diff file Expand all files Collapse all files

735
libguile/gsubr.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -40,8 +40,6 @@
* and rest arguments. * and rest arguments.
*/ */
/* #define GSUBR_TEST */
/* OK here goes nothing: we're going to define VM assembly trampolines for /* OK here goes nothing: we're going to define VM assembly trampolines for
@ -75,101 +73,49 @@
read-only data. 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 */ /* A: req; B: opt; C: rest */
#define A(nreq) \ #define A(nreq) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1), \
/* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ 0, \
/* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \ 0
/* 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)
#define B(nopt) \ #define B(nopt) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nopt + 1), \
/* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nopt + 1), \
/* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ 0
/* 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)
#define C() \ #define C() \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, 1), \
/* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ 0, \
/* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \ 0
/* 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)
#define AB(nreq, nopt) \ #define AB(nreq, nopt) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
/* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nreq + nopt + 1), \
/* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nreq + nopt + 1), \
/* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0)
/* 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)
#define AC(nreq) \ #define AC(nreq) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
/* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + 1), \
/* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ 0
/* 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)
#define BC(nopt) \ #define BC(nopt) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nopt + 1), \
/* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \ 0, \
/* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ 0
/* 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)
#define ABC(nreq, nopt) \ #define ABC(nreq, nopt) \
OBJCODE_HEADER, \ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \
/* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + nopt + 1), \
/* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \
/* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \ 0
/* 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 */
/* /*
(defun generate-bytecode (n) (defun generate-bytecode (n)
@ -211,14 +157,7 @@
(generate-bytecode i) (generate-bytecode i)
(setq i (1+ i))))) (setq i (1+ i)))))
*/ */
static const struct static const scm_t_uint32 subr_stub_code[] = {
{
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 */ /* C-u 1 0 M-x generate-bytecodes RET */
/* 0 arguments */ /* 0 arguments */
A(0), A(0),
@ -261,8 +200,7 @@ static const struct
/* 10 arguments */ /* 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), 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) 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 A
@ -272,560 +210,103 @@ static const struct
#undef AC #undef AC
#undef BC #undef BC
#undef ABC #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 */
/* 0 arguments */
SCM_PACK (objcode_cells.cells+0),
/* 1 arguments */
SCM_PACK (objcode_cells.cells+2),
SCM_PACK (objcode_cells.cells+4),
SCM_PACK (objcode_cells.cells+6),
/* 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),
/* 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),
/* 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),
/* 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),
/* 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),
/* 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),
/* 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),
/* 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),
/* 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)
};
/* (nargs * nargs) + nopt + rest * (nargs + 1) */ /* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \ #define SUBR_STUB_CODE(nreq,nopt,rest) \
scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \ &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \
+ nopt + rest * (nreq + nopt + rest + 1)] + nopt + rest * (nreq + nopt + rest + 1)) * 4]
SCM static const scm_t_uint32*
scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt, get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
unsigned int rest)
{ {
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10)) if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest)); 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 static SCM
create_gsubr (int define, const char *name, create_subr (int define, const char *name,
unsigned int nreq, unsigned int nopt, unsigned int rest, unsigned int nreq, unsigned int nopt, unsigned int rest,
SCM (*fcn) (), SCM *generic_loc) SCM (*fcn) (), SCM *generic_loc)
{ {
SCM ret; SCM ret, sname;
SCM sname;
SCM table;
scm_t_bits flags; scm_t_bits flags;
scm_t_bits nfree = generic_loc ? 3 : 2;
/* make objtable */
sname = scm_from_utf8_symbol (name); 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_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
table, SCM_BOOL_F);
/* set flags */
flags = SCM_F_PROGRAM_IS_PRIMITIVE; flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0; 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_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) if (define)
scm_define (sname, ret); scm_define (sname, ret);
/* et voila. */
return ret; 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
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) 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
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) 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 SCM
@ -836,7 +317,7 @@ scm_c_make_gsubr_with_generic (const char *name,
SCM (*fcn)(), SCM (*fcn)(),
SCM *gf) SCM *gf)
{ {
return create_gsubr (0, name, req, opt, rst, fcn, gf); return create_subr (0, name, req, opt, rst, fcn, gf);
} }
SCM SCM
@ -847,38 +328,12 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM (*fcn)(), SCM (*fcn)(),
SCM *gf) 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 void
scm_init_gsubr() 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" #include "libguile/gsubr.x"
} }

21
libguile/gsubr.h
View file

@ -4,7 +4,7 @@
#define SCM_GSUBR_H #define SCM_GSUBR_H
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 /* Subrs
*/ */
/* Max number of args to the C procedure backing a gsubr */ /* Max number of args to the C procedure backing a gsubr */
#define SCM_GSUBR_MAX 10 #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) \ #define SCM_SUBRF(x) \
((SCM (*) (void)) \ ((SCM (*) (void)) \
SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0))) 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) \ #define SCM_SUBR_GENERIC(x) \
((SCM *) \ ((SCM *) SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 2)))
SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
#define SCM_SET_SUBR_GENERIC(x, g) \ #define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_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, SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, scm_t_subr fcn); int req, int opt, int rst, scm_t_subr fcn);
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name, SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,

37
libguile/programs.c
View file

@ -116,6 +116,9 @@ scm_i_rtl_program_name (SCM program)
{ {
static SCM rtl_program_name = SCM_BOOL_F; 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) if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
rtl_program_name = rtl_program_name =
scm_c_private_variable ("system vm program", "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; 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) if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
rtl_program_documentation = rtl_program_documentation =
scm_c_private_variable ("system vm program", 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; 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) if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
rtl_program_properties = rtl_program_properties =
scm_c_private_variable ("system vm program", "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 #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_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program), (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; static SCM rtl_program_minimum_arity = SCM_BOOL_F;
SCM l; 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) if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
rtl_program_minimum_arity = rtl_program_minimum_arity =
scm_c_private_variable ("system vm program", scm_c_private_variable ("system vm program",

3
libguile/programs.h
View file

@ -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_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program); 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_name (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program); SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program); SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);

41
libguile/snarf.h
View file

@ -4,7 +4,7 @@
#define SCM_SNARF_H #define SCM_SNARF_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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) 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. */ /* Always use the generic subr case. */
#define SCM_DEFINE SCM_DEFINE_GSUBR #define SCM_DEFINE SCM_DEFINE_GSUBR
#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SNARF_HERE(\ SCM_SNARF_HERE(\

34
module/system/vm/program.scm
View file

@ -198,7 +198,8 @@
;; returns list of list of bindings ;; returns list of list of bindings
;; (list-ref ret N) == bindings bound to the Nth local slot ;; (list-ref ret N) == bindings bound to the Nth local slot
(define (program-bindings-by-index prog) (define (program-bindings-by-index prog)
(cond ((program-bindings prog) => collapse-locals) (cond ((rtl-program? prog) '())
((program-bindings prog) => collapse-locals)
(else '()))) (else '())))
(define (program-bindings-for-ip prog ip) (define (program-bindings-for-ip prog ip)
@ -291,14 +292,29 @@
;; the name "program-arguments" is taken by features.c... ;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip) (define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list." "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) (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))) (arity-arguments-alist arity)))
(or (find-program-arities (rtl-program-code prog)) '())) (or (find-program-arities (rtl-program-code prog)) '()))))
(else
(let ((arity (program-arity prog ip))) (let ((arity (program-arity prog ip)))
(and arity (and arity
(arity->arguments-alist prog arity))))) (arity->arguments-alist prog arity))))))
(define* (program-lambda-list prog #:optional ip) (define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list." "Returns the signature of the given procedure in the form of an argument list."
@ -325,6 +341,14 @@
(define (program-arguments-alists prog) (define (program-arguments-alists prog)
(cond (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) ((rtl-program? prog)
(map arity-arguments-alist (map arity-arguments-alist
(or (find-program-arities (rtl-program-code prog)) '()))) (or (find-program-arities (rtl-program-code prog)) '())))

6
test-suite/tests/eval.test
View file

@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -349,7 +349,9 @@
(define tag (make-prompt-tag "foo")) (define tag (make-prompt-tag "foo"))
(with-test-prefix "stacks" (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 ;; The primitive involving the error must appear exactly once on the
;; stack. ;; stack.
(let* ((stack (make-tagged-trimmed-stack tag '(#t))) (let* ((stack (make-tagged-trimmed-stack tag '(#t)))