From 4a2d78b4d463cd29226f3eee776dcad9f64e6152 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 25 Jun 2018 15:49:34 +0200 Subject: [PATCH] Give multiple-values objects a tc7 * libguile/scm.h (scm_tc7_values): New tc7. Never seen by Scheme, so we don't need to update it anywhere else. * libguile/values.h (scm_is_values): New public static inline function. (scm_i_nvalues, scm_i_value_ref): New private static inline functions. (SCM_VALUESP): Use scm_is_value. (scm_values_2, scm_values_3): New functions. (scm_values_vtable): Remove; values objects are not structs any more. * libguile/values.c (scm_i_extract_values_2): Adapt to new values representation. (print_values): Remove now-unused function. (scm_c_nvalues): Use scm_i_nvalues. (scm_c_value_ref): Use scm_i_value_ref. (scm_values, scm_c_values): Make the new-style objects, which store their values inline. (scm_values_2, scm_values_3): New helpers, to avoid consing little useless lists. * libguile/vm-engine.c (halt, subr-call) * libguile/eval.c (eval): Adapt to new values representation. * libguile/i18n.c (scm_locale_string_to_integer) (scm_locale_string_to_integer) * libguile/numbers.c (scm_i_floor_divide, scm_i_ceiling_divide) (scm_i_truncate_divide, scm_i_centered_divide, scm_i_round_divide) (scm_i_exact_integer_sqrt) * libguile/r6rs-ports.c (make_bytevector_output_port) * libguile/srfi-1.c (scm_srfi1_partition, scm_srfi1_partition_x) * libguile/srfi-14.c (scm_char_set_diff_plus_intersection) (scm_char_set_diff_plus_intersection_x) * libguile/posix.c (scm_getrlimit, scm_open_process): Adapt to use scm_values_2 or scm_values_3. * libguile/print.c (iprin1): Add printer for values objects. --- libguile/eval.c | 16 ++++--- libguile/i18n.c | 4 +- libguile/numbers.c | 12 ++--- libguile/posix.c | 12 ++--- libguile/print.c | 7 +++ libguile/r6rs-ports.c | 2 +- libguile/scm.h | 2 +- libguile/srfi-1.c | 9 +--- libguile/srfi-14.c | 4 +- libguile/values.c | 104 ++++++++++++++++++++++-------------------- libguile/values.h | 27 +++++++++-- libguile/vm-engine.c | 22 ++++----- 12 files changed, 123 insertions(+), 98 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index f80a9f3f5..1403a14f5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -224,13 +224,12 @@ static void error_unrecognized_keyword (SCM proc, SCM kw) static SCM truncate_values (SCM x) { - if (SCM_LIKELY (!SCM_VALUESP (x))) + if (SCM_LIKELY (!scm_is_values (x))) return x; else { - SCM l = scm_struct_ref (x, SCM_INUM0); - if (SCM_LIKELY (scm_is_pair (l))) - return scm_car (l); + if (SCM_LIKELY (scm_i_nvalues (x) > 0)) + return scm_i_value_ref (x, 0); else { scm_ithrow (scm_from_latin1_symbol ("vm-run"), @@ -368,8 +367,13 @@ eval (SCM x, SCM env) /* `proc' is the consumer. */ proc = EVAL1 (CDR (mx), env); v = scm_call_0 (producer); - if (SCM_VALUESP (v)) - args = scm_struct_ref (v, SCM_INUM0); + if (scm_is_values (v)) + { + size_t i = scm_i_nvalues (v); + args = SCM_EOL; + while (i--) + args = scm_cons (scm_i_value_ref (v, i), args); + } else args = scm_list_1 (v); goto apply_proc; diff --git a/libguile/i18n.c b/libguile/i18n.c index a8a14a710..a01ea8128 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1360,7 +1360,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", else result = scm_from_long (c_result); - return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); + return scm_values_2 (result, scm_from_long (c_endptr - c_str)); } #undef FUNC_NAME @@ -1404,7 +1404,7 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", else result = scm_from_double (c_result); - return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); + return scm_values_2 (result, scm_from_long (c_endptr - c_str)); } #undef FUNC_NAME diff --git a/libguile/numbers.c b/libguile/numbers.c index b067002bf..a14597b7c 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1500,7 +1500,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0, SCM q, r; scm_floor_divide(x, y, &q, &r); - return scm_values (scm_list_2 (q, r)); + return scm_values_2 (q, r); } #undef FUNC_NAME @@ -2038,7 +2038,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0, SCM q, r; scm_ceiling_divide(x, y, &q, &r); - return scm_values (scm_list_2 (q, r)); + return scm_values_2 (q, r); } #undef FUNC_NAME @@ -2529,7 +2529,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0, SCM q, r; scm_truncate_divide(x, y, &q, &r); - return scm_values (scm_list_2 (q, r)); + return scm_values_2 (q, r); } #undef FUNC_NAME @@ -3140,7 +3140,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0, SCM q, r; scm_centered_divide(x, y, &q, &r); - return scm_values (scm_list_2 (q, r)); + return scm_values_2 (q, r); } #undef FUNC_NAME @@ -3815,7 +3815,7 @@ SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0, SCM q, r; scm_round_divide(x, y, &q, &r); - return scm_values (scm_list_2 (q, r)); + return scm_values_2 (q, r); } #undef FUNC_NAME @@ -10094,7 +10094,7 @@ SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0, SCM s, r; scm_exact_integer_sqrt (k, &s, &r); - return scm_values (scm_list_2 (s, r)); + return scm_values_2 (s, r); } #undef FUNC_NAME diff --git a/libguile/posix.c b/libguile/posix.c index 233d84723..497896b0e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -599,10 +599,10 @@ SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0, if (getrlimit (iresource, &lim) != 0) scm_syserror (FUNC_NAME); - return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F - : scm_from_long (lim.rlim_cur), - (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F - : scm_from_long (lim.rlim_max))); + return scm_values_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_cur), + (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_max)); } #undef FUNC_NAME @@ -1435,9 +1435,7 @@ scm_open_process (SCM mode, SCM prog, SCM args) SCM_FPORT_OPTION_NOT_SEEKABLE); } - return scm_values (scm_list_3 (read_port, - write_port, - scm_from_int (pid))); + return scm_values_3 (read_port, write_port, scm_from_int (pid)); } #undef FUNC_NAME diff --git a/libguile/print.c b/libguile/print.c index a68b99643..86f2b81fb 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -60,6 +60,7 @@ #include "struct.h" #include "symbols.h" #include "syntax.h" +#include "values.h" #include "variable.h" #include "vectors.h" #include "vm.h" @@ -703,6 +704,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_variable: scm_i_variable_print (exp, port, pstate); break; + case scm_tc7_values: + scm_puts ("#", port); + break; case scm_tc7_program: scm_i_program_print (exp, port, pstate); break; diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 05f9278bf..b923cf2a1 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -763,7 +763,7 @@ make_bytevector_output_port (void) SCM_NEWSMOB (proc, bytevector_output_port_procedure, buf); - return scm_values (scm_list_2 (port, proc)); + return scm_values_2 (port, proc); } /* Write octets from WRITE_BUF to the backing store. */ diff --git a/libguile/scm.h b/libguile/scm.h index 4d513ff4e..9dee8fc95 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -489,7 +489,7 @@ typedef uintptr_t scm_t_bits; #define scm_tc7_keyword 0x35 #define scm_tc7_atomic_box 0x37 #define scm_tc7_syntax 0x3d -#define scm_tc7_unused_3f 0x3f +#define scm_tc7_values 0x3f #define scm_tc7_program 0x45 #define scm_tc7_vm_cont 0x47 #define scm_tc7_bytevector 0x4d diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index e713fe8fa..0c7944847 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -818,12 +818,7 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, dropped_tail = new_tail; } } - /* re-use the initial conses for the values list */ - SCM_SETCAR(kept, SCM_CDR(kept)); - SCM_SETCDR(kept, dropped); - SCM_SETCAR(dropped, SCM_CDR(dropped)); - SCM_SETCDR(dropped, SCM_EOL); - return scm_values(kept); + return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped)); } #undef FUNC_NAME @@ -877,7 +872,7 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0, *tp = SCM_EOL; *fp = SCM_EOL; - return scm_values (scm_list_2 (tlst, flst)); + return scm_values_2 (tlst, flst); } #undef FUNC_NAME diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 950928f27..b266400ea 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -1900,7 +1900,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 charsets_intersection (p, r); rest = SCM_CDR (rest); } - return scm_values (scm_list_2 (res1, res2)); + return scm_values_2 (res1, res2); } #undef FUNC_NAME @@ -1988,7 +1988,7 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection_x, scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest))); cs1 = diff; cs2 = intersect; - return scm_values (scm_list_2 (cs1, cs2)); + return scm_values_2 (cs1, cs2); } #undef FUNC_NAME diff --git a/libguile/values.c b/libguile/values.c index 60c4b1af1..4fd9b5451 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -21,59 +21,37 @@ # include #endif -#include "eval.h" #include "feature.h" #include "gc.h" #include "gsubr.h" #include "list.h" #include "numbers.h" #include "pairs.h" -#include "ports.h" -#include "strings.h" -#include "struct.h" #include "values.h" -SCM scm_values_vtable; - /* OBJ must be a values object containing exactly two values. scm_i_extract_values_2 puts those two values into *p1 and *p2. */ void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2) { - SCM values; - - SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1, + SCM_ASSERT_TYPE (scm_is_values (obj), obj, SCM_ARG1, "scm_i_extract_values_2", "values"); - values = scm_struct_ref (obj, SCM_INUM0); - if (scm_ilength (values) != 2) + if (scm_i_nvalues (obj) != 2) scm_wrong_type_arg_msg ("scm_i_extract_values_2", SCM_ARG1, obj, "a values object containing exactly two values"); - *p1 = SCM_CAR (values); - *p2 = SCM_CADR (values); -} -static SCM -print_values (SCM obj, SCM pwps) -{ - SCM values = scm_struct_ref (obj, SCM_INUM0); - SCM port = SCM_PORT_WITH_PS_PORT (pwps); - scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); - - scm_puts ("#", port); - - return SCM_UNSPECIFIED; + *p1 = scm_i_value_ref (obj, 0); + *p2 = scm_i_value_ref (obj, 1); } size_t scm_c_nvalues (SCM obj) { - if (SCM_LIKELY (SCM_VALUESP (obj))) - return scm_ilength (scm_struct_ref (obj, SCM_INUM0)); + if (SCM_LIKELY (scm_is_values (obj))) + return scm_i_nvalues (obj); else return 1; } @@ -81,18 +59,8 @@ scm_c_nvalues (SCM obj) SCM scm_c_value_ref (SCM obj, size_t idx) { - if (SCM_LIKELY (SCM_VALUESP (obj))) - { - SCM values = scm_struct_ref (obj, SCM_INUM0); - size_t i = idx; - while (SCM_LIKELY (scm_is_pair (values))) - { - if (i == 0) - return SCM_CAR (values); - values = SCM_CDR (values); - i--; - } - } + if (SCM_LIKELY (scm_is_values (obj) && idx < scm_i_nvalues (obj))) + return scm_i_value_ref (obj, idx); else if (idx == 0) return obj; @@ -119,7 +87,17 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, if (n == 1) result = SCM_CAR (args); else - result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args)); + { + size_t i; + + if ((size_t) n > (size_t) (UINTPTR_MAX >> 8)) + scm_error (scm_out_of_range_key, FUNC_NAME, "Too many values", + SCM_EOL, SCM_EOL); + + result = scm_words ((((scm_t_bits) n) << 8) | scm_tc7_values, n + 1); + for (i = 0; i < n; i++, args = SCM_CDR (args)) + SCM_SET_CELL_OBJECT (result, i + 1, SCM_CAR (args)); + } return result; } @@ -128,24 +106,52 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1, SCM scm_c_values (SCM *base, size_t nvalues) { - SCM ret, *walk; + SCM ret; + size_t i; if (nvalues == 1) return *base; - for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--) - ret = scm_cons (*walk, ret); + if ((uintptr_t) nvalues > (UINTPTR_MAX >> 8)) + scm_error (scm_out_of_range_key, "scm_c_values", "Too many values", + SCM_EOL, SCM_EOL); - return scm_values (ret); + ret = scm_words ((((scm_t_bits) nvalues) << 8) | scm_tc7_values, nvalues + 1); + + for (i = 0; i < nvalues; i++) + SCM_SET_CELL_OBJECT (ret, i + 1, base[i]); + + return ret; +} + +SCM +scm_values_2 (SCM a, SCM b) +{ + SCM ret; + + ret = scm_words ((2 << 8) | scm_tc7_values, 3); + SCM_SET_CELL_OBJECT_1 (ret, a); + SCM_SET_CELL_OBJECT_2 (ret, b); + + return ret; +} + +SCM +scm_values_3 (SCM a, SCM b, SCM c) +{ + SCM ret; + + ret = scm_words ((3 << 8) | scm_tc7_values, 4); + SCM_SET_CELL_OBJECT_1 (ret, a); + SCM_SET_CELL_OBJECT_2 (ret, b); + SCM_SET_CELL_OBJECT_3 (ret, c); + + return ret; } void scm_init_values (void) { - SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values); - - scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pw"), print); - scm_add_feature ("values"); #include "values.x" diff --git a/libguile/values.h b/libguile/values.h index 6312aa3ab..e5f004332 100644 --- a/libguile/values.h +++ b/libguile/values.h @@ -22,17 +22,36 @@ -#include "libguile/struct.h" +#include "libguile/gc.h" -SCM_API SCM scm_values_vtable; +static inline int +scm_is_values (SCM x) +{ + return SCM_HAS_TYP7 (x, scm_tc7_values); +} -#define SCM_VALUESP(x) (SCM_STRUCTP (x)\ - && scm_is_eq (scm_struct_vtable (x), scm_values_vtable)) +#ifdef BUILDING_LIBGUILE +static inline size_t +scm_i_nvalues (SCM x) +{ + return SCM_CELL_WORD_0 (x) >> 8; +} + +static inline SCM +scm_i_value_ref (SCM x, size_t n) +{ + return SCM_CELL_OBJECT (x, n+1); +} +#endif + +#define SCM_VALUESP(x) (scm_is_values (x)) SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2); SCM_API SCM scm_values (SCM args); SCM_API SCM scm_c_values (SCM *base, size_t n); +SCM_API SCM scm_values_2 (SCM a, SCM b); +SCM_API SCM scm_values_3 (SCM a, SCM b, SCM c); SCM_API size_t scm_c_nvalues (SCM obj); SCM_API SCM scm_c_value_ref (SCM obj, size_t idx); SCM_INTERNAL void scm_init_values (void); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 56c5ec177..ac47da67b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -342,11 +342,11 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int resume) else { uint32_t n; - ret = SCM_EOL; SYNC_IP (); - for (n = nvals; n > 0; n--) - ret = scm_inline_cons (thread, FP_REF (4 + n - 1), ret); - ret = scm_values (ret); + VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ()); + ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1); + for (n = 0; n < nvals; n++) + SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (4 + n - 1)); } VP->ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); @@ -608,16 +608,12 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int resume) ret = scm_apply_subr (sp, FRAME_LOCALS_COUNT ()); CACHE_SP (); - if (SCM_UNLIKELY (SCM_VALUESP (ret))) + if (SCM_UNLIKELY (scm_is_values (ret))) { - SCM vals = scm_struct_ref (ret, SCM_INUM0); - long len = scm_ilength (vals); - ALLOC_FRAME (1 + len); - while (len--) - { - SP_SET (len, SCM_CAR (vals)); - vals = SCM_CDR (vals); - } + size_t n, nvals = scm_i_nvalues (ret); + ALLOC_FRAME (1 + nvals); + for (n = 0; n < nvals; n++) + FP_SET (n + 1, scm_i_value_ref (ret, n)); NEXT (1); } else