diff options
Diffstat (limited to 'libguile/gsubr.c')
-rw-r--r-- | libguile/gsubr.c | 653 |
1 files changed, 410 insertions, 243 deletions
diff --git a/libguile/gsubr.c b/libguile/gsubr.c index e22d16363..644262737 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,38 +1,48 @@ -/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013, 2015 - * 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 - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ +/* Copyright 1995-2001,2006,2008-2011,2013,2015,2018-2019 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + #ifdef HAVE_CONFIG_H # include <config.h> #endif +#include <flexmember.h> #include <stdio.h> #include <stdarg.h> +#include <string.h> + +#include "foreign.h" +#include "frames.h" +#include "instructions.h" +#include "jit.h" +#include "modules.h" +#include "numbers.h" +#include "private-options.h" +#include "programs.h" +#include "srfi-4.h" +#include "symbols.h" +#include "threads.h" + +#include "gsubr.h" -#include "libguile/_scm.h" -#include "libguile/gsubr.h" -#include "libguile/foreign.h" -#include "libguile/instructions.h" -#include "libguile/srfi-4.h" -#include "libguile/programs.h" -#include "libguile/private-options.h" /* * gsubr.c @@ -40,224 +50,309 @@ * and rest arguments. */ +/* In July 2018 there were 1140 subrs defined in stock Guile. */ +static const size_t expected_subr_count = 1500; + +static scm_i_pthread_mutex_t admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + +static void **subrs = NULL; +static uint32_t next_subr_idx = 0; +static uint32_t subrs_array_size = 0; + +static uint32_t +alloc_subr_idx (void *subr) +{ + uint32_t idx; + + scm_i_pthread_mutex_lock (&admin_mutex); + + idx = next_subr_idx++; + + if (idx > 0xffffff) abort (); + + if (idx >= subrs_array_size) + { + void **new_subrs; + + if (subrs_array_size) + subrs_array_size *= 2; + else + subrs_array_size = expected_subr_count; + + /* Leak this allocation, as code lives as long as the program + does. In the likely case, we only make one malloc for the + program; in the general case it's still O(n) in number of subrs + because of the geometric factor. Use malloc instead of GC + allocations because it's not traceable and not collectable. */ + new_subrs = malloc (subrs_array_size * sizeof (void*)); + memcpy (new_subrs, subrs, idx * sizeof (void*)); + subrs = new_subrs; + } + + subrs[idx] = subr; + + scm_i_pthread_mutex_unlock (&admin_mutex); + + return idx; +} + -/* OK here goes nothing: we're going to define VM assembly trampolines for - invoking subrs. Ready? Right! */ - -/* There's a maximum of 10 args, so the number of possible combinations is: - (REQ-OPT-REST) - for 0 args: 1 (000) (1 + 0) - for 1 arg: 3 (100, 010, 001) (2 + 1) - for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2) - for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3) - for N args: 2N+1 - - and the index at which N args starts: - for 0 args: 0 - for 1 args: 1 - for 2 args: 4 - for 3 args: 9 - for N args: N^2 - - One can prove this: - - (1 + 3 + 5 + ... + (2N+1)) - = ((2N+1)+1)/2 * (N+1) - = 2(N+1)/2 * (N+1) - = (N+1)^2 - - Thus the total sum is 11^2 = 121. Let's just generate all of them as - read-only data. -*/ - -/* A: req; B: opt; C: rest */ -#define A(nreq) \ - SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0, \ - 0 - -#define B(nopt) \ - SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), \ - SCM_PACK_OP_24 (alloc_frame, nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0 - -#define C() \ - SCM_PACK_OP_24 (bind_rest, 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0, \ - 0 - -#define AB(nreq, nopt) \ - SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ - SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), \ - SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0) - -#define AC(nreq) \ - SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ - SCM_PACK_OP_24 (bind_rest, nreq + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0 - -#define BC(nopt) \ - SCM_PACK_OP_24 (bind_rest, nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0, \ - 0 - -#define ABC(nreq, nopt) \ - SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ - SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0), \ - 0 +static SCM *names = NULL; +static uint32_t names_array_size = 0; +static void +record_subr_name (uint32_t idx, SCM name) +{ + scm_i_pthread_mutex_lock (&admin_mutex); -/* - (defun generate-bytecode (n) - "Generate bytecode for N arguments" - (interactive "p") - (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)) - (if (< 0 nopt) - (format " B(%d)," nopt) - (format " A(0),")))) - (setq nreq (1- nreq)))) - (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)) - (if (< 0 nopt) - (format " BC(%d)," nopt) - (format " C(),")))) - (setq nreq (1- nreq)))) - (insert "\n\n "))) - - (defun generate-bytecodes (n) - "Generate bytecodes for up to N arguments" - (interactive "p") - (let ((i 0)) - (while (<= i n) - (generate-bytecode i) - (setq i (1+ i))))) -*/ -static const scm_t_uint32 subr_stub_code[] = { - /* 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), + if (idx >= names_array_size) + { + SCM *new_names; + uint32_t new_size; + + if (names_array_size) + new_size = names_array_size * 2; + else + new_size = expected_subr_count; + + new_names = SCM_GC_MALLOC (new_size * sizeof (SCM)); + memcpy (new_names, names, names_array_size * sizeof (SCM)); + while (names_array_size < new_size) + new_names[names_array_size++] = SCM_BOOL_F; + names = new_names; + names_array_size = new_size; + } + + names[idx] = name; + + scm_i_pthread_mutex_unlock (&admin_mutex); +} + + + +struct code_arena { + struct code_arena *next; + size_t size; + size_t used; + char data[FLEXIBLE_ARRAY_MEMBER]; +}; + +static struct code_arena *code_arena = NULL; + +static size_t +round_up_power_of_two (size_t n, size_t m) +{ + return (n + (m-1)) & ~(m-1); +} + +static struct code_arena * +alloc_chunk (size_t size, struct code_arena *next) +{ + /* Leak the allocation, as we currently don't allow code to be + collected. */ + struct code_arena *ret = malloc (FLEXSIZEOF (struct code_arena, data, size)); + if (!ret) abort (); + ret->next = next; + ret->size = size; + ret->used = 0; + return ret; +} + +static char * +alloc (size_t byte_size) +{ + char *ret; + + byte_size = round_up_power_of_two (byte_size, sizeof (void *)); + + scm_i_pthread_mutex_lock (&admin_mutex); + + if (code_arena == NULL || code_arena->size - code_arena->used < byte_size) + { + size_t chunk_size; + size_t avg_code_size = 6 * sizeof(uint32_t); + avg_code_size += sizeof (struct scm_jit_function_data); + + chunk_size = expected_subr_count * avg_code_size; + if (chunk_size < byte_size) + chunk_size = byte_size; + + code_arena = alloc_chunk (chunk_size, code_arena); + } + + ret = &code_arena->data[code_arena->used]; + code_arena->used += byte_size; + + scm_i_pthread_mutex_unlock (&admin_mutex); + + memset (ret, 0, byte_size); + + return ret; +} + +uint32_t * +scm_i_alloc_primitive_code_with_instrumentation (size_t uint32_count, + uint32_t **write_ptr) +{ + char *ptr; + uint32_t *ret; + struct scm_jit_function_data *data; + size_t byte_size, padded_byte_size; + + /* Reserve space for instrument-entry. */ + byte_size = (2 + uint32_count) * sizeof (uint32_t); + padded_byte_size = round_up_power_of_two (byte_size, sizeof (void *)); + /* Reserve space for jit data. */ + ptr = alloc (padded_byte_size + sizeof (struct scm_jit_function_data)); + ret = (uint32_t *) ptr; + data = (struct scm_jit_function_data*) (ptr + padded_byte_size); + + ret[0] = SCM_PACK_OP_24 (instrument_entry, 0); + ret[1] = padded_byte_size / 4; + + *write_ptr = ret + 2; + + data->mcode = NULL; + data->counter = 0; + data->start = -padded_byte_size; + data->end = -(padded_byte_size - byte_size); + + return ret; +} + +static int +is_primitive_code (const void *ptr) +{ + const char *cptr = ptr; + int ret = 0; + struct code_arena *arena; + + scm_i_pthread_mutex_lock (&admin_mutex); + for (arena = code_arena; arena; arena = arena->next) + if (&arena->data[0] <= cptr && cptr < &arena->data[arena->used]) + { + ret = 1; + break; + } + scm_i_pthread_mutex_unlock (&admin_mutex); + + return ret; +} + +static uint32_t * +alloc_subr_code (uint32_t subr_idx, uint32_t code[], size_t code_size) +{ + uint32_t post[3] = { SCM_PACK_OP_24 (subr_call, subr_idx), + SCM_PACK_OP_24 (handle_interrupts, 0), + SCM_PACK_OP_24 (return_values, 0) }; + uint32_t *ret, *write; + + ret = scm_i_alloc_primitive_code_with_instrumentation (code_size + 3, &write); + + memcpy (write, code, code_size * sizeof (uint32_t)); + write += code_size; + memcpy (write, post, 3 * sizeof (uint32_t)); + + return ret; +} + +enum arity_kind { + NULLARY = 0, + REQ = 1, + OPT = 2, + REST = 4, + REQ_OPT = REQ + OPT, + REQ_REST = REQ + REST, + OPT_REST = OPT + REST, + REQ_OPT_REST = REQ + OPT + REST }; -#undef A -#undef B -#undef C -#undef AB -#undef AC -#undef BC -#undef ABC - -/* (nargs * nargs) + nopt + rest * (nargs + 1) */ -#define SUBR_STUB_CODE(nreq,nopt,rest) \ - &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \ - + nopt + rest * (nreq + nopt + rest + 1)) * 6] - -static const scm_t_uint32* -get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest) +static uint32_t* +get_subr_stub_code (uint32_t subr_idx, + unsigned int nreq, unsigned int nopt, unsigned int rest) { + enum arity_kind kind = NULLARY; + if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10)) scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest)); - return SUBR_STUB_CODE (nreq, nopt, rest); + if (nreq) kind += REQ; + if (nopt) kind += OPT; + if (rest) kind += REST; + + switch (kind) + { + case NULLARY: + case REQ: + { + uint32_t code[1] = { SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1) }; + return alloc_subr_code (subr_idx, code, 1); + } + case OPT: + { + uint32_t code[2] = { SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), + SCM_PACK_OP_24 (bind_optionals, nopt + 1) }; + return alloc_subr_code (subr_idx, code, 2); + } + case REST: + { + uint32_t code[1] = { SCM_PACK_OP_24 (bind_rest, 1) }; + return alloc_subr_code (subr_idx, code, 1); + } + case REQ_OPT: + { + uint32_t code[3] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), + SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), + SCM_PACK_OP_24 (bind_optionals, nreq + nopt + 1) }; + return alloc_subr_code (subr_idx, code, 3); + } + case REQ_REST: + { + uint32_t code[2] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), + SCM_PACK_OP_24 (bind_rest, nreq + 1) }; + return alloc_subr_code (subr_idx, code, 2); + } + case OPT_REST: + { + uint32_t code[2] = { SCM_PACK_OP_24 (bind_optionals, nopt + 1), + SCM_PACK_OP_24 (bind_rest, nopt + 1) }; + return alloc_subr_code (subr_idx, code, 2); + } + case REQ_OPT_REST: + { + uint32_t code[3] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), + SCM_PACK_OP_24 (bind_optionals, nreq + nopt + 1), + SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1) }; + return alloc_subr_code (subr_idx, code, 3); + } + default: + abort (); + } } static SCM create_subr (int define, const char *name, unsigned int nreq, unsigned int nopt, unsigned int rest, - SCM (*fcn) (), SCM *generic_loc) + void *fcn, SCM *generic_loc) { SCM ret, sname; + uint32_t idx; scm_t_bits flags; - scm_t_bits nfree = generic_loc ? 3 : 2; + scm_t_bits nfree = generic_loc ? 1 : 0; + idx = alloc_subr_idx (fcn); sname = scm_from_utf8_symbol (name); flags = SCM_F_PROGRAM_IS_PRIMITIVE; flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0; ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); - SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest)); - SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL)); - SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname); + SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (idx, nreq, nopt, rest)); + record_subr_name (idx, sname); if (generic_loc) - SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2, - scm_from_pointer (generic_loc, NULL)); + SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, + scm_from_pointer (generic_loc, NULL)); if (define) scm_define (sname, ret); @@ -266,35 +361,113 @@ create_subr (int define, const char *name, } int -scm_i_primitive_code_p (const scm_t_uint32 *code) +scm_i_primitive_code_p (const uint32_t *code) { - if (code < subr_stub_code) - return 0; - if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32))) - return 0; + return is_primitive_code (code); +} + +static uintptr_t +primitive_call_ip (const uint32_t *code) +{ + int direction = 0; + while (1) + { + switch (code[0] & 0xff) + { + case scm_op_instrument_entry: + if (direction < 0) abort (); + direction = 1; + code += 2; + break; + case scm_op_assert_nargs_ee: + case scm_op_assert_nargs_le: + case scm_op_assert_nargs_ge: + case scm_op_bind_optionals: + case scm_op_bind_rest: + case scm_op_alloc_frame: + if (direction < 0) abort (); + direction = 1; + code += 1; + break; + case scm_op_subr_call: + case scm_op_foreign_call: + return (uintptr_t) code; + case scm_op_return_values: + case scm_op_handle_interrupts: + /* Going back isn't possible for instruction streams where we + don't know the length of the preceding instruction, but for + the code we emit, these particular opcodes are only ever + preceded by 4-byte instructions. */ + if (direction > 0) abort (); + direction = -1; + code -= 1; + break; + default: + return 0; + } + } +} + +static const uint32_t NOT_A_SUBR_CALL = 0xffffffff; - return 1; +static uint32_t +primitive_subr_idx (const uint32_t *code) +{ + uint32_t word; + uintptr_t call_ip = primitive_call_ip (code); + if (call_ip == 0) + return NOT_A_SUBR_CALL; + word = ((uint32_t *) call_ip)[0]; + if ((word & 0xff) == scm_op_subr_call) + { + uint32_t idx = word >> 8; + if (idx >= next_subr_idx) abort(); + return idx; + } + else + return NOT_A_SUBR_CALL; } -scm_t_uintptr +uintptr_t scm_i_primitive_call_ip (SCM subr) { - size_t i; - const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr); - - /* A stub is 6 32-bit words long, or 24 bytes. The call will be one - instruction, in either the fourth, third, or second word. Return a - byte offset from the entry. */ - for (i = 1; i < 4; i++) - if ((code[i] & 0xff) == scm_op_subr_call) - return (scm_t_uintptr) (code + i); - abort (); + return primitive_call_ip (SCM_PROGRAM_CODE (subr)); } SCM -scm_apply_subr (union scm_vm_stack_element *sp, scm_t_ptrdiff nslots) +scm_i_primitive_name (const uint32_t *code) { - SCM (*subr)() = SCM_SUBRF (sp[nslots - 1].as_scm); + uint32_t idx = primitive_subr_idx (code); + if (idx == NOT_A_SUBR_CALL) + return SCM_BOOL_F; + return names[idx]; +} + +scm_t_subr +scm_subr_function_by_index (uint32_t idx) +{ + if (idx == NOT_A_SUBR_CALL) + abort (); + return subrs[idx]; +} + +scm_t_subr +scm_subr_function (SCM subr) +{ + uint32_t idx = primitive_subr_idx (SCM_PROGRAM_CODE (subr)); + return scm_subr_function_by_index (idx); +} + +SCM +scm_subr_name (SCM subr) +{ + return scm_i_primitive_name (SCM_PROGRAM_CODE (subr)); +} + +SCM +scm_apply_subr (union scm_vm_stack_element *sp, uint32_t idx, ptrdiff_t nslots) +{ + SCM (*subr)() = subrs[idx]; #define ARG(i) (sp[i].as_scm) switch (nslots - 1) @@ -369,11 +542,5 @@ scm_c_define_gsubr_with_generic (const char *name, void scm_init_gsubr() { -#include "libguile/gsubr.x" +#include "gsubr.x" } - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |