From 214e887dbdece2e7608b02dd1ce5b31e710266cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Sep 2017 21:56:31 +0200 Subject: [PATCH] Struct vtables store bitmask of unboxed fields * 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. --- libguile/foreign-object.c | 31 +++---- libguile/goops.c | 8 +- libguile/hash.c | 33 ++----- libguile/struct.c | 183 +++++++++++--------------------------- libguile/struct.h | 29 +++--- libguile/vm-engine.c | 54 +++++------ 6 files changed, 112 insertions(+), 226 deletions(-) diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c index f074463a1..34b9f22ca 100644 --- a/libguile/foreign-object.c +++ b/libguile/foreign-object.c @@ -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 * 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" { SCM obj; - SCM layout; size_t i; - const char *layout_chars; SCM_VALIDATE_VTABLE (SCM_ARG1, type); - layout = SCM_VTABLE_LAYOUT (type); - - if (scm_i_symbol_length (layout) / 2 < n) + if (SCM_VTABLE_SIZE (type) / 2 < 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++) - if (layout_chars[i * 2] != 'u') - scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); + if (!SCM_VTABLE_FIELD_IS_UNBOXED (type, i)) + scm_wrong_type_arg_msg (FUNC_NAME, 0, type, "foreign object type"); 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) #define FUNC_NAME "foreign-object-ref" { - SCM layout; - SCM_VALIDATE_STRUCT (SCM_ARG1, obj); - layout = SCM_STRUCT_LAYOUT (obj); - if (scm_i_symbol_length (layout) / 2 < n) + if (SCM_STRUCT_SIZE (obj) <= n) scm_out_of_range (FUNC_NAME, scm_from_size_t (n)); - if (scm_i_symbol_ref (layout, n * 2) != 'u') - scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); + if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n)) + scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field"); 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) #define FUNC_NAME "foreign-object-set!" { - SCM layout; - SCM_VALIDATE_STRUCT (SCM_ARG1, obj); - layout = SCM_STRUCT_LAYOUT (obj); - if (scm_i_symbol_length (layout) / 2 < n) + if (SCM_STRUCT_SIZE (obj) <= n) scm_out_of_range (FUNC_NAME, scm_from_size_t (n)); - if (scm_i_symbol_ref (layout, n * 2) != 'u') - scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field"); + if (!SCM_STRUCT_FIELD_IS_UNBOXED (obj, n)) + scm_wrong_type_arg_msg (FUNC_NAME, 0, scm_from_size_t (n), "unboxed field"); SCM_STRUCT_DATA_SET (obj, n, val); } diff --git a/libguile/goops.c b/libguile/goops.c index e8ae001ed..40a93b1a4 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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 { scm_t_signed_bits n, i; - SCM vtable, layout; SCM_VALIDATE_STRUCT (1, obj); - vtable = SCM_STRUCT_VTABLE (obj); - - n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - layout = SCM_VTABLE_LAYOUT (vtable); + n = SCM_STRUCT_SIZE (obj); /* Set all SCM-holding slots to the GOOPS unbound value. */ 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); return SCM_UNSPECIFIED; diff --git a/libguile/hash.c b/libguile/hash.c index 84285aa11..93c6f7aa8 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -227,36 +227,21 @@ static unsigned long scm_raw_ihash (SCM obj, size_t depth); static unsigned long scm_i_struct_hash (SCM obj, size_t depth) { - SCM layout; - scm_t_bits *data; size_t struct_size, field_num; unsigned long hash; - layout = SCM_STRUCT_LAYOUT (obj); - struct_size = scm_i_symbol_length (layout) / 2; - data = SCM_STRUCT_DATA (obj); + struct_size = SCM_STRUCT_SIZE (obj); hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj))); if (depth > 0) - for (field_num = 0; field_num < struct_size; field_num++) - { - int type; - type = scm_i_symbol_ref (layout, field_num * 2); - switch (type) - { - case 'p': - 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. */ + { + for (field_num = 0; field_num < struct_size; field_num++) + if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, field_num)) + hash ^= scm_raw_ihashq (SCM_STRUCT_DATA_REF (obj, field_num)); + else + hash ^= scm_raw_ihash (SCM_STRUCT_SLOT_REF (obj, field_num), + depth / 2); + } return hash; } diff --git a/libguile/struct.c b/libguile/struct.c index 57195bcb3..e39f3c720 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -120,50 +120,35 @@ 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) +set_vtable_access_fields (SCM vtable) { - size_t len, field; + size_t len, nfields, bitmask_size, field; SCM layout; const char *c_layout; - scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE; + scm_t_uint32 *unboxed_fields; layout = SCM_VTABLE_LAYOUT (vtable); c_layout = scm_i_symbol_chars (layout); len = scm_i_symbol_length (layout); 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. */ - 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 'h': - if (field == 0) - flags |= SCM_VTABLE_FLAG_SIMPLE_RW; - break; - - case 'r': - flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW; - break; - - default: - abort (); - } - } + for (field = 0; field < nfields; field++) + if (c_layout[field*2] == 'u') + unboxed_fields[field/32U] |= 1U << (field%32U); /* 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_unboxed_fields, + (scm_t_uintptr) unboxed_fields); } 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_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 is a metaclass. */ @@ -271,56 +256,27 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj) static void scm_struct_init (SCM handle, SCM layout, size_t n_inits, scm_t_bits *inits) { - SCM vtable; - scm_t_bits *mem; - size_t n_fields; + size_t n, n_fields, inits_idx = 0; - vtable = SCM_STRUCT_VTABLE (handle); - n_fields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - mem = SCM_STRUCT_DATA (handle); + n_fields = SCM_STRUCT_SIZE (handle); - if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && n_inits == n_fields) - /* The fast path: HANDLE has N_INITS "p" fields. */ - memcpy (mem, inits, n_inits * sizeof (SCM)); - else + for (n = 0; n < n_fields; n++) { - scm_t_wchar prot = 0; - int i; - size_t inits_idx = 0; - - i = -2; - while (n_fields) - { - i += 2; - prot = scm_i_symbol_ref (layout, i+1); - switch (scm_i_symbol_ref (layout, i)) - { - case 'u': - if (prot == 'h' || inits_idx == n_inits) - *mem = 0; - 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++; - } + if (inits_idx == n_inits || scm_i_symbol_ref (layout, n*2+1) == 'h') + { + if (SCM_STRUCT_FIELD_IS_UNBOXED (handle, n)) + SCM_STRUCT_DATA_SET (handle, n, 0); + else + SCM_STRUCT_SLOT_SET (handle, n, SCM_BOOL_F); + } + else + { + SCM_STRUCT_DATA_SET (handle, n, + SCM_STRUCT_FIELD_IS_UNBOXED (handle, n) + ? scm_to_uintptr_t (SCM_PACK (inits[inits_idx])) + : inits[inits_idx]); + inits_idx++; + } } } @@ -384,19 +340,17 @@ SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init) #define FUNC_NAME "make-struct" { - SCM layout; size_t basic_size; SCM obj; SCM_VALIDATE_VTABLE (1, vtable); - layout = SCM_VTABLE_LAYOUT (vtable); - basic_size = scm_i_symbol_length (layout) / 2; + basic_size = SCM_VTABLE_SIZE (vtable); SCM_ASSERT (n_tail == 0, scm_from_size_t (n_tail), 2, FUNC_NAME); 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 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); c_nfields = scm_to_size_t (nfields); - SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields, - nfields, 2, FUNC_NAME); + SCM_ASSERT (SCM_VTABLE_SIZE (vtable) == c_nfields, nfields, 2, FUNC_NAME); ret = scm_i_alloc_struct (SCM_UNPACK (vtable), c_nfields); - - 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); + scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, NULL); 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); /* Manually initialize fields. */ SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_layout, layout); - SCM_STRUCT_DATA_SET (obj, scm_vtable_index_flags, - SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED); + set_vtable_access_fields (obj); + 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_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_DATA_SET (obj, scm_vtable_index_size, nfields); SCM_STRUCT_DATA_SET (obj, scm_vtable_index_reserved_7, 0); for (n = scm_vtable_offset_user; n < nfields; n++) - if (scm_i_symbol_ref (layout, n*2) == 'p') - SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F); - else + if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, n)) SCM_STRUCT_DATA_SET (obj, n, 0); + else + SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F); return obj; } @@ -570,20 +514,15 @@ SCM scm_i_struct_equalp (SCM s1, SCM s2) #define FUNC_NAME "scm_i_struct_equalp" { - SCM vtable1, vtable2, layout; size_t struct_size, field_num; SCM_VALIDATE_STRUCT (1, s1); SCM_VALIDATE_STRUCT (2, s2); - vtable1 = SCM_STRUCT_VTABLE (s1); - vtable2 = SCM_STRUCT_VTABLE (s2); - - if (!scm_is_eq (vtable1, vtable2)) + if (!scm_is_eq (SCM_STRUCT_VTABLE (s1), SCM_STRUCT_VTABLE (s2))) return SCM_BOOL_F; - layout = SCM_STRUCT_LAYOUT (s1); - struct_size = scm_i_symbol_length (layout) / 2; + struct_size = SCM_STRUCT_SIZE (s1); 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); 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; /* 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.") #define FUNC_NAME s_scm_struct_ref { - SCM vtable, layout; size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - layout = SCM_VTABLE_LAYOUT (vtable); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); SCM_ASSERT_RANGE (2, pos, p < nfields); - /* Only 'p' fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME); + SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); return SCM_STRUCT_SLOT_REF (handle, p); } @@ -656,20 +591,16 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, "to.") #define FUNC_NAME s_scm_struct_set_x { - SCM vtable, layout; size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - layout = SCM_VTABLE_LAYOUT (vtable); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); SCM_ASSERT_RANGE (2, pos, p < nfields); - /* Only 'p' fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME); + SCM_ASSERT (!SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); 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'.") #define FUNC_NAME s_scm_struct_ref_unboxed { - SCM vtable, layout; size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - layout = SCM_VTABLE_LAYOUT (vtable); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); SCM_ASSERT_RANGE (2, pos, p < nfields); - /* Only 'u' fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME); + SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); 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.") #define FUNC_NAME s_scm_struct_set_x_unboxed { - SCM vtable, layout; size_t nfields, p; SCM_VALIDATE_STRUCT (1, handle); - vtable = SCM_STRUCT_VTABLE (handle); - layout = SCM_VTABLE_LAYOUT (vtable); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); + nfields = SCM_STRUCT_SIZE (handle); p = scm_to_size_t (pos); SCM_ASSERT_RANGE (2, pos, p < nfields); - /* Only 'u' fields. */ - SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME); + SCM_ASSERT (SCM_STRUCT_FIELD_IS_UNBOXED (handle, p), pos, 2, FUNC_NAME); SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val)); diff --git a/libguile/struct.h b/libguile/struct.h index 66c1740d7..d88944cd7 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -61,7 +61,7 @@ "pw" /* printer */ \ "ph" /* name (hidden from make-struct for back-compat reasons) */ \ "uh" /* size */ \ - "uh" /* reserved */ \ + "uh" /* unboxed fields */ \ "uh" /* reserved */ #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_name 4 /* Name of this vtable. */ #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_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_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_SIMPLE (1L << 6) /* instances of this vtable have only "p" fields and no tail array*/ -#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_0 (1L << 8) -#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9) -#define SCM_VTABLE_FLAG_SMOB_0 (1L << 10) -#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 11) -#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 12) -#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 13) -#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 14) -#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 15) +#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 6) +#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 7) +#define SCM_VTABLE_FLAG_SMOB_0 (1L << 8) +#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 9) +#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 10) +#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 11) +#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 12) +#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 13) +#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 14) +#define SCM_VTABLE_FLAG_RESERVED_3 (1L << 15) #define SCM_VTABLE_USER_FLAG_SHIFT 16 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_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_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_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_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_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_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER)) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 6e0bfc57b..94bf35279 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -441,12 +441,12 @@ #define VM_VALIDATE_INDEX(u64, size, proc) \ VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64)) -#define VM_VALIDATE_BOXED_STRUCT_FIELD(layout, i, proc) \ - VM_ASSERT (scm_i_symbol_ref (layout, i * 2) == 'p', \ +#define VM_VALIDATE_BOXED_STRUCT_FIELD(obj, i, proc) \ + 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)) -#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. */ #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) { scm_t_uint8 dst, src, idx; - SCM obj, vtable; - scm_t_uint64 index, nfields; + SCM obj; + scm_t_uint64 index; 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); VM_VALIDATE_STRUCT (obj, "struct-ref"); - vtable = SCM_STRUCT_VTABLE (obj); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - VM_VALIDATE_INDEX (index, nfields, "struct-ref"); - VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable), - index, "struct-ref"); + VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-ref"); + VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-ref"); 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)) { scm_t_uint8 dst, idx, src; - SCM obj, vtable, val; - scm_t_uint64 index, nfields; + SCM obj, val; + scm_t_uint64 index; 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); VM_VALIDATE_STRUCT (obj, "struct-set!"); - vtable = SCM_STRUCT_VTABLE (obj); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - VM_VALIDATE_INDEX (index, nfields, "struct-set!"); - VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable), - index, "struct-set!"); + VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-set!"); + VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-set!"); SCM_STRUCT_SLOT_SET (obj, index, val); 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) { scm_t_uint8 dst, src, idx; - SCM obj, vtable; - scm_t_uint64 index, nfields; + SCM obj; + scm_t_uint64 index; UNPACK_8_8_8 (op, dst, src, idx); @@ -2857,11 +2851,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, index = idx; VM_VALIDATE_STRUCT (obj, "struct-ref"); - vtable = SCM_STRUCT_VTABLE (obj); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - VM_VALIDATE_INDEX (index, nfields, "struct-ref"); - VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable), - index, "struct-ref"); + VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-ref"); + VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-ref"); 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)) { scm_t_uint8 dst, idx, src; - SCM obj, vtable, val; - scm_t_uint64 index, nfields; + SCM obj, val; + scm_t_uint64 index; UNPACK_8_8_8 (op, dst, idx, src); @@ -2884,11 +2875,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, index = idx; VM_VALIDATE_STRUCT (obj, "struct-set!"); - vtable = SCM_STRUCT_VTABLE (obj); - nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - VM_VALIDATE_INDEX (index, nfields, "struct-set!"); - VM_VALIDATE_BOXED_STRUCT_FIELD (SCM_VTABLE_LAYOUT (vtable), - index, "struct-set!"); + VM_VALIDATE_INDEX (index, SCM_STRUCT_SIZE (obj), "struct-set!"); + VM_VALIDATE_BOXED_STRUCT_FIELD (obj, index, "struct-set!"); SCM_STRUCT_SLOT_SET (obj, index, val); NEXT (1);