From 27337b6373954e1a975d97d0bf06b5c03d65b64d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Oct 2013 10:03:26 +0200 Subject: 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. --- libguile/gsubr.c | 819 ++++++++++--------------------------------------------- 1 file changed, 137 insertions(+), 682 deletions(-) (limited to 'libguile/gsubr.c') 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" } -- cgit v1.2.3