[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-6-ga752
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-6-ga752c0d |
|
Date: |
Sat, 23 Jan 2010 15:44:23 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a752c0dc2798fb1af93d56f6f73bea964df12633
The branch, master has been updated
via a752c0dc2798fb1af93d56f6f73bea964df12633 (commit)
via 696ac4dfcc4e48c95df8935fc3640377c5df18fb (commit)
via 01e74380f6170b5cb1105e5df9a368ab257420ef (commit)
via aa42c03669df8acf997d3108f08ce94d5d7611c2 (commit)
via 0e64cbea3d22411564af302a63b670fe0617ccf3 (commit)
from 73d1aaafb226b5e386b6b2eeacc40b836ff85940 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a752c0dc2798fb1af93d56f6f73bea964df12633
Author: Ludovic Courtès <address@hidden>
Date: Sat Jan 23 16:43:50 2010 +0100
Add `struct-ref' and `struct-set' VM opcodes.
* libguile/vm-i-scheme.c (make_struct): Optimize the
`SCM_VTABLE_FLAG_SIMPLE' case.
(struct_ref, struct_set): New opcodes.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
`struct-ref' and `struct-set!'.
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Likewise.
(*effect-free-primitives*): Add `struct-ref'.
commit 696ac4dfcc4e48c95df8935fc3640377c5df18fb
Author: Ludovic Courtès <address@hidden>
Date: Sat Jan 23 16:41:28 2010 +0100
Slightly improve comments and style in `struct.c'.
* libguile/struct.c (scm_i_struct_inherit_vtable_magic): Comment.
Punctuate comments within the body, have them follow GCS.
(scm_make_vtable_vtable): Clarify comments.
commit 01e74380f6170b5cb1105e5df9a368ab257420ef
Author: Ludovic Courtès <address@hidden>
Date: Sat Jan 23 16:39:14 2010 +0100
Clarify GC-registered displacements for structs.
* libguile/struct.c (scm_init_struct): Remove unneeded
`GC_REGISTER_DISPLACEMENT ()' call. Comment the remaining one.
commit aa42c03669df8acf997d3108f08ce94d5d7611c2
Author: Ludovic Courtès <address@hidden>
Date: Sat Jan 23 16:21:13 2010 +0100
Optimize struct initialization and accessors for the common case.
* libguile/struct.c (set_vtable_layout_flags): New function.
(scm_i_struct_inherit_vtable_magic): Use it.
(scm_struct_init): Optimize the case where HANDLE's vtable has the
`SCM_VTABLE_FLAG_SIMPLE' flag.
(scm_struct_ref): Likewise.
(scm_struct_ref): Likewise, when `SCM_VTABLE_FLAG_SIMPLE_RW' is also set.
* libguile/struct.h (SCM_VTABLE_BASE_LAYOUT): Update comment for the
next-to-last hidden field.
(scm_vtable_index_reserved_6): Rename to...
(scm_vtable_index_size): ... this.
(SCM_VTABLE_FLAG_RESERVED_0): Rename to...
(SCM_VTABLE_FLAG_SIMPLE): ... this.
(SCM_VTABLE_FLAG_RESERVED_1): Rename to...
(SCM_VTABLE_FLAG_SIMPLE_RW): ... this.
* test-suite/tests/structs.test ("low-level struct
procedures")["struct-ref", "struct-set!", "struct-ref out-of-range",
"struct-set! out-of-range"]: New tests.
commit 0e64cbea3d22411564af302a63b670fe0617ccf3
Author: Ludovic Courtès <address@hidden>
Date: Fri Jan 22 16:55:24 2010 +0100
Install `standard-library.info'.
* doc/ref/Makefile.am (BUILT_SOURCES): Move `standard-library.texi'
to...
(nodist_info_TEXINFOS): ... here. New variable.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/Makefile.am | 3 +-
libguile/struct.c | 400 ++++++++++++++++++------------
libguile/struct.h | 12 +-
libguile/vm-i-scheme.c | 76 ++++++-
module/language/tree-il/compile-glil.scm | 2 +
module/language/tree-il/primitives.scm | 4 +-
test-suite/tests/structs.test | 37 ++-
7 files changed, 362 insertions(+), 172 deletions(-)
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index a587343..b7ea8f0 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -21,9 +21,10 @@
AUTOMAKE_OPTIONS = gnu
-BUILT_SOURCES = lib-version.texi standard-library.texi
+BUILT_SOURCES = lib-version.texi
info_TEXINFOS = guile.texi
+nodist_info_TEXINFOS = standard-library.texi
guile_TEXINFOS = preface.texi \
intro.texi \
diff --git a/libguile/struct.c b/libguile/struct.c
index 321f2f1..6340a70 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009, 2010 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
@@ -22,6 +22,7 @@
#endif
#include <alloca.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
@@ -151,7 +152,64 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout",
1, 0, 0,
#undef FUNC_NAME
+/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
+ or only "pw" fields) and update its flags accordingly. */
+static void
+set_vtable_layout_flags (SCM vtable)
+{
+ size_t len, field;
+ SCM layout;
+ const char *c_layout;
+ scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE;
+
+ layout = SCM_VTABLE_LAYOUT (vtable);
+ c_layout = scm_i_symbol_chars (layout);
+ len = scm_i_symbol_length (layout);
+
+ assert (len % 2 == 0);
+
+ /* Update FLAGS according to LAYOUT. */
+ for (field = 0;
+ field < len && flags & SCM_VTABLE_FLAG_SIMPLE;
+ field += 2)
+ {
+ if (c_layout[field] != 'p')
+ flags = 0;
+ else
+ switch (c_layout[field + 1])
+ {
+ case 'w':
+ case 'W':
+ if (!(flags & SCM_VTABLE_FLAG_SIMPLE_RW) && field > 0)
+ /* There's a mixture of `w' and `r' flags. */
+ flags = 0;
+ else
+ flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
+ break;
+
+ case 'r':
+ case 'R':
+ if (flags & SCM_VTABLE_FLAG_SIMPLE_RW)
+ /* There's a mixture of `w' and `r' flags. */
+ flags = 0;
+ break;
+
+ default:
+ flags = 0;
+ }
+ }
+ if (flags & SCM_VTABLE_FLAG_SIMPLE)
+ {
+ /* VTABLE is simple so update its flags and record the size of its
+ instances. */
+ SCM_SET_VTABLE_FLAGS (vtable, flags);
+ SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2);
+ }
+}
+
+/* Have OBJ, a newly created vtable, inherit flags from VTABLE. VTABLE is a
+ vtable-vtable and OBJ is an instance of VTABLE. */
void
scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
#define FUNC_NAME "%inherit-vtable-magic"
@@ -162,17 +220,18 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
Both of these questions also imply a certain layout of the structure. So
instead of checking the layout at runtime, what we do is pre-verify the
layout -- so that at runtime we can just check the applicable flag and
- dispatch directly to the Scheme procedure in slot 0.
- */
+ dispatch directly to the Scheme procedure in slot 0. */
SCM olayout;
- /* verify that obj is a valid vtable */
+ /* Verify that OBJ is a valid vtable. */
if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
- /* if obj's vtable is compatible with the required vtable (class) layout, it
- is a metaclass */
+ set_vtable_layout_flags (obj);
+
+ /* If OBJ's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass. */
olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
scm_string_length (olayout)))
@@ -183,8 +242,8 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
scm_string_length
(required_vtable_fields))))
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
- /* finally if obj is an applicable class, verify that its vtable is
- compatible with the required applicable layout */
+ /* Finally, if OBJ is an applicable class, verify that its vtable is
+ compatible with the required applicable layout. */
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
{
if (scm_is_false (scm_string_eq (olayout,
required_applicable_with_setter_fields,
@@ -215,60 +274,74 @@ static void
scm_struct_init (SCM handle, SCM layout, size_t n_tail,
size_t n_inits, scm_t_bits *inits)
{
- scm_t_wchar prot = 0;
- int n_fields = scm_i_symbol_length (layout) / 2;
- int tailp = 0;
- int i;
- size_t inits_idx = 0;
- scm_t_bits *mem = SCM_STRUCT_DATA (handle);
-
- i = -2;
- while (n_fields)
+ SCM vtable;
+ scm_t_bits *mem;
+
+ vtable = SCM_STRUCT_VTABLE (handle);
+ mem = SCM_STRUCT_DATA (handle);
+
+ if (SCM_UNPACK (vtable) != 0
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && n_tail == 0
+ && n_inits == SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))
+ /* The fast path: HANDLE has N_INITS "p" fields. */
+ memcpy (mem, inits, n_inits * sizeof (SCM));
+ else
{
- if (!tailp)
- {
- i += 2;
- prot = scm_i_symbol_ref (layout, i+1);
- if (SCM_LAYOUT_TAILP (prot))
- {
- tailp = 1;
- prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = (scm_t_bits)n_tail;
- n_fields += n_tail - 1;
- if (n_fields == 0)
- break;
- }
- }
- switch (scm_i_symbol_ref (layout, i))
+ scm_t_wchar prot = 0;
+ int n_fields = scm_i_symbol_length (layout) / 2;
+ int tailp = 0;
+ int i;
+ size_t inits_idx = 0;
+
+ i = -2;
+ while (n_fields)
{
- case 'u':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = 0;
- else
+ if (!tailp)
{
- *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
- inits_idx++;
+ i += 2;
+ prot = scm_i_symbol_ref (layout, i+1);
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
+ if (n_fields == 0)
+ break;
+ }
}
- break;
-
- case 'p':
- if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
- *mem = SCM_UNPACK (SCM_BOOL_F);
- else
+ switch (scm_i_symbol_ref (layout, i))
{
- *mem = inits[inits_idx];
- inits_idx++;
+ case 'u':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = 0;
+ else
+ {
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
+ }
+ break;
+
+ case 'p':
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
+ *mem = SCM_UNPACK (SCM_BOOL_F);
+ else
+ {
+ *mem = inits[inits_idx];
+ inits_idx++;
+ }
+
+ break;
+
+ case 's':
+ *mem = SCM_UNPACK (handle);
+ break;
}
-
- break;
- case 's':
- *mem = SCM_UNPACK (handle);
- break;
+ n_fields--;
+ mem++;
}
-
- n_fields--;
- mem++;
}
}
@@ -504,11 +577,8 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
"@end lisp")
#define FUNC_NAME s_scm_make_vtable_vtable
{
- SCM fields;
- SCM layout;
- size_t basic_size;
- size_t n_tail, i, n_init;
- SCM obj;
+ SCM fields, layout, obj;
+ size_t basic_size, n_tail, i, n_init;
long ilen;
scm_t_bits *v;
@@ -539,11 +609,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
SCM_CRITICAL_SECTION_START;
obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
- /* magic magic magic */
- SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
+
scm_struct_init (obj, layout, n_tail, n_init, v);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+
return obj;
}
#undef FUNC_NAME
@@ -627,71 +699,81 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
"integer value small enough to fit in one machine word.")
#define FUNC_NAME s_scm_struct_ref
{
- SCM answer = SCM_UNDEFINED;
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable, answer = SCM_UNDEFINED;
+ scm_t_bits *data;
size_t p;
- scm_t_bits n_fields;
- scm_t_wchar field_type = 0;
-
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
-
- SCM_ASSERT_RANGE(1, pos, p < n_fields);
-
- if (p * 2 < layout_len)
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
{
- scm_t_wchar ref;
- field_type = scm_i_symbol_ref (layout, p * 2);
- ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
- {
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
- }
+ /* The fast path: HANDLE is a struct with only "p" fields. */
+ answer = SCM_PACK (data[p]);
}
- else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
- field_type = scm_i_symbol_ref(layout, layout_len - 2);
else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
{
- case 'u':
- answer = scm_from_ulong (data[p]);
- break;
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
+
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ scm_t_wchar ref;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ ref = scm_i_symbol_ref (layout, p * 2 + 1);
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ }
+ }
+ else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
+ field_type = scm_i_symbol_ref(layout, layout_len - 2);
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+
+ switch (field_type)
+ {
+ case 'u':
+ answer = scm_from_ulong (data[p]);
+ break;
#if 0
- case 'i':
- answer = scm_from_long (data[p]);
- break;
+ case 'i':
+ answer = scm_from_long (data[p]);
+ break;
- case 'd':
- answer = scm_make_real (*((double *)&(data[p])));
- break;
+ case 'd':
+ answer = scm_make_real (*((double *)&(data[p])));
+ break;
#endif
- case 's':
- case 'p':
- answer = SCM_PACK (data[p]);
- break;
+ case 's':
+ case 'p':
+ answer = SCM_PACK (data[p]);
+ break;
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return answer;
@@ -706,65 +788,76 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
"to.")
#define FUNC_NAME s_scm_struct_set_x
{
- scm_t_bits * data;
- SCM layout;
- size_t layout_len;
+ SCM vtable;
+ scm_t_bits *data;
size_t p;
- int n_fields;
- scm_t_wchar field_type = 0;
SCM_VALIDATE_STRUCT (1, handle);
- layout = SCM_STRUCT_LAYOUT (handle);
+ vtable = SCM_STRUCT_VTABLE (handle);
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)
+ && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
+ /* The fast path: HANDLE is a struct with only "p" fields. */
+ data[p] = SCM_UNPACK (val);
+ else
+ {
+ SCM layout;
+ size_t layout_len, n_fields;
+ scm_t_wchar field_type = 0;
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ layout_len = scm_i_symbol_length (layout);
+ n_fields = layout_len / 2;
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
- if (p * 2 < layout_len)
- {
- char set_x;
- field_type = scm_i_symbol_ref (layout, p * 2);
- set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w' && set_x != 'h')
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ char set_x;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ set_x = scm_i_symbol_ref (layout, p * 2 + 1);
+ if (set_x != 'w' && set_x != 'h')
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+ }
+ else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
+ field_type = scm_i_symbol_ref (layout, layout_len - 2);
+ else
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
- field_type = scm_i_symbol_ref (layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- data[p] = SCM_NUM2ULONG (3, val);
- break;
+
+ switch (field_type)
+ {
+ case 'u':
+ data[p] = SCM_NUM2ULONG (3, val);
+ break;
#if 0
- case 'i':
- data[p] = SCM_NUM2LONG (3, val);
- break;
+ case 'i':
+ data[p] = SCM_NUM2LONG (3, val);
+ break;
- case 'd':
- *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
- break;
+ case 'd':
+ *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
+ break;
#endif
- case 'p':
- data[p] = SCM_UNPACK (val);
- break;
+ case 'p':
+ data[p] = SCM_UNPACK (val);
+ break;
- case 's':
- SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
+ case 's':
+ SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
}
return val;
@@ -899,9 +992,10 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
void
scm_init_struct ()
{
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data
pointer */
- GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
- + scm_tc3_struct); /* for the vtable data pointer
*/
+ /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
+ scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
+ default. */
+ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct);
scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
diff --git a/libguile/struct.h b/libguile/struct.h
index 537ef90..012d9b6 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010 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
@@ -41,12 +41,12 @@
/* All vtables have the following fields. */
#define SCM_VTABLE_BASE_LAYOUT \
"pr" /* layout */ \
- "uh" /* flags */ \
+ "uh" /* flags */ \
"sr" /* self */ \
"uh" /* finalizer */ \
"pw" /* printer */ \
"ph" /* name (hidden from make-struct for back-compat reasons) */ \
- "uh" /* reserved */ \
+ "uh" /* size */ \
"uh" /* reserved */
#define scm_vtable_index_layout 0 /* A symbol describing the
physical arrangement of this type. */
@@ -55,7 +55,7 @@
#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of
this struct type. */
#define scm_vtable_index_instance_printer 4 /* A printer for this struct
type. */
#define scm_vtable_index_name 5 /* Name of this vtable. */
-#define scm_vtable_index_reserved_6 6
+#define scm_vtable_index_size 6 /* Number of fields, for simple
structs. */
#define scm_vtable_index_reserved_7 7
#define scm_vtable_offset_user 8 /* Where do user fields start in
the vtable? */
@@ -79,8 +79,8 @@
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are
applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable
are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are
applicable-with-setters? */
-#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
-#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
+#define SCM_VTABLE_FLAG_SIMPLE (1L << 5) /* instances of this vtable have only
"pr" fields */
+#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 6) /* instances of this vtable have
only "pw" fields */
#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 02dbd5f..e5e73dd 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -645,12 +645,32 @@ VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct",
2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
- int n_args = ((h << 8U) + l);
+ scm_t_bits n_args = ((h << 8U) + l);
SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
const SCM *inits = sp - n_args + 3;
sp -= n_args - 1;
+ if (SCM_LIKELY (SCM_STRUCTP (vtable)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (n_tail)))
+ {
+ scm_t_bits n_inits, len;
+
+ n_inits = SCM_I_INUM (n_tail) + n_args - 2;
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (n_inits == len))
+ {
+ SCM obj;
+
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits);
+ memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM));
+
+ RETURN (obj);
+ }
+ }
+
SYNC_REGISTER ();
RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
n_args - 2, (scm_t_bits *) inits));
@@ -672,6 +692,60 @@ VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3,
-1, 1)
NEXT;
}
+VM_DEFINE_FUNCTION (178, struct_ref, "struct-ref", 2)
+{
+ ARGS2 (obj, pos);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ RETURN (SCM_PACK (data[index]));
+ }
+ }
+
+ RETURN (scm_struct_ref (obj, pos));
+}
+
+VM_DEFINE_FUNCTION (179, struct_set, "struct-set", 3)
+{
+ ARGS3 (obj, pos, val);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE_RW)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ data[index] = SCM_UNPACK (val);
+ RETURN (val);
+ }
+ }
+
+ RETURN (scm_struct_set_x (obj, pos, val));
+}
+
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index bfa57a1..8a72e93 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -118,6 +118,8 @@
((variable-set . 2) . variable-set)
((struct? . 1) . struct?)
((struct-vtable . 1) . struct-vtable)
+ ((struct-ref . 2) . struct-ref)
+ ((struct-set! . 3) . struct-set)
(make-struct . make-struct)
;; hack for javascript
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 848aa8d..83bfc0e 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -58,7 +58,7 @@
variable-ref variable-set!
;; args of variable-set are switched; it needs special help
- struct? struct-vtable make-struct
+ struct? struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
@@ -112,7 +112,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref
- struct? struct-vtable make-struct
+ struct? struct-vtable make-struct struct-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 2c2ca0c..55e0807 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -1,7 +1,7 @@
-;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
-;;;; Ludovic Courtès <address@hidden>, 2006-06-12.
+;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <address@hidden>, 2006-06-12.
;;;;
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010 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
@@ -80,9 +80,33 @@
(pass-if "struct-set!"
(let ((ball (make-ball green "Bob")))
(set-owner! ball "Bill")
- (string=? (owner ball) "Bill"))))
+ (string=? (owner ball) "Bill")))
+ (pass-if "struct-ref"
+ (let ((ball (make-ball red "Alice")))
+ (equal? (struct-ref ball 0) "Alice")))
+ (pass-if "struct-set!"
+ (let* ((v (make-vtable "pw"))
+ (s (make-struct v 0))
+ (r (struct-set! s 0 'a)))
+ (eq? r
+ (struct-ref s 0)
+ 'a)))
+
+ (pass-if-exception "struct-ref out-of-range"
+ exception:out-of-range
+ (let* ((v (make-vtable "prpr"))
+ (s (make-struct v 0 'a 'b)))
+ (struct-ref s 2)))
+
+ (pass-if-exception "struct-set! out-of-range"
+ exception:out-of-range
+ (let* ((v (make-vtable "pwpw"))
+ (s (make-struct v 0 'a 'b)))
+ (struct-set! s 2 'c))))
+
+
(with-test-prefix "equal?"
(pass-if "simple structs"
@@ -153,8 +177,3 @@
(lambda (port)
(display struct port)))))
(equal? str "hello")))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-7-6-ga752c0d,
Ludovic Courtès <=