mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 21:10:27 +02:00
redo the SCM tagging strategy
Currently failing some guardian tests. * libguile/tags.h: Refactor tagging so that tc3 bits for a pair live in the SCM value, not in the heap words. Do the same for structs. This more rational tagging strategy will make native code generation easier. Note that this means that to check a heap pointer for its type, you first have to ensure that it has the expected tc3, as not all the type bits are on the heap. (SCM_TYP3): Check the SCM tag type, not the bits in the cell. (SCM_HAS_TYP3): New helper. (SCM_I_CONSP): Redefine to just check the typ3. (scm_tcs_cons_imcar, scm_tcs_cons_nimcar, scm_tcs_struct): Remove, as they are no longer necessary. * libguile/array-handle.c (scm_i_array_implementation_for_obj): Check for heap objects before checking type bits, so we don't check pairs. * libguile/evalext.c (scm_self_evaluating_p): * libguile/gc.c (scm_i_tag_name): * libguile/goops.c (scm_class_of) * libguile/hash.c (scm_hasher): * libguile/print.c (iprin1): Adapt to tagging changes. * libguile/gc.c (scm_storage_prehistory): Register all displacements here. There are the same displacements as before, unfortunately. * libguile/list.c (SCM_I_CONS): * libguile/pairs.c (scm_cons): * libguile/pairs.h (scm_is_pair): * libguile/vm-engine.h (CONS): Tag pairs with scm_tc3_pair. * libguile/modules.c (scm_post_boot_init_modules): * libguile/modules.h (SCM_MODULEP): * libguile/struct.c (struct_finalizer_trampoline, scm_i_alloc_struct): (scm_make_vtable_vtable): * libguile/struct.h (SCM_STRUCTP, SCM_STRUCT_VTABLE_DATA): (SCM_STRUCT_VTABLE_SLOTS): * libguile/vm-i-scheme.c (make-struct): Adapt to struct tagging changes. * libguile/numbers.h (SCM_I_INUMP): * module/rnrs/arithmetic/fixnums.scm (fixnum?, inline-fixnum?): Adapt to the new fixnum tag. * libguile/numbers.h (SCM_INEXACTP): Make sure of the tc3 before looking at the cell type.
This commit is contained in:
Andy Wingo
parent
03daea184e
commit
b071ce2147
17 changed files with 233 additions and 310 deletions
|
|
@ -51,9 +51,13 @@ scm_t_array_implementation*
|
|||
scm_i_array_implementation_for_obj (SCM obj)
|
||||
{
|
||||
int i;
|
||||
|
||||
if (!(SCM_HAS_TYP3 (obj, scm_tc3_heap)
|
||||
|| SCM_HAS_TYP3 (obj, scm_tc3_struct)))
|
||||
return NULL;
|
||||
|
||||
for (i = 0; i < num_array_impls_registered; i++)
|
||||
if (SCM_NIMP (obj)
|
||||
&& (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
|
||||
if ((SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
|
||||
return &array_impls[i];
|
||||
return NULL;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2013 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
|
||||
|
|
@ -69,7 +69,11 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
|
|||
case scm_tc3_imm24:
|
||||
/* characters, booleans, other immediates */
|
||||
return scm_from_bool (!scm_is_null_and_not_nil (obj));
|
||||
case scm_tc3_struct:
|
||||
return SCM_BOOL_T;
|
||||
case scm_tc3_cons:
|
||||
return SCM_BOOL_F;
|
||||
case scm_tc3_heap:
|
||||
switch (SCM_TYP7 (obj))
|
||||
{
|
||||
case scm_tc7_vector:
|
||||
|
|
@ -91,16 +95,16 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
|
|||
case scm_tc7_bytevector:
|
||||
case scm_tc7_array:
|
||||
case scm_tc7_bitvector:
|
||||
case scm_tcs_struct:
|
||||
return SCM_BOOL_T;
|
||||
default:
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
}
|
||||
default:
|
||||
SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
|
||||
scm_list_1 (obj));
|
||||
return SCM_UNSPECIFIED; /* never reached */
|
||||
}
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -640,12 +640,17 @@ scm_storage_prehistory ()
|
|||
|
||||
GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
|
||||
|
||||
/* We only need to register a displacement for those types for which the
|
||||
higher bits of the type tag are used to store a pointer (that is, a
|
||||
pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
|
||||
handled in `scm_alloc_struct ()'. */
|
||||
/* SCM values pointing to pairs and structs are tagged. */
|
||||
GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
|
||||
/* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
|
||||
GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
|
||||
|
||||
/* The first word of a struct points to `SCM_STRUCT_DATA (vtable)',
|
||||
and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by default.
|
||||
Also, in the general case, `SCM_STRUCT_DATA (obj)' points 2 words
|
||||
after the beginning of a GC-allocated region; that region is
|
||||
different from that of OBJ once OBJ has undergone class
|
||||
redefinition. */
|
||||
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
|
||||
|
||||
/* Sanity check. */
|
||||
if (!GC_is_visible (&scm_protects))
|
||||
|
|
@ -950,12 +955,6 @@ scm_i_tag_name (scm_t_bits tag)
|
|||
{
|
||||
switch (tag & 0x7f) /* 7 bits */
|
||||
{
|
||||
case scm_tcs_struct:
|
||||
return "struct";
|
||||
case scm_tcs_cons_imcar:
|
||||
return "cons (immediate car)";
|
||||
case scm_tcs_cons_nimcar:
|
||||
return "cons (non-immediate car)";
|
||||
case scm_tc7_pointer:
|
||||
return "foreign";
|
||||
case scm_tc7_hashtable:
|
||||
|
|
|
|||
|
|
@ -247,10 +247,26 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
return scm_class_unknown;
|
||||
|
||||
case scm_tc3_cons:
|
||||
return scm_class_pair;
|
||||
|
||||
case scm_tc3_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
|
||||
return SCM_CLASS_OF (x);
|
||||
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
/* Goops object */
|
||||
if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
|
||||
scm_change_object_class (x,
|
||||
SCM_CLASS_OF (x), /* old */
|
||||
SCM_OBJ_CLASS_REDEF (x)); /* new */
|
||||
return SCM_CLASS_OF (x);
|
||||
}
|
||||
else
|
||||
return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
|
||||
|
||||
case scm_tc3_heap:
|
||||
switch (SCM_TYP7 (x))
|
||||
{
|
||||
case scm_tcs_cons_nimcar:
|
||||
return scm_class_pair;
|
||||
case scm_tc7_symbol:
|
||||
return scm_class_symbol;
|
||||
case scm_tc7_vector:
|
||||
|
|
@ -315,30 +331,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
|
||||
: SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
|
||||
: SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
|
||||
case scm_tcs_struct:
|
||||
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
|
||||
return SCM_CLASS_OF (x);
|
||||
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
/* Goops object */
|
||||
if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
|
||||
scm_change_object_class (x,
|
||||
SCM_CLASS_OF (x), /* old */
|
||||
SCM_OBJ_CLASS_REDEF (x)); /* new */
|
||||
return SCM_CLASS_OF (x);
|
||||
}
|
||||
else
|
||||
return scm_i_define_class_for_vtable (SCM_CLASS_OF (x));
|
||||
default:
|
||||
if (scm_is_pair (x))
|
||||
return scm_class_pair;
|
||||
else
|
||||
return scm_class_unknown;
|
||||
}
|
||||
|
||||
case scm_tc3_struct:
|
||||
case scm_tc3_tc7_1:
|
||||
case scm_tc3_tc7_2:
|
||||
case scm_tc3_unused_1:
|
||||
case scm_tc3_unused_2:
|
||||
/* case scm_tc3_unused: */
|
||||
/* Never reached */
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
|
||||
* 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
* 2009, 2010, 2011, 2012, 2013 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
|
||||
|
|
@ -306,10 +306,21 @@ scm_raw_ihash (SCM obj, size_t depth)
|
|||
if (SCM_IMP (obj))
|
||||
return scm_raw_ihashq (SCM_UNPACK (obj));
|
||||
|
||||
switch (SCM_TYP7(obj))
|
||||
switch (SCM_TYP3 (obj))
|
||||
{
|
||||
case scm_tc3_cons:
|
||||
if (depth)
|
||||
return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
|
||||
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
|
||||
else
|
||||
return scm_raw_ihashq (scm_tc3_cons);
|
||||
|
||||
case scm_tc3_struct:
|
||||
return scm_i_struct_hash (obj, depth);
|
||||
|
||||
case scm_tc3_heap:
|
||||
switch SCM_TYP7(obj)
|
||||
{
|
||||
/* FIXME: do better for structs, variables, ... Also the hashes
|
||||
are currently associative, which ain't the right thing. */
|
||||
case scm_tc7_smob:
|
||||
return scm_raw_ihashq (SCM_TYP16 (obj));
|
||||
case scm_tc7_number:
|
||||
|
|
@ -321,7 +332,8 @@ scm_raw_ihash (SCM obj, size_t depth)
|
|||
return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
|
||||
}
|
||||
else
|
||||
return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
|
||||
return scm_i_string_hash (scm_number_to_string (obj,
|
||||
scm_from_int (10)));
|
||||
case scm_tc7_string:
|
||||
return scm_i_string_hash (obj);
|
||||
case scm_tc7_symbol:
|
||||
|
|
@ -339,20 +351,15 @@ scm_raw_ihash (SCM obj, size_t depth)
|
|||
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
|
||||
return h;
|
||||
}
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
if (depth)
|
||||
return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
|
||||
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
|
||||
else
|
||||
return scm_raw_ihashq (scm_tc3_cons);
|
||||
case scm_tcs_struct:
|
||||
return scm_i_struct_hash (obj, depth);
|
||||
default:
|
||||
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
|
||||
}
|
||||
}
|
||||
|
||||
default:
|
||||
/* Invalid object. */
|
||||
abort ();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
|
||||
#define SCM_I_CONS(cell, x, y) \
|
||||
do { \
|
||||
cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
|
||||
cell = SCM_PACK (SCM_UNPACK (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y))) | scm_tc3_cons); \
|
||||
} while (0)
|
||||
|
||||
SCM
|
||||
|
|
|
|||
|
|
@ -875,7 +875,7 @@ static void
|
|||
scm_post_boot_init_modules ()
|
||||
{
|
||||
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
|
||||
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
|
||||
scm_module_tag = SCM_CELL_WORD_1 (module_type);
|
||||
|
||||
resolve_module_var = scm_c_lookup ("resolve-module");
|
||||
define_module_star_var = scm_c_lookup ("define-module*");
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@
|
|||
SCM_API int scm_module_system_booted_p;
|
||||
SCM_API scm_t_bits scm_module_tag;
|
||||
|
||||
#define SCM_MODULEP(OBJ) \
|
||||
(!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
|
||||
#define SCM_MODULEP(obj) \
|
||||
(SCM_STRUCTP (obj) && SCM_CELL_WORD_0 (obj) == scm_module_tag)
|
||||
|
||||
#define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module")
|
||||
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ typedef scm_t_int32 scm_t_wchar;
|
|||
#endif /* (-1 == (((-1) << 2) + 2) >> 2) */
|
||||
|
||||
|
||||
#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x))
|
||||
#define SCM_I_INUMP(x) ((SCM_UNPACK (x) & 0x3) == scm_tc2_int)
|
||||
#define SCM_I_NINUMP(x) (!SCM_I_INUMP (x))
|
||||
#define SCM_I_MAKINUM(x) \
|
||||
(SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int))
|
||||
|
|
@ -124,7 +124,8 @@ typedef scm_t_int32 scm_t_wchar;
|
|||
#define scm_tc16_fraction (scm_tc7_number + 4 * 256L)
|
||||
|
||||
#define SCM_INEXACTP(x) \
|
||||
(!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
|
||||
(SCM_HAS_TYP3 (x, scm_tc3_heap) \
|
||||
&& (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
|
||||
#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
|
||||
#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_PAIRS_H
|
||||
#define SCM_PAIRS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009, 2010, 2012, 2013 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
|
||||
|
|
@ -129,7 +129,8 @@ SCM_INLINE SCM scm_cdr (SCM x);
|
|||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_cons (SCM x, SCM y)
|
||||
{
|
||||
return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
|
||||
return SCM_PACK (SCM_UNPACK (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)))
|
||||
| scm_tc3_cons);
|
||||
}
|
||||
|
||||
SCM_INLINE_IMPLEMENTATION int
|
||||
|
|
|
|||
|
|
@ -522,8 +522,8 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
{
|
||||
switch (SCM_ITAG3 (exp))
|
||||
{
|
||||
case scm_tc3_tc7_1:
|
||||
case scm_tc3_tc7_2:
|
||||
case scm_tc3_unused_1:
|
||||
case scm_tc3_unused_2:
|
||||
/* These tc3 tags should never occur in an immediate value. They are
|
||||
* only used in cell types of non-immediates, i. e. the value returned
|
||||
* by SCM_CELL_TYPE (exp) can use these tags.
|
||||
|
|
@ -559,11 +559,14 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
scm_ipruk ("immediate", exp, port);
|
||||
}
|
||||
break;
|
||||
|
||||
case scm_tc3_cons:
|
||||
switch (SCM_TYP7 (exp))
|
||||
{
|
||||
case scm_tcs_struct:
|
||||
{
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
scm_iprlist ("(", exp, ')', port, pstate);
|
||||
EXIT_NESTED_DATA (pstate);
|
||||
break;
|
||||
|
||||
case scm_tc3_struct:
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
|
|
@ -580,17 +583,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
scm_print_struct (exp, port, pstate);
|
||||
}
|
||||
EXIT_NESTED_DATA (pstate);
|
||||
}
|
||||
break;
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
ENTER_NESTED_DATA (pstate, exp, circref);
|
||||
scm_iprlist ("(", exp, ')', port, pstate);
|
||||
EXIT_NESTED_DATA (pstate);
|
||||
break;
|
||||
circref:
|
||||
print_circref (port, pstate, exp);
|
||||
break;
|
||||
|
||||
case scm_tc3_heap:
|
||||
switch (SCM_TYP7 (exp))
|
||||
{
|
||||
case scm_tc7_number:
|
||||
switch SCM_TYP16 (exp) {
|
||||
case scm_tc16_big:
|
||||
|
|
@ -746,10 +743,18 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
EXIT_NESTED_DATA (pstate);
|
||||
break;
|
||||
default:
|
||||
/* case scm_tcs_closures: */
|
||||
punk:
|
||||
scm_ipruk ("type", exp, port);
|
||||
}
|
||||
break;
|
||||
|
||||
default:
|
||||
scm_ipruk ("unknown!", exp, port);
|
||||
break;
|
||||
|
||||
circref:
|
||||
print_circref (port, pstate, exp);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -413,7 +413,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
|
|||
static void
|
||||
struct_finalizer_trampoline (void *ptr, void *unused_data)
|
||||
{
|
||||
SCM obj = PTR2SCM (ptr);
|
||||
SCM obj = SCM_PACK (((scm_t_bits)ptr) | scm_tc3_struct);
|
||||
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
|
||||
|
||||
if (finalize)
|
||||
|
|
@ -439,7 +439,8 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
|
|||
{
|
||||
SCM ret;
|
||||
|
||||
ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2);
|
||||
ret = scm_words ((scm_t_bits)vtable_data, n_words + 2);
|
||||
ret = SCM_PACK (SCM_UNPACK (ret) | scm_tc3_struct);
|
||||
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
|
||||
|
||||
/* vtable_data can be null when making a vtable vtable */
|
||||
|
|
@ -582,7 +583,7 @@ scm_i_make_vtable_vtable (SCM user_fields)
|
|||
|
||||
obj = scm_i_alloc_struct (NULL, basic_size);
|
||||
/* 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_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj));
|
||||
|
||||
v = SCM_UNPACK (layout);
|
||||
scm_struct_init (obj, layout, 0, 1, &v);
|
||||
|
|
@ -948,16 +949,6 @@ scm_init_struct ()
|
|||
{
|
||||
SCM name;
|
||||
|
||||
/* 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);
|
||||
|
||||
/* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
|
||||
beginning of a GC-allocated region; that region is different from that of
|
||||
OBJ once OBJ has undergone class redefinition. */
|
||||
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
|
||||
|
||||
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
|
||||
scm_c_define ("standard-vtable-fields", required_vtable_fields);
|
||||
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@
|
|||
|
||||
typedef void (*scm_t_struct_finalize) (SCM obj);
|
||||
|
||||
#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
|
||||
#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_struct)
|
||||
#define SCM_STRUCT_SLOTS(X) ((SCM*)SCM_CELL_WORD_1 ((X)))
|
||||
#define SCM_STRUCT_SLOT_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
|
||||
#define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V)
|
||||
|
|
@ -147,8 +147,8 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
|
|||
|
||||
/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
|
||||
the vtable we have to do an indirection through the self slot. */
|
||||
#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
|
||||
#define SCM_STRUCT_VTABLE_SLOTS(X) ((SCM*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
|
||||
#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits*)SCM_CELL_WORD_0 (X))
|
||||
#define SCM_STRUCT_VTABLE_SLOTS(X) ((SCM*)SCM_CELL_WORD_0 (X))
|
||||
#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
|
||||
/* But often we just need to access the vtable's data; we can do that without
|
||||
the data->self->data indirection. */
|
||||
|
|
|
|||
223
libguile/tags.h
223
libguile/tags.h
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_TAGS_H
|
||||
#define SCM_TAGS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
|
||||
* Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
|
|
@ -277,63 +277,41 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
|
|||
* section with the summary of the type codes on the heap.
|
||||
*
|
||||
* tc1:
|
||||
* 0: For scheme objects, tc1==0 must be fulfilled.
|
||||
* (1: This can never be the case for a scheme object.)
|
||||
* 0: A heap object.
|
||||
* 1: An immediate object.
|
||||
*
|
||||
* tc2:
|
||||
* 00: Either a heap object or some non-integer immediate
|
||||
* (01: This can never be the case for a scheme object.)
|
||||
* 10: Small integer
|
||||
* (11: This can never be the case for a scheme object.)
|
||||
* 00: A heap object with a tag word on the heap
|
||||
* 10: A pair or a struct
|
||||
* 11: Small integer
|
||||
* 01: Some other immediate
|
||||
*
|
||||
* tc3:
|
||||
* 000: a heap object (pair, closure, class instance etc.)
|
||||
* (001: This can never be the case for a scheme object.)
|
||||
* 010: an even small integer (least significant bit is 0).
|
||||
* (011: This can never be the case for a scheme object.)
|
||||
* 100: Non-integer immediate
|
||||
* (101: This can never be the case for a scheme object.)
|
||||
* 110: an odd small integer (least significant bit is 1).
|
||||
* (111: This can never be the case for a scheme object.)
|
||||
* 000: A heap object with a tag word on the heap
|
||||
* 001: Some other immediate
|
||||
* 010: A pair
|
||||
* 011: Small integer (odd)
|
||||
* 100: (Unallocated tc3.)
|
||||
* 101: (Unallocated tc3.)
|
||||
* 110: A struct
|
||||
* 111: Small integer (even)
|
||||
*
|
||||
* The remaining bits of the heap objects form the pointer to the heap
|
||||
* cell. The remaining bits of the small integers form the integer's
|
||||
* value and sign. Thus, the only scheme objects for which a further
|
||||
* subdivision is of interest are the ones with tc3==100.
|
||||
* subdivision is of interest are the ones with tc3==001.
|
||||
*
|
||||
* tc8 (for objects with tc3==100):
|
||||
* 00000-100: special objects ('flags')
|
||||
* 00001-100: characters
|
||||
* 00010-100: unused
|
||||
* 00011-100: unused
|
||||
* tc8 (for objects with tc3==001):
|
||||
* 00000-001: special objects ('flags')
|
||||
* 00001-001: characters
|
||||
* 00010-001: unused
|
||||
* 00011-001: unused
|
||||
*
|
||||
* For heap objects with tc3==000, the remaining tag bits are to be
|
||||
* found in the first word of the object, on the heap. That tag word
|
||||
* will have a tc3 of 000.
|
||||
*
|
||||
* Summary of type codes on the heap
|
||||
*
|
||||
* Here is a summary of tagging in scm_t_bits values as they might occur in
|
||||
* the first scm_t_bits variable of a heap cell.
|
||||
*
|
||||
* tc1:
|
||||
* 0: the cell belongs to a pair.
|
||||
* 1: the cell belongs to a non-pair.
|
||||
*
|
||||
* tc2:
|
||||
* 00: the cell belongs to a pair with no short integer in its car.
|
||||
* 01: the cell belongs to a non-pair (struct or some other heap object).
|
||||
* 10: the cell belongs to a pair with a short integer in its car.
|
||||
* 11: the cell belongs to a non-pair (closure or some other heap object).
|
||||
*
|
||||
* tc3:
|
||||
* 000: the cell belongs to a pair with a heap object in its car.
|
||||
* 001: the cell belongs to a struct
|
||||
* 010: the cell belongs to a pair with an even short integer in its car.
|
||||
* 011: the cell belongs to a closure
|
||||
* 100: the cell belongs to a pair with a non-integer immediate in its car.
|
||||
* 101: the cell belongs to some other heap object.
|
||||
* 110: the cell belongs to a pair with an odd short integer in its car.
|
||||
* 111: the cell belongs to some other heap object.
|
||||
*
|
||||
* tc7 (for tc3==1x1):
|
||||
* tc7 (for tc3==000):
|
||||
* See below for the list of types. Note the special case of scm_tc7_vector
|
||||
* and scm_tc7_wvect: vectors and weak vectors are treated the same in many
|
||||
* cases. Thus, their tc7-codes are chosen to only differ in one bit. This
|
||||
|
|
@ -348,18 +326,53 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
|
|||
* predefined way, since smobs can be added arbitrarily by user C code.
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
||||
/* Checking if a SCM variable holds an immediate or a heap object:
|
||||
* This check can either be performed by checking for tc3==000 or tc3==00x,
|
||||
* since for a SCM variable it is known that tc1==0. */
|
||||
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
|
||||
/* Checking if a SCM variable holds an immediate or a heap object: This
|
||||
* check can either be performed by checking for values with 1 as their
|
||||
* least significant bit. */
|
||||
#define SCM_IMP(x) (1 & SCM_UNPACK (x))
|
||||
#define SCM_NIMP(x) (!SCM_IMP (x))
|
||||
#define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x))
|
||||
|
||||
|
||||
|
||||
|
||||
/* Definitions for tc2: */
|
||||
|
||||
#define scm_tc2_int 3
|
||||
|
||||
|
||||
/* Definitions for tc3: */
|
||||
|
||||
#define SCM_TYP3(x) (7 & SCM_UNPACK (x))
|
||||
#define SCM_ITAG3(x) (SCM_TYP3 (x))
|
||||
#define SCM_HAS_TYP3(x, tag) (SCM_TYP3 (x) == (tag))
|
||||
|
||||
#define scm_tc3_heap 0
|
||||
#define scm_tc3_imm24 1
|
||||
#define scm_tc3_cons 2
|
||||
#define scm_tc3_int_1 (scm_tc2_int + 0)
|
||||
#define scm_tc3_unused_1 4
|
||||
#define scm_tc3_unused_2 5
|
||||
#define scm_tc3_struct 6
|
||||
#define scm_tc3_int_2 (scm_tc2_int + 4)
|
||||
|
||||
|
||||
/* Checking if a SCM variable holds an immediate integer: See numbers.h for
|
||||
* the definition of the following macros: SCM_I_FIXNUM_BIT,
|
||||
* SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */
|
||||
the definition of the following macros: SCM_I_FIXNUM_BIT,
|
||||
SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */
|
||||
|
||||
/* As we have seen, heap objects can have 0, 2, or 6 in their three
|
||||
lowest bits. If you have a heap object and want the pointer to the
|
||||
start of the object, perhaps for GC purposes, you need to mask off
|
||||
the low bits, which is what SCM_HEAP_OBJECT_BASE does.
|
||||
|
||||
Note that you can avoid this macro if you know the specific type of
|
||||
the object (pair, struct, or other).
|
||||
*/
|
||||
#define SCM_HEAP_OBJECT_BASE(x) ((scm_t_bits*)((SCM_UNPACK (x)) & ~7))
|
||||
|
||||
/* Checking if a SCM variable holds a pair (for historical reasons, in Guile
|
||||
* also known as a cons-cell): This is done by first checking that the SCM
|
||||
|
|
@ -367,39 +380,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
|
|||
* for the SCM_CELL_TYPE of the SCM variable.
|
||||
*/
|
||||
|
||||
#define SCM_I_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
|
||||
|
||||
|
||||
|
||||
/* Definitions for tc2: */
|
||||
|
||||
#define scm_tc2_int 2
|
||||
|
||||
|
||||
/* Definitions for tc3: */
|
||||
|
||||
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
|
||||
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
|
||||
|
||||
#define scm_tc3_cons 0
|
||||
#define scm_tc3_struct 1
|
||||
#define scm_tc3_int_1 (scm_tc2_int + 0)
|
||||
#define scm_tc3_unused 3
|
||||
#define scm_tc3_imm24 4
|
||||
#define scm_tc3_tc7_1 5
|
||||
#define scm_tc3_int_2 (scm_tc2_int + 4)
|
||||
#define scm_tc3_tc7_2 7
|
||||
|
||||
|
||||
/* As we have seen, heap objects have a tag in their three lowest bits.
|
||||
If you have a heap object and want the pointer to the start of the
|
||||
object, perhaps for GC purposes, you need to mask off the low bits,
|
||||
which is what SCM_HEAP_OBJECT_BASE does.
|
||||
|
||||
Note that you can avoid this macro if you know the specific type of
|
||||
the object (pair, struct, or other).
|
||||
*/
|
||||
#define SCM_HEAP_OBJECT_BASE(x) ((scm_t_bits*)((SCM_UNPACK (x)) & ~7))
|
||||
#define SCM_I_CONSP(x) (SCM_HAS_TYP3 (x, scm_tc3_cons))
|
||||
|
||||
|
||||
/* Definitions for tc7: */
|
||||
|
|
@ -408,7 +389,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
|
|||
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
|
||||
#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CELL_TYPE (x))
|
||||
#define SCM_HAS_HEAP_TYPE(x, type, tag) \
|
||||
(SCM_NIMP (x) && type (x) == (tag))
|
||||
(SCM_HAS_TYP3 (x, scm_tc3_heap) && type (x) == (tag))
|
||||
#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
|
||||
#define SCM_HAS_TYP7S(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7S, tag))
|
||||
|
||||
|
|
@ -610,74 +591,6 @@ enum scm_tc8_tags
|
|||
#endif /* BUILDING_LIBGUILE */
|
||||
|
||||
|
||||
/* Dispatching aids:
|
||||
|
||||
When switching on SCM_TYP7 of a SCM value, use these fake case
|
||||
labels to catch types that use fewer than 7 bits for tagging. */
|
||||
|
||||
/* For cons pairs with immediate values in the CAR
|
||||
*/
|
||||
|
||||
#define scm_tcs_cons_imcar \
|
||||
scm_tc2_int + 0: case scm_tc2_int + 4: case scm_tc3_imm24 + 0:\
|
||||
case scm_tc2_int + 8: case scm_tc2_int + 12: case scm_tc3_imm24 + 8:\
|
||||
case scm_tc2_int + 16: case scm_tc2_int + 20: case scm_tc3_imm24 + 16:\
|
||||
case scm_tc2_int + 24: case scm_tc2_int + 28: case scm_tc3_imm24 + 24:\
|
||||
case scm_tc2_int + 32: case scm_tc2_int + 36: case scm_tc3_imm24 + 32:\
|
||||
case scm_tc2_int + 40: case scm_tc2_int + 44: case scm_tc3_imm24 + 40:\
|
||||
case scm_tc2_int + 48: case scm_tc2_int + 52: case scm_tc3_imm24 + 48:\
|
||||
case scm_tc2_int + 56: case scm_tc2_int + 60: case scm_tc3_imm24 + 56:\
|
||||
case scm_tc2_int + 64: case scm_tc2_int + 68: case scm_tc3_imm24 + 64:\
|
||||
case scm_tc2_int + 72: case scm_tc2_int + 76: case scm_tc3_imm24 + 72:\
|
||||
case scm_tc2_int + 80: case scm_tc2_int + 84: case scm_tc3_imm24 + 80:\
|
||||
case scm_tc2_int + 88: case scm_tc2_int + 92: case scm_tc3_imm24 + 88:\
|
||||
case scm_tc2_int + 96: case scm_tc2_int + 100: case scm_tc3_imm24 + 96:\
|
||||
case scm_tc2_int + 104: case scm_tc2_int + 108: case scm_tc3_imm24 + 104:\
|
||||
case scm_tc2_int + 112: case scm_tc2_int + 116: case scm_tc3_imm24 + 112:\
|
||||
case scm_tc2_int + 120: case scm_tc2_int + 124: case scm_tc3_imm24 + 120
|
||||
|
||||
/* For cons pairs with heap objects in the SCM_CAR
|
||||
*/
|
||||
#define scm_tcs_cons_nimcar \
|
||||
scm_tc3_cons + 0:\
|
||||
case scm_tc3_cons + 8:\
|
||||
case scm_tc3_cons + 16:\
|
||||
case scm_tc3_cons + 24:\
|
||||
case scm_tc3_cons + 32:\
|
||||
case scm_tc3_cons + 40:\
|
||||
case scm_tc3_cons + 48:\
|
||||
case scm_tc3_cons + 56:\
|
||||
case scm_tc3_cons + 64:\
|
||||
case scm_tc3_cons + 72:\
|
||||
case scm_tc3_cons + 80:\
|
||||
case scm_tc3_cons + 88:\
|
||||
case scm_tc3_cons + 96:\
|
||||
case scm_tc3_cons + 104:\
|
||||
case scm_tc3_cons + 112:\
|
||||
case scm_tc3_cons + 120
|
||||
|
||||
/* For structs
|
||||
*/
|
||||
#define scm_tcs_struct \
|
||||
scm_tc3_struct + 0:\
|
||||
case scm_tc3_struct + 8:\
|
||||
case scm_tc3_struct + 16:\
|
||||
case scm_tc3_struct + 24:\
|
||||
case scm_tc3_struct + 32:\
|
||||
case scm_tc3_struct + 40:\
|
||||
case scm_tc3_struct + 48:\
|
||||
case scm_tc3_struct + 56:\
|
||||
case scm_tc3_struct + 64:\
|
||||
case scm_tc3_struct + 72:\
|
||||
case scm_tc3_struct + 80:\
|
||||
case scm_tc3_struct + 88:\
|
||||
case scm_tc3_struct + 96:\
|
||||
case scm_tc3_struct + 104:\
|
||||
case scm_tc3_struct + 112:\
|
||||
case scm_tc3_struct + 120
|
||||
|
||||
|
||||
|
||||
#endif /* SCM_TAGS_H */
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -308,7 +308,7 @@
|
|||
#define CONS(x,y,z) \
|
||||
{ \
|
||||
SYNC_BEFORE_GC (); \
|
||||
x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \
|
||||
x = SCM_PACK (SCM_UNPACK (scm_cell (SCM_UNPACK (y), SCM_UNPACK (z))) | scm_tc3_cons); \
|
||||
}
|
||||
|
||||
/* Pop the N objects on top of the stack and push a list that contains
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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
|
||||
|
|
@ -592,8 +592,8 @@ VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
|
|||
{
|
||||
/* Verily, we are making a simple struct with the right number of
|
||||
initializers, and no finalizer. */
|
||||
ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
|
||||
n + 1);
|
||||
ret = scm_words ((scm_t_bits) SCM_STRUCT_DATA (vtable), n + 1);
|
||||
ret = SCM_PACK (SCM_UNPACK (ret) | scm_tc3_struct);
|
||||
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
|
||||
memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -103,10 +103,10 @@
|
|||
(define (least-fixnum) most-negative-fixnum)
|
||||
|
||||
(define (fixnum? obj)
|
||||
(not (= 0 (logand 2 (object-address obj)))))
|
||||
(eqv? #b11 (logand #b11 (object-address obj))))
|
||||
|
||||
(define-inlinable (inline-fixnum? obj)
|
||||
(not (= 0 (logand 2 (object-address obj)))))
|
||||
(eqv? #b11 (logand #b11 (object-address obj))))
|
||||
|
||||
(define-syntax assert-fixnum
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue