[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 13/26: Give multiple-values objects a tc7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 13/26: Give multiple-values objects a tc7 |
|
Date: |
Tue, 26 Jun 2018 11:26:13 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 4a2d78b4d463cd29226f3eee776dcad9f64e6152
Author: Andy Wingo <address@hidden>
Date: Mon Jun 25 15:49:34 2018 +0200
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 | 31 ++++++++++++---
libguile/vm-engine.c | 22 +++++------
12 files changed, 125 insertions(+), 100 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index f80a9f3..1403a14 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 a8a14a7..a01ea81 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 b067002..a14597b 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 233d847..497896b 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 a68b996..86f2b81 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 ("#<values (", port);
+ print_vector_or_weak_vector (exp, scm_i_nvalues (exp),
+ scm_c_value_ref, port, pstate);
+ 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 05f9278..b923cf2 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 4d513ff..9dee8fc 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 e713fe8..0c79448 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 950928f..b266400 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 60c4b1a..4fd9b54 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -21,59 +21,37 @@
# include <config.h>
#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 ("#<values ", port);
- scm_iprin1 (values, port, ps);
- 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);
+
+ 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 scm_values (ret);
+ return ret;
}
-void
-scm_init_values (void)
+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 print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
+ SCM ret;
- scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pw"), print);
+ 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_add_feature ("values");
#include "values.x"
diff --git a/libguile/values.h b/libguile/values.h
index 6312aa3..e5f0043 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -22,17 +22,36 @@
-#include "libguile/struct.h"
-
-SCM_API SCM scm_values_vtable;
-
-#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
- && scm_is_eq (scm_struct_vtable (x),
scm_values_vtable))
+#include "libguile/gc.h"
+
+static inline int
+scm_is_values (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_values);
+}
+
+#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 56c5ec1..ac47da6 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
- [Guile-commits] 18/26: Refactor continuation capture in VM, (continued)
- [Guile-commits] 18/26: Refactor continuation capture in VM, Andy Wingo, 2018/06/26
- [Guile-commits] 17/26: Foreign-call intrinsic boxes errno, Andy Wingo, 2018/06/26
- [Guile-commits] 25/26: Optimize abort-to-prompt to avoid alloca, Andy Wingo, 2018/06/26
- [Guile-commits] 15/26: Most header files use forward decl for union scm_vm_stack_element, Andy Wingo, 2018/06/26
- [Guile-commits] 14/26: Add intrinsic for foreign-call, Andy Wingo, 2018/06/26
- [Guile-commits] 11/26: Move VM keyword argument parsing to happen via an intrinsic, Andy Wingo, 2018/06/26
- [Guile-commits] 22/26: Add rest-arg-length intrinsic., Andy Wingo, 2018/06/26
- [Guile-commits] 16/26: Reinstating undelimited continuations uses intrinsic, Andy Wingo, 2018/06/26
- [Guile-commits] 24/26: Refactors to abort-to-prompt implementation, Andy Wingo, 2018/06/26
- [Guile-commits] 12/26: Add push-interrupt-frame VM intrinsic, Andy Wingo, 2018/06/26
- [Guile-commits] 13/26: Give multiple-values objects a tc7,
Andy Wingo <=
- [Guile-commits] 26/26: Allow abort_to_prompt to avoid a longjmp, Andy Wingo, 2018/06/26
- [Guile-commits] 21/26: compose-continuation uses an intrinsic, Andy Wingo, 2018/06/26
- [Guile-commits] 23/26: abort-to-prompt uses an intrinsic, Andy Wingo, 2018/06/26
- [Guile-commits] 19/26: Rename scm_i_thread to scm_thread, Andy Wingo, 2018/06/26
- [Guile-commits] 02/26: Replace uses of scm_t_int8, scm_t_uintmax, etc with stdint types, Andy Wingo, 2018/06/26