mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Struct vtables store bitmask of unboxed fields

Browse source 
* libguile/struct.h (scm_vtable_index_unboxed_fields): Allocate slot for
  bitmask of which fields are unboxed.
  (SCM_VTABLE_FLAG_SIMPLE, SCM_VTABLE_FLAG_SIMPLE_RW): Remove flags.
  Renumber other flags.
  (SCM_VTABLE_SIZE, SCM_STRUCT_SIZE): New helpers; long overdue.
  (SCM_VTABLE_UNBOXED_FIELDS, SCM_VTABLE_FIELD_IS_UNBOXED):
  (SCM_STRUCT_FIELD_IS_UNBOXED): New macros.
* libguile/struct.c (set_vtable_access_fields): Rename from
  set_vtable_layout_flags, and initialize the unboxed flags bitmask
  instead of computing vtable flags.
  (scm_struct_init, scm_c_make_structv, scm_allocate_struct): Simplify.
  (scm_i_make_vtable_vtable): Adapt.
  (scm_i_struct_equalp, scm_struct_ref, scm_struct_set_x)
  (scm_struct_ref_unboxed, scm_struct_set_x_unboxed): Simplify.
* libguile/vm-engine.c (VM_VALIDATE_BOXED_STRUCT_FIELD):
  (VM_VALIDATE_UNBOXED_STRUCT_FIELD): Adapt definitions.
  (struct-ref, struct-set!, struct-ref/immediate)
  (struct-set!/immediate): Simplify definitions.
* libguile/hash.c (scm_i_struct_hash): Simplify.
* libguile/goops.c (scm_sys_clear_fields_x): Simplify.
* libguile/foreign-object.c (scm_make_foreign_object_n):
  (scm_foreign_object_unsigned_ref, scm_foreign_object_unsigned_set_x):
  Simplify.
This commit is contained in:
Andy Wingo 2017-09-26 21:56:31 +02:00
parent f32500acca
commit 214e887dbd
6 changed files with 112 additions and 226 deletions
Download patch file Download diff file Expand all files Collapse all files

31
libguile/foreign-object.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2014 Free Software Foundation, Inc. /* Copyright (C) 2014, 2017 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -104,21 +104,16 @@ scm_make_foreign_object_n (SCM type, size_t n, void *vals[])
#define FUNC_NAME "make-foreign-object" #define FUNC_NAME "make-foreign-object"
{ {
SCM obj; SCM obj;
SCM layout;
size_t i; size_t i;
const char *layout_chars;
SCM_VALIDATE_VTABLE (SCM_ARG1, type); SCM_VALIDATE_VTABLE (SCM_ARG1, type);
layout = SCM_VTABLE_LAYOUT (type); if (SCM_VTABLE_SIZE (type) / 2 < n)
if (scm_i_symbol_length (layout) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n)); scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
layout_chars = scm_i_symbol_chars (layout);
for (i = 0; i < n; i++) for (i = 0; i < n; i++)
if (layout_chars[i * 2] != 'u') if (!SCM_VTABLE_FIELD_IS_UNBOXED (type, i))
scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); scm_wrong_type_arg_msg (FUNC_NAME, 0, type, "foreign object type");
obj = scm_c_make_structv (type, 0, 0, NULL); obj = scm_c_make_structv (type, 0, 0, NULL);
@ -133,16 +128,13 @@ scm_t_bits
scm_foreign_object_unsigned_ref (SCM obj, size_t n) scm_foreign_object_unsigned_ref (SCM obj, size_t n)
#define FUNC_NAME "foreign-object-ref" #define FUNC_NAME "foreign-object-ref"
{ {
SCM layout;
SCM_VALIDATE_STRUCT (SCM_ARG1, obj); SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
layout = SCM_STRUCT_LAYOUT (obj); if (SCM_STRUCT_SIZE (obj) <= n)
if (scm_i_symbol_length (layout) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n)); scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
if (scm_i_symbol_ref (layout, n * 2) != 'u') if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n))
scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field");
return SCM_STRUCT_DATA_REF (obj, n); return SCM_STRUCT_DATA_REF (obj, n);
} }
@ -152,16 +144,13 @@ void
scm_foreign_object_unsigned_set_x (SCM obj, size_t n, scm_t_bits val) scm_foreign_object_unsigned_set_x (SCM obj, size_t n, scm_t_bits val)
#define FUNC_NAME "foreign-object-set!" #define FUNC_NAME "foreign-object-set!"
{ {
SCM layout;
SCM_VALIDATE_STRUCT (SCM_ARG1, obj); SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
layout = SCM_STRUCT_LAYOUT (obj); if (SCM_STRUCT_SIZE (obj) <= n)
if (scm_i_symbol_length (layout) / 2 < n)
scm_out_of_range (FUNC_NAME, scm_from_size_t (n)); scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
if (scm_i_symbol_ref (layout, n * 2) != 'u') if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n))
scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field");
SCM_STRUCT_DATA_SET (obj, n, val); SCM_STRUCT_DATA_SET (obj, n, val);
} }

8
libguile/goops.c
View file

@ -475,17 +475,13 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
#define FUNC_NAME s_scm_sys_clear_fields_x #define FUNC_NAME s_scm_sys_clear_fields_x
{ {
scm_t_signed_bits n, i; scm_t_signed_bits n, i;
SCM vtable, layout;
SCM_VALIDATE_STRUCT (1, obj); SCM_VALIDATE_STRUCT (1, obj);
vtable = SCM_STRUCT_VTABLE (obj); n = SCM_STRUCT_SIZE (obj);
n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
layout = SCM_VTABLE_LAYOUT (vtable);
/* Set all SCM-holding slots to the GOOPS unbound value. */ /* Set all SCM-holding slots to the GOOPS unbound value. */
for (i = 0; i < n; i++) for (i = 0; i < n; i++)
if (scm_i_symbol_ref (layout, i*2) == 'p') if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, i))
SCM_STRUCT_SLOT_SET (obj, i, unbound); SCM_STRUCT_SLOT_SET (obj, i, unbound);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;

33
libguile/hash.c
View file

@ -227,36 +227,21 @@ static unsigned long scm_raw_ihash (SCM obj, size_t depth);
static unsigned long static unsigned long
scm_i_struct_hash (SCM obj, size_t depth) scm_i_struct_hash (SCM obj, size_t depth)
{ {
SCM layout;
scm_t_bits *data;
size_t struct_size, field_num; size_t struct_size, field_num;
unsigned long hash; unsigned long hash;
layout = SCM_STRUCT_LAYOUT (obj); struct_size = SCM_STRUCT_SIZE (obj);
struct_size = scm_i_symbol_length (layout) / 2;
data = SCM_STRUCT_DATA (obj);
hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj))); hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
if (depth > 0) if (depth > 0)
for (field_num = 0; field_num < struct_size; field_num++) {
{ for (field_num = 0; field_num < struct_size; field_num++)
int type; if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, field_num))
type = scm_i_symbol_ref (layout, field_num * 2); hash ^= scm_raw_ihashq (SCM_STRUCT_DATA_REF (obj, field_num));
switch (type) else
{ hash ^= scm_raw_ihash (SCM_STRUCT_SLOT_REF (obj, field_num),
case 'p': depth / 2);
hash ^= scm_raw_ihash (SCM_PACK (data[field_num]), }
depth / 2);
break;
case 'u':
hash ^= scm_raw_ihashq (data[field_num]);
break;
default:
abort ();
}
}
/* FIXME: Tail elements should be taken into account. */
return hash; return hash;
} }

183
libguile/struct.c
View file

@ -120,50 +120,35 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
#undef FUNC_NAME #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 static void
set_vtable_layout_flags (SCM vtable) set_vtable_access_fields (SCM vtable)
{ {
size_t len, field; size_t len, nfields, bitmask_size, field;
SCM layout; SCM layout;
const char *c_layout; const char *c_layout;
scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE; scm_t_uint32 *unboxed_fields;
layout = SCM_VTABLE_LAYOUT (vtable); layout = SCM_VTABLE_LAYOUT (vtable);
c_layout = scm_i_symbol_chars (layout); c_layout = scm_i_symbol_chars (layout);
len = scm_i_symbol_length (layout); len = scm_i_symbol_length (layout);
assert (len % 2 == 0); assert (len % 2 == 0);
nfields = len / 2;
bitmask_size = (nfields + 31U) / 32U;
unboxed_fields = scm_gc_malloc_pointerless (bitmask_size, "unboxed fields");
memset (unboxed_fields, 0, bitmask_size * sizeof(*unboxed_fields));
/* Update FLAGS according to LAYOUT. */ /* Update FLAGS according to LAYOUT. */
for (field = 0; for (field = 0; field < nfields; field++)
field < len && flags & SCM_VTABLE_FLAG_SIMPLE; if (c_layout[field*2] == 'u')
field += 2) unboxed_fields[field/32U] |= 1U << (field%32U);
{
if (c_layout[field] != 'p')
flags = 0;
else
switch (c_layout[field + 1])
{
case 'w':
case 'h':
if (field == 0)
flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
break;
case 'r':
flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
break;
default:
abort ();
}
}
/* Record computed size of vtable's instances. */ /* Record computed size of vtable's instances. */
SCM_SET_VTABLE_FLAGS (vtable, flags); SCM_SET_VTABLE_FLAGS (vtable, 0);
SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2); SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2);
SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_unboxed_fields,
(scm_t_uintptr) unboxed_fields);
} }
static int static int
@ -224,7 +209,7 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
SCM_MISC_ERROR ("invalid layout for new vtable: ~a", SCM_MISC_ERROR ("invalid layout for new vtable: ~a",
scm_list_1 (SCM_VTABLE_LAYOUT (obj))); scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
set_vtable_layout_flags (obj); set_vtable_access_fields (obj);
/* If OBJ's vtable is compatible with the required vtable (class) layout, it /* If OBJ's vtable is compatible with the required vtable (class) layout, it
is a metaclass. */ is a metaclass. */
@ -271,56 +256,27 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
static void static void
scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits) scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits)
{ {
SCM vtable; size_t n, n_fields, inits_idx = 0;
scm_t_bits *mem;
size_t n_fields;
vtable = SCM_STRUCT_VTABLE (handle); n_fields = SCM_STRUCT_SIZE (handle);
n_fields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
mem = SCM_STRUCT_DATA (handle);
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) for (n = 0; n < n_fields; n++)
&& n_inits == n_fields)
/* The fast path: HANDLE has N_INITS "p" fields. */
memcpy (mem, inits, n_inits * sizeof (SCM));
else
{ {
scm_t_wchar prot = 0; if (inits_idx == n_inits || scm_i_symbol_ref (layout, n*2+1) == 'h')
int i; {
size_t inits_idx = 0; if (SCM_STRUCT_FIELD_IS_UNBOXED (handle, n))
SCM_STRUCT_DATA_SET (handle, n, 0);
i = -2; else
while (n_fields) SCM_STRUCT_SLOT_SET (handle, n, SCM_BOOL_F);
{ }
i += 2; else
prot = scm_i_symbol_ref (layout, i+1); {
switch (scm_i_symbol_ref (layout, i)) SCM_STRUCT_DATA_SET (handle, n,
{ SCM_STRUCT_FIELD_IS_UNBOXED (handle, n)
case 'u': ? scm_to_uintptr_t (SCM_PACK (inits[inits_idx]))
if (prot == 'h' || inits_idx == n_inits) : inits[inits_idx]);
*mem = 0; inits_idx++;
else }
{
*mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
inits_idx++;
}
break;
case 'p':
if (prot == 'h' || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
*mem = inits[inits_idx];
inits_idx++;
}
break;
}
n_fields--;
mem++;
}
} }
} }
@ -384,19 +340,17 @@ SCM
scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init) scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
#define FUNC_NAME "make-struct" #define FUNC_NAME "make-struct"
{ {
SCM layout;
size_t basic_size; size_t basic_size;
SCM obj; SCM obj;
SCM_VALIDATE_VTABLE (1, vtable); SCM_VALIDATE_VTABLE (1, vtable);
layout = SCM_VTABLE_LAYOUT (vtable); basic_size = SCM_VTABLE_SIZE (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME); SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME);
obj = scm_i_alloc_struct (SCM_UNPACK (vtable), basic_size); obj = scm_i_alloc_struct (SCM_UNPACK (vtable), basic_size);
scm_struct_init (obj, layout, n_init, init); scm_struct_init (obj, SCM_VTABLE_LAYOUT (vtable), n_init, init);
/* If we're making a vtable, validate its layout and inherit /* If we're making a vtable, validate its layout and inherit
flags. However we allow for separation of allocation and flags. However we allow for separation of allocation and
@ -450,19 +404,10 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
SCM_VALIDATE_VTABLE (1, vtable); SCM_VALIDATE_VTABLE (1, vtable);
c_nfields = scm_to_size_t (nfields); c_nfields = scm_to_size_t (nfields);
SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields, SCM_ASSERT (SCM_VTABLE_SIZE (vtable) == c_nfields, nfields, 2, FUNC_NAME);
nfields, 2, FUNC_NAME);
ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields); ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields);
scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL);
if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
{
size_t n;
for (n = 0; n < c_nfields; n++)
SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F));
}
else
scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL);
return ret; return ret;
} }
@ -526,19 +471,18 @@ scm_i_make_vtable_vtable (SCM fields)
SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc3_struct); SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc3_struct);
/* Manually initialize fields. */ /* Manually initialize fields. */
SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_layout, layout); SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_layout, layout);
SCM_STRUCT_DATA_SET (obj, scm_vtable_index_flags, set_vtable_access_fields (obj);
SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED); SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
SCM_STRUCT_DATA_SET (obj, scm_vtable_index_instance_finalize, 0); SCM_STRUCT_DATA_SET (obj, scm_vtable_index_instance_finalize, 0);
SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_instance_printer, SCM_BOOL_F); SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_instance_printer, SCM_BOOL_F);
SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_name, SCM_BOOL_F); SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_name, SCM_BOOL_F);
SCM_STRUCT_DATA_SET (obj, scm_vtable_index_size, nfields);
SCM_STRUCT_DATA_SET (obj, scm_vtable_index_reserved_7, 0); SCM_STRUCT_DATA_SET (obj, scm_vtable_index_reserved_7, 0);
for (n = scm_vtable_offset_user; n < nfields; n++) for (n = scm_vtable_offset_user; n < nfields; n++)
if (scm_i_symbol_ref (layout, n*2) == 'p') if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, n))
SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F);
else
SCM_STRUCT_DATA_SET (obj, n, 0); SCM_STRUCT_DATA_SET (obj, n, 0);
else
SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F);
return obj; return obj;
} }
@ -570,20 +514,15 @@ SCM
scm_i_struct_equalp (SCM s1, SCM s2) scm_i_struct_equalp (SCM s1, SCM s2)
#define FUNC_NAME "scm_i_struct_equalp" #define FUNC_NAME "scm_i_struct_equalp"
{ {
SCM vtable1, vtable2, layout;
size_t struct_size, field_num; size_t struct_size, field_num;
SCM_VALIDATE_STRUCT (1, s1); SCM_VALIDATE_STRUCT (1, s1);
SCM_VALIDATE_STRUCT (2, s2); SCM_VALIDATE_STRUCT (2, s2);
vtable1 = SCM_STRUCT_VTABLE (s1); if (!scm_is_eq (SCM_STRUCT_VTABLE (s1), SCM_STRUCT_VTABLE (s2)))
vtable2 = SCM_STRUCT_VTABLE (s2);
if (!scm_is_eq (vtable1, vtable2))
return SCM_BOOL_F; return SCM_BOOL_F;
layout = SCM_STRUCT_LAYOUT (s1); struct_size = SCM_STRUCT_SIZE (s1);
struct_size = scm_i_symbol_length (layout) / 2;
for (field_num = 0; field_num < struct_size; field_num++) for (field_num = 0; field_num < struct_size; field_num++)
{ {
@ -593,7 +532,7 @@ scm_i_struct_equalp (SCM s1, SCM s2)
field2 = SCM_STRUCT_DATA_REF (s2, field_num); field2 = SCM_STRUCT_DATA_REF (s2, field_num);
if (field1 != field2) { if (field1 != field2) {
if (scm_i_symbol_ref (layout, field_num * 2) == 'u') if (SCM_STRUCT_FIELD_IS_UNBOXED (s1, field_num))
return SCM_BOOL_F; return SCM_BOOL_F;
/* Having a normal field point to the object itself is a bit /* Having a normal field point to the object itself is a bit
@ -629,20 +568,16 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
"word.") "word.")
#define FUNC_NAME s_scm_struct_ref #define FUNC_NAME s_scm_struct_ref
{ {
SCM vtable, layout;
size_t nfields, p; size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle); SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle); nfields = SCM_STRUCT_SIZE (handle);
layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos); p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields); SCM_ASSERT_RANGE (2, pos, p < nfields);
/* Only 'p' fields. */ SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
return SCM_STRUCT_SLOT_REF (handle, p); return SCM_STRUCT_SLOT_REF (handle, p);
} }
@ -656,20 +591,16 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
"to.") "to.")
#define FUNC_NAME s_scm_struct_set_x #define FUNC_NAME s_scm_struct_set_x
{ {
SCM vtable, layout;
size_t nfields, p; size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle); SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle); nfields = SCM_STRUCT_SIZE (handle);
layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos); p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields); SCM_ASSERT_RANGE (2, pos, p < nfields);
/* Only 'p' fields. */ SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
SCM_STRUCT_SLOT_SET (handle, p, val); SCM_STRUCT_SLOT_SET (handle, p, val);
@ -684,20 +615,16 @@ SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0,
"@var{handle}. The field must be of type 'u'.") "@var{handle}. The field must be of type 'u'.")
#define FUNC_NAME s_scm_struct_ref_unboxed #define FUNC_NAME s_scm_struct_ref_unboxed
{ {
SCM vtable, layout;
size_t nfields, p; size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle); SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle); nfields = SCM_STRUCT_SIZE (handle);
layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos); p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields); SCM_ASSERT_RANGE (2, pos, p < nfields);
/* Only 'u' fields. */ SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p)); return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p));
} }
@ -711,20 +638,16 @@ SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0,
"to.") "to.")
#define FUNC_NAME s_scm_struct_set_x_unboxed #define FUNC_NAME s_scm_struct_set_x_unboxed
{ {
SCM vtable, layout;
size_t nfields, p; size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle); SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle); nfields = SCM_STRUCT_SIZE (handle);
layout = SCM_VTABLE_LAYOUT (vtable);
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos); p = scm_to_size_t (pos);
SCM_ASSERT_RANGE (2, pos, p < nfields); SCM_ASSERT_RANGE (2, pos, p < nfields);
/* Only 'u' fields. */ SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME);
SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val)); SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));

29
libguile/struct.h
View file

@ -61,7 +61,7 @@
"pw" /* printer */ \ "pw" /* printer */ \
"ph" /* name (hidden from make-struct for back-compat reasons) */ \ "ph" /* name (hidden from make-struct for back-compat reasons) */ \
"uh" /* size */ \ "uh" /* size */ \
"uh" /* reserved */ \ "uh" /* unboxed fields */ \
"uh" /* reserved */ "uh" /* reserved */
#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ #define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
@ -70,7 +70,7 @@
#define scm_vtable_index_instance_printer 3 /* A printer for this struct type. */ #define scm_vtable_index_instance_printer 3 /* A printer for this struct type. */
#define scm_vtable_index_name 4 /* Name of this vtable. */ #define scm_vtable_index_name 4 /* Name of this vtable. */
#define scm_vtable_index_size 5 /* Number of fields, for simple structs. */ #define scm_vtable_index_size 5 /* Number of fields, for simple structs. */
#define scm_vtable_index_reserved_6 6 #define scm_vtable_index_unboxed_fields 6 /* Raw scm_t_uint32* bitmask indicating unboxed fields. */
#define scm_vtable_index_reserved_7 7 #define scm_vtable_index_reserved_7 7
#define scm_vtable_offset_user 8 /* Where do user fields start in the vtable? */ #define scm_vtable_offset_user 8 /* Where do user fields start in the vtable? */
@ -95,16 +95,16 @@
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 3) /* instances of this vtable are applicable? */ #define SCM_VTABLE_FLAG_APPLICABLE (1L << 3) /* instances of this vtable are applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 4) /* instances of this vtable are applicable-with-setter vtables? */ #define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 4) /* instances of this vtable are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 5) /* instances of this vtable are applicable-with-setters? */ #define SCM_VTABLE_FLAG_SETTER (1L << 5) /* instances of this vtable are applicable-with-setters? */
#define SCM_VTABLE_FLAG_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields and no tail array*/ #define SCM_VTABLE_FLAG_RESERVED_0 (1L << 6)
#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */ #define SCM_VTABLE_FLAG_RESERVED_1 (1L << 7)
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8) #define SCM_VTABLE_FLAG_SMOB_0 (1L << 8)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9) #define SCM_VTABLE_FLAG_GOOPS_0 (1L << 9)
#define SCM_VTABLE_FLAG_SMOB_0 (1L << 10) #define SCM_VTABLE_FLAG_GOOPS_1 (1L << 10)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 11) #define SCM_VTABLE_FLAG_GOOPS_2 (1L << 11)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 12) #define SCM_VTABLE_FLAG_GOOPS_3 (1L << 12)
#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 13) #define SCM_VTABLE_FLAG_GOOPS_4 (1L << 13)
#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 14) #define SCM_VTABLE_FLAG_RESERVED_2 (1L << 14)
#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 15) #define SCM_VTABLE_FLAG_RESERVED_3 (1L << 15)
#define SCM_VTABLE_USER_FLAG_SHIFT 16 #define SCM_VTABLE_USER_FLAG_SHIFT 16
typedef void (*scm_t_struct_finalize) (SCM obj); typedef void (*scm_t_struct_finalize) (SCM obj);
@ -131,13 +131,18 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_instance_printer, (P))) #define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_instance_printer, (P)))
#define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name)) #define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name))
#define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V)) #define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V))
#define SCM_VTABLE_SIZE(X) (SCM_STRUCT_DATA_REF (X, scm_vtable_index_size))
#define SCM_VTABLE_UNBOXED_FIELDS(X) ((scm_t_uint32*) SCM_STRUCT_DATA_REF (X, scm_vtable_index_unboxed_fields))
#define SCM_VTABLE_FIELD_IS_UNBOXED(X,F) (SCM_VTABLE_UNBOXED_FIELDS (X)[(F)>>5]&(1U<<((F)&31)))
#define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_CELL_WORD_0 (X) - scm_tc3_struct)) #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
#define SCM_STRUCT_LAYOUT(X) (SCM_VTABLE_LAYOUT (SCM_STRUCT_VTABLE (X))) #define SCM_STRUCT_LAYOUT(X) (SCM_VTABLE_LAYOUT (SCM_STRUCT_VTABLE (X)))
#define SCM_STRUCT_SIZE(X) (SCM_VTABLE_SIZE (SCM_STRUCT_VTABLE (X)))
#define SCM_STRUCT_PRINTER(X) (SCM_VTABLE_INSTANCE_PRINTER (SCM_STRUCT_VTABLE (X))) #define SCM_STRUCT_PRINTER(X) (SCM_VTABLE_INSTANCE_PRINTER (SCM_STRUCT_VTABLE (X)))
#define SCM_STRUCT_FINALIZER(X) (SCM_VTABLE_INSTANCE_FINALIZER (SCM_STRUCT_VTABLE (X))) #define SCM_STRUCT_FINALIZER(X) (SCM_VTABLE_INSTANCE_FINALIZER (SCM_STRUCT_VTABLE (X)))
#define SCM_STRUCT_VTABLE_FLAGS(X) (SCM_VTABLE_FLAGS (SCM_STRUCT_VTABLE (X))) #define SCM_STRUCT_VTABLE_FLAGS(X) (SCM_VTABLE_FLAGS (SCM_STRUCT_VTABLE (X)))
#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_VTABLE_FLAG_IS_SET (SCM_STRUCT_VTABLE (X), (F))) #define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_VTABLE_FLAG_IS_SET (SCM_STRUCT_VTABLE (X), (F)))
#define SCM_STRUCT_FIELD_IS_UNBOXED(X,F) (SCM_VTABLE_FIELD_IS_UNBOXED (SCM_STRUCT_VTABLE (X), (F)))
#define SCM_STRUCT_APPLICABLE_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_APPLICABLE)) #define SCM_STRUCT_APPLICABLE_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_APPLICABLE))
#define SCM_STRUCT_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER)) #define SCM_STRUCT_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER))

54
libguile/vm-engine.c
View file

@ -441,12 +441,12 @@
#define VM_VALIDATE_INDEX(u64, size, proc) \ #define VM_VALIDATE_INDEX(u64, size, proc) \
VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64)) VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64))
#define VM_VALIDATE_BOXED_STRUCT_FIELD(layout, i, proc) \ #define VM_VALIDATE_BOXED_STRUCT_FIELD(obj, i, proc) \
VM_ASSERT (scm_i_symbol_ref (layout, i * 2) == 'p', \ VM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, i), \
vm_error_boxed_struct_field (proc, i))
#define VM_VALIDATE_UNBOXED_STRUCT_FIELD(obj, i, proc) \
VM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (obj, i), \
vm_error_boxed_struct_field (proc, i)) vm_error_boxed_struct_field (proc, i))
#define VM_VALIDATE_UNBOXED_STRUCT_FIELD(layout, i, proc) \
VM_ASSERT (scm_i_symbol_ref (layout, i * 2) == 'u', \
vm_error_unboxed_struct_field (proc, i))
/* Return true (non-zero) if PTR has suitable alignment for TYPE. */ /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
#define ALIGNED_P(ptr, type) \ #define ALIGNED_P(ptr, type) \
@ -2775,8 +2775,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (108, struct_ref, "struct-ref", OP1 (X8_S8_S8_S8) | OP_DST) VM_DEFINE_OP (108, struct_ref, "struct-ref", OP1 (X8_S8_S8_S8) | OP_DST)
{ {
scm_t_uint8 dst, src, idx; scm_t_uint8 dst, src, idx;
SCM obj, vtable; SCM obj;
scm_t_uint64 index, nfields; scm_t_uint64 index;
UNPACK_8_8_8 (op, dst, src, idx); UNPACK_8_8_8 (op, dst, src, idx);
@ -2784,11 +2784,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
index = SP_REF_U64 (idx); index = SP_REF_U64 (idx);
VM_VALIDATE_STRUCT (obj, "struct-ref"); VM_VALIDATE_STRUCT (obj, "struct-ref");
vtable = SCM_STRUCT_VTABLE (obj); VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-ref");
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-ref");
VM_VALIDATE_INDEX (index, nfields, "struct-ref");
VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable),
index, "struct-ref");
RETURN (SCM_STRUCT_SLOT_REF (obj, index)); RETURN (SCM_STRUCT_SLOT_REF (obj, index));
} }
@ -2800,8 +2797,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (109, struct_set, "struct-set!", OP1 (X8_S8_S8_S8)) VM_DEFINE_OP (109, struct_set, "struct-set!", OP1 (X8_S8_S8_S8))
{ {
scm_t_uint8 dst, idx, src; scm_t_uint8 dst, idx, src;
SCM obj, vtable, val; SCM obj, val;
scm_t_uint64 index, nfields; scm_t_uint64 index;
UNPACK_8_8_8 (op, dst, idx, src); UNPACK_8_8_8 (op, dst, idx, src);
@ -2810,11 +2807,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
index = SP_REF_U64 (idx); index = SP_REF_U64 (idx);
VM_VALIDATE_STRUCT (obj, "struct-set!"); VM_VALIDATE_STRUCT (obj, "struct-set!");
vtable = SCM_STRUCT_VTABLE (obj); VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-set!");
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-set!");
VM_VALIDATE_INDEX (index, nfields, "struct-set!");
VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable),
index, "struct-set!");
SCM_STRUCT_SLOT_SET (obj, index, val); SCM_STRUCT_SLOT_SET (obj, index, val);
NEXT (1); NEXT (1);
@ -2848,8 +2842,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (111, struct_ref_immediate, "struct-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST) VM_DEFINE_OP (111, struct_ref_immediate, "struct-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
{ {
scm_t_uint8 dst, src, idx; scm_t_uint8 dst, src, idx;
SCM obj, vtable; SCM obj;
scm_t_uint64 index, nfields; scm_t_uint64 index;
UNPACK_8_8_8 (op, dst, src, idx); UNPACK_8_8_8 (op, dst, src, idx);
@ -2857,11 +2851,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
index = idx; index = idx;
VM_VALIDATE_STRUCT (obj, "struct-ref"); VM_VALIDATE_STRUCT (obj, "struct-ref");
vtable = SCM_STRUCT_VTABLE (obj); VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-ref");
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-ref");
VM_VALIDATE_INDEX (index, nfields, "struct-ref");
VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable),
index, "struct-ref");
RETURN (SCM_STRUCT_SLOT_REF (obj, index)); RETURN (SCM_STRUCT_SLOT_REF (obj, index));
} }
@ -2874,8 +2865,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (112, struct_set_immediate, "struct-set!/immediate", OP1 (X8_S8_C8_S8)) VM_DEFINE_OP (112, struct_set_immediate, "struct-set!/immediate", OP1 (X8_S8_C8_S8))
{ {
scm_t_uint8 dst, idx, src; scm_t_uint8 dst, idx, src;
SCM obj, vtable, val; SCM obj, val;
scm_t_uint64 index, nfields; scm_t_uint64 index;
UNPACK_8_8_8 (op, dst, idx, src); UNPACK_8_8_8 (op, dst, idx, src);
@ -2884,11 +2875,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
index = idx; index = idx;
VM_VALIDATE_STRUCT (obj, "struct-set!"); VM_VALIDATE_STRUCT (obj, "struct-set!");
vtable = SCM_STRUCT_VTABLE (obj); VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-set!");
nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-set!");
VM_VALIDATE_INDEX (index, nfields, "struct-set!");
VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable),
index, "struct-set!");
SCM_STRUCT_SLOT_SET (obj, index, val); SCM_STRUCT_SLOT_SET (obj, index, val);
NEXT (1); NEXT (1);