[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/07: WIP: New tagging v8
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 04/07: WIP: New tagging v8 |
|
Date: |
Thu, 6 Jun 2019 05:37:14 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit 87f32999b939669ba561787f8357f13895a9248e
Author: Mark H Weaver <address@hidden>
Date: Mon Jun 3 07:30:25 2019 -0400
WIP: New tagging v8
---
libguile/array-handle.c | 12 +-
libguile/array-map.c | 4 +-
libguile/arrays.c | 2 +-
libguile/arrays.h | 2 +-
libguile/atomic.c | 2 +-
libguile/atomic.h | 2 +-
libguile/bitvectors.c | 10 +-
libguile/bytevectors.h | 14 +-
libguile/continuations.c | 2 +-
libguile/control.c | 2 +-
libguile/eq.c | 24 +--
libguile/eval.h | 9 --
libguile/evalext.c | 47 +++---
libguile/fluids.c | 10 +-
libguile/fluids.h | 2 +-
libguile/foreign.c | 6 +-
libguile/foreign.h | 6 +-
libguile/frames.c | 2 +-
libguile/frames.h | 4 +-
libguile/gc.c | 2 +-
libguile/generalized-arrays.c | 12 +-
libguile/goops.c | 54 +++----
libguile/gsubr.c | 2 +-
libguile/hash.c | 36 +++--
libguile/hashtab.c | 2 +-
libguile/hashtab.h | 2 +-
libguile/jit.c | 62 ++++----
libguile/keywords.c | 4 +-
libguile/modules.c | 2 +-
libguile/numbers.h | 43 ++---
libguile/ports.c | 2 +-
libguile/ports.h | 14 +-
libguile/print.c | 78 +++++-----
libguile/programs.h | 18 +--
libguile/scm.h | 242 +++++++++++++++--------------
libguile/strings.c | 14 +-
libguile/strings.h | 12 +-
libguile/struct.c | 17 +-
libguile/struct.h | 4 +-
libguile/symbols.h | 4 +-
libguile/syntax.c | 4 +-
libguile/values.c | 10 +-
libguile/values.h | 4 +-
libguile/variable.c | 2 +-
libguile/variable.h | 2 +-
libguile/vectors.c | 2 +-
libguile/vectors.h | 15 +-
libguile/vm-engine.c | 4 +-
libguile/vm.c | 6 +-
libguile/vm.h | 2 +-
libguile/weak-set.c | 4 +-
libguile/weak-table.c | 4 +-
libguile/weak-vector.c | 2 +-
libguile/weak-vector.h | 2 +-
module/language/cps/closure-conversion.scm | 4 +-
module/language/cps/compile-bytecode.scm | 10 +-
module/language/tree-il/compile-cps.scm | 44 ++++--
module/language/tree-il/cps-primitives.scm | 4 +
module/system/base/target.scm | 20 ++-
module/system/base/types.scm | 138 +++++++++-------
module/system/base/types/internal.scm | 230 +++++++++++++++------------
module/system/vm/assembler.scm | 86 +++++-----
62 files changed, 739 insertions(+), 648 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 4b69e67..c4b2f3b 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -175,30 +175,30 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
h->array = array;
- switch (SCM_TYP7 (array))
+ switch (SCM_TYP11 (array))
{
- case scm_tc7_string:
+ case scm_tc11_string:
initialize_vector_handle (h, scm_c_string_length (array),
SCM_ARRAY_ELEMENT_TYPE_CHAR,
scm_c_string_ref, scm_c_string_set_x,
NULL,
scm_i_string_is_mutable (array));
break;
- case scm_tc7_vector:
+ case scm_tc11_vector:
initialize_vector_handle (h, scm_c_vector_length (array),
SCM_ARRAY_ELEMENT_TYPE_SCM,
scm_c_vector_ref, scm_c_vector_set_x,
SCM_I_VECTOR_WELTS (array),
SCM_I_IS_MUTABLE_VECTOR (array));
break;
- case scm_tc7_bitvector:
+ case scm_tc11_bitvector:
initialize_vector_handle (h, scm_c_bitvector_length (array),
SCM_ARRAY_ELEMENT_TYPE_BIT,
scm_c_bitvector_ref, scm_c_bitvector_set_x,
scm_i_bitvector_bits (array),
scm_i_is_mutable_bitvector (array));
break;
- case scm_tc7_bytevector:
+ case scm_tc11_bytevector:
{
size_t length;
scm_t_array_element_type element_type;
@@ -244,7 +244,7 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
SCM_MUTABLE_BYTEVECTOR_P (array));
}
break;
- case scm_tc7_array:
+ case scm_tc11_array:
scm_array_get_handle (SCM_I_ARRAY_V (array), h);
h->array = array;
h->base = SCM_I_ARRAY_BASE (array);
diff --git a/libguile/array-map.c b/libguile/array-map.c
index a76d8fc..62e9b4f 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -479,7 +479,7 @@ array_index_map_1 (SCM ra, SCM proc)
scm_array_handle_release (&h);
}
-/* Here we assume that the array is a scm_tc7_array, as that is the only
+/* Here we assume that the array is a scm_tc11_array, as that is the only
kind of array in Guile that supports rank > 1. */
static void
array_index_map_n (SCM ra, SCM proc)
@@ -656,7 +656,7 @@ SCM
scm_i_array_rebase (SCM a, size_t base)
{
size_t ndim = SCM_I_ARRAY_NDIM (a);
- SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc11_array, 3 + ndim*3);
SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
/* FIXME do check base */
SCM_I_ARRAY_SET_BASE (b, base);
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 0a91951..856acf6 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -138,7 +138,7 @@ verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits));
SCM
scm_i_make_array (int ndim)
{
- SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc11_array, 3 + ndim*3);
SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
SCM_I_ARRAY_SET_BASE (ra, 0);
/* dimensions are unset */
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 7221fdb..9401e0a 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -66,7 +66,7 @@ SCM_API SCM scm_array_rank (SCM ra);
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) &
~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
+#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc11_array, a)
/* XXXX Why not SCM_TYP11_PREDICATE?? */
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) &
(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))
diff --git a/libguile/atomic.c b/libguile/atomic.c
index adb2a0c..d221103 100644
--- a/libguile/atomic.c
+++ b/libguile/atomic.c
@@ -41,7 +41,7 @@ SCM_DEFINE (scm_make_atomic_box, "make-atomic-box", 1, 0, 0,
"Return an atomic box initialized to value @var{init}.")
#define FUNC_NAME s_scm_make_atomic_box
{
- SCM ret = scm_cell (scm_tc7_atomic_box, SCM_UNPACK (SCM_UNDEFINED));
+ SCM ret = scm_cell (scm_tc11_atomic_box, SCM_UNPACK (SCM_UNDEFINED));
scm_atomic_box_set_x (ret, init);
return ret;
}
diff --git a/libguile/atomic.h b/libguile/atomic.h
index 7bf3cae..1846cd3 100644
--- a/libguile/atomic.h
+++ b/libguile/atomic.h
@@ -29,7 +29,7 @@
static inline int
scm_is_atomic_box (SCM obj)
{
- return SCM_HAS_TYP7 (obj, scm_tc7_atomic_box);
+ return SCM_HAS_TYP11 (obj, scm_tc11_atomic_box);
}
static inline SCM*
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 0bb4c1f..83dfa0e 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -44,13 +44,13 @@
* but alack, all we have is this crufty C.
*/
-#define SCM_F_BITVECTOR_IMMUTABLE (0x80)
+#define SCM_F_BITVECTOR_IMMUTABLE (0x800)
-#define IS_BITVECTOR(obj) SCM_HAS_TYP7 ((obj), scm_tc7_bitvector)
+#define IS_BITVECTOR(obj) SCM_HAS_TYP11 ((obj), scm_tc11_bitvector)
#define IS_MUTABLE_BITVECTOR(x) \
(SCM_NIMP (x) && \
- ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \
- == scm_tc7_bitvector))
+ ((SCM_CELL_TYPE (x) & (0x7ff | SCM_F_BITVECTOR_IMMUTABLE)) \
+ == scm_tc11_bitvector))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))
#define BITVECTOR_BITS(obj) ((uint32_t *)SCM_CELL_WORD_2(obj))
@@ -136,7 +136,7 @@ scm_c_make_bitvector (size_t len, SCM fill)
bits = scm_gc_malloc_pointerless (sizeof (uint32_t) * word_len,
"bitvector");
- res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0);
+ res = scm_double_cell (scm_tc11_bitvector, len, (scm_t_bits)bits, 0);
if (!SCM_UNBNDP (fill))
scm_bitvector_fill_x (res, fill);
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 980d6e2..fe9c0b4 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -121,20 +121,20 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
/* Internal API. */
#define SCM_BYTEVECTOR_P(x) \
- (SCM_HAS_TYP7 (x, scm_tc7_bytevector))
+ (SCM_HAS_TYP11 (x, scm_tc11_bytevector))
#define SCM_BYTEVECTOR_FLAGS(_bv) \
- (SCM_CELL_TYPE (_bv) >> 7UL)
+ (SCM_CELL_TYPE (_bv) >> 11UL)
#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f) \
SCM_SET_CELL_TYPE ((_bv), \
- scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL))
+ scm_tc11_bytevector | ((scm_t_bits)(_f) << 11UL))
#define SCM_F_BYTEVECTOR_CONTIGUOUS 0x100UL
#define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL
-#define SCM_MUTABLE_BYTEVECTOR_P(x) \
- (SCM_NIMP (x) && \
- ((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \
- == scm_tc7_bytevector))
+#define SCM_MUTABLE_BYTEVECTOR_P(x) \
+ (SCM_NIMP (x) && \
+ ((SCM_CELL_TYPE (x) & (0x7ffUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 11UL))) \
+ == scm_tc11_bytevector))
#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 3f86c6b..1980ac6 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -103,7 +103,7 @@ make_continuation_trampoline (SCM contregs)
scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ ret = scm_words (scm_tc11_program | (nfree << 20) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, goto_continuation_code.code);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
diff --git a/libguile/control.c b/libguile/control.c
index 5e24bb7..b57fb31 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -97,7 +97,7 @@ scm_i_make_composable_continuation (SCM vmcont)
scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
SCM ret;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ ret = scm_words (scm_tc11_program | (nfree << 20) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, compose_continuation_code.code);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont);
diff --git a/libguile/eq.c b/libguile/eq.c
index 627d6f0..ec4ce76 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -224,11 +224,11 @@ SCM scm_eqv_p (SCM x, SCM y)
/* this ensures that types and scm_length are the same. */
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
return SCM_BOOL_F;
- switch (SCM_TYP7 (x))
+ switch (SCM_TYP11 (x))
{
default:
break;
- case scm_tc7_number:
+ case scm_tc11_number:
return scm_from_bool (scm_i_heap_numbers_equal_p (x, y));
}
return SCM_BOOL_F;
@@ -332,7 +332,7 @@ scm_equal_p (SCM x, SCM y)
return SCM_BOOL_F;
}
- switch (SCM_TYP7 (x))
+ switch (SCM_TYP11 (x))
{
default:
/* Check equality between structs of equal type (see cell-type test
above). */
@@ -344,7 +344,7 @@ scm_equal_p (SCM x, SCM y)
return scm_i_struct_equalp (x, y);
}
break;
- case scm_tc7_number:
+ case scm_tc11_number:
switch SCM_TYP16 (x)
{
case scm_tc16_big:
@@ -359,20 +359,20 @@ scm_equal_p (SCM x, SCM y)
/* assert not reached? */
return SCM_BOOL_F;
}
- case scm_tc7_pointer:
+ case scm_tc11_pointer:
return scm_from_bool (SCM_POINTER_VALUE (x) == SCM_POINTER_VALUE (y));
- case scm_tc7_string:
+ case scm_tc11_string:
return scm_string_equal_p (x, y);
- case scm_tc7_bytevector:
+ case scm_tc11_bytevector:
return scm_bytevector_eq_p (x, y);
- case scm_tc7_array:
+ case scm_tc11_array:
return scm_array_equal_p (x, y);
- case scm_tc7_bitvector:
+ case scm_tc11_bitvector:
return scm_i_bitvector_equal_p (x, y);
- case scm_tc7_vector:
- case scm_tc7_wvect:
+ case scm_tc11_vector:
+ case scm_tc11_wvect:
return scm_i_vector_equal_p (x, y);
- case scm_tc7_syntax:
+ case scm_tc11_syntax:
if (scm_is_false (scm_equal_p (scm_syntax_wrap (x),
scm_syntax_wrap (y))))
return SCM_BOOL_F;
diff --git a/libguile/eval.h b/libguile/eval.h
index b25e76f..6987399 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -33,15 +33,6 @@
-/* {Ilocs}
- *
- * Ilocs are relative pointers into local environment structures.
- *
- */
-#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc)
-
-
-
/* {Evaluator}
*/
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 4ac4343..a9366f6 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -66,35 +66,34 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1,
0, 0,
{
switch (SCM_ITAG3 (obj))
{
- case scm_tc3_int_1:
- case scm_tc3_int_2:
- /* inum */
+ case scm_tcs_fixnums:
+ /* immediate numbers */
return SCM_BOOL_T;
case scm_tc3_imm24:
- /* characters, booleans, other immediates */
+ /* characters, booleans, other immediates */
return scm_from_bool (!scm_is_null_and_not_nil (obj));
case scm_tc3_cons:
- switch (SCM_TYP7 (obj))
+ switch (SCM_TYP11 (obj))
{
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_pointer:
- case scm_tc7_hashtable:
- case scm_tc7_weak_set:
- case scm_tc7_weak_table:
- case scm_tc7_fluid:
- case scm_tc7_dynamic_state:
- case scm_tc7_frame:
- case scm_tc7_keyword:
- case scm_tc7_syntax:
- case scm_tc7_vm_cont:
- case scm_tc7_number:
- case scm_tc7_string:
- case scm_tc7_smob:
- case scm_tc7_program:
- case scm_tc7_bytevector:
- case scm_tc7_array:
- case scm_tc7_bitvector:
+ case scm_tc11_vector:
+ case scm_tc11_wvect:
+ case scm_tc11_pointer:
+ case scm_tc11_hashtable:
+ case scm_tc11_weak_set:
+ case scm_tc11_weak_table:
+ case scm_tc11_fluid:
+ case scm_tc11_dynamic_state:
+ case scm_tc11_frame:
+ case scm_tc11_keyword:
+ case scm_tc11_syntax:
+ case scm_tc11_vm_cont:
+ case scm_tc11_number:
+ case scm_tc11_string:
+ case scm_tc11_program:
+ case scm_tc11_bytevector:
+ case scm_tc11_array:
+ case scm_tc11_bitvector:
+ case scm_tcs_smob:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/fluids.c b/libguile/fluids.c
index f626933..0898a0e 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -98,14 +98,14 @@
table could share more state, as in an immutable weak array-mapped
hash trie or something, but we don't have such a data structure. */
-#define FLUID_F_THREAD_LOCAL 0x100
+#define FLUID_F_THREAD_LOCAL 0x1000
#define SCM_I_FLUID_THREAD_LOCAL_P(x) \
(SCM_CELL_WORD_0 (x) & FLUID_F_THREAD_LOCAL)
static inline int
is_dynamic_state (SCM x)
{
- return SCM_HAS_TYP7 (x, scm_tc7_dynamic_state);
+ return SCM_HAS_TYP11 (x, scm_tc11_dynamic_state);
}
static inline SCM
@@ -225,7 +225,7 @@ scm_i_dynamic_state_print (SCM exp, SCM port,
scm_print_state *pstate SCM_UNUSED
static SCM
new_fluid (SCM init, scm_t_bits flags)
{
- return scm_cell (scm_tc7_fluid | flags, SCM_UNPACK (init));
+ return scm_cell (scm_tc11_fluid | flags, SCM_UNPACK (init));
}
SCM
@@ -585,7 +585,7 @@ scm_dynwind_fluid (SCM fluid, SCM value)
SCM
scm_i_make_initial_dynamic_state (void)
{
- return scm_cell (scm_tc7_dynamic_state,
+ return scm_cell (scm_tc11_dynamic_state,
SCM_UNPACK (scm_c_make_weak_table
(0, SCM_WEAK_TABLE_KIND_KEY)));
}
@@ -613,7 +613,7 @@ SCM_DEFINE (scm_current_dynamic_state,
"current-dynamic-state", 0, 0, 0,
#define FUNC_NAME s_scm_current_dynamic_state
{
struct scm_dynamic_state *state = SCM_I_CURRENT_THREAD->dynamic_state;
- return scm_cell (scm_tc7_dynamic_state,
+ return scm_cell (scm_tc11_dynamic_state,
SCM_UNPACK (save_dynamic_state (state)));
}
#undef FUNC_NAME
diff --git a/libguile/fluids.h b/libguile/fluids.h
index ffcb489..c16dda8 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -36,7 +36,7 @@
dynamic state, you can use fluids for thread local storage.
*/
-#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
+#define SCM_FLUID_P(x) (SCM_HAS_TYP11 (x, scm_tc11_fluid))
#define SCM_VALIDATE_FLUID(pos, fluid) \
SCM_I_MAKE_VALIDATE_MSG2 (pos, fluid, scm_is_fluid, "fluid")
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 1368cc9..206c2a5 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -173,7 +173,7 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer
finalizer)
ret = null_pointer;
else
{
- ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
+ ret = scm_cell (scm_tc11_pointer, (scm_t_bits) ptr);
if (finalizer)
scm_i_set_finalizer (SCM2PTR (ret), pointer_finalizer_trampoline,
@@ -860,7 +860,7 @@ cif_to_procedure (SCM cif, SCM func_ptr, int with_errno)
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ ret = scm_words (scm_tc11_program | (nfree << 20) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
@@ -1295,7 +1295,7 @@ scm_init_foreign (void)
#endif
);
- null_pointer = scm_cell (scm_tc7_pointer, 0);
+ null_pointer = scm_cell (scm_tc11_pointer, 0);
scm_define (sym_null, null_pointer);
}
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 41f26b3..b264ed9 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -25,7 +25,7 @@
/* A "foreign pointer" is a wrapped C pointer. It is represented by a
cell whose second word is a pointer. The first word has the
- `scm_tc7_pointer' type code.
+ `scm_tc11_pointer' type code.
The basic idea is that we can help the programmer to avoid cutting herself,
but we won't take away her knives. */
@@ -50,14 +50,14 @@ typedef enum scm_t_foreign_type scm_t_foreign_type;
typedef void (*scm_t_pointer_finalizer) (void *);
-#define SCM_POINTER_P(x) (SCM_HAS_TYP7 (x, scm_tc7_pointer))
+#define SCM_POINTER_P(x) (SCM_HAS_TYP11 (x, scm_tc11_pointer))
#define SCM_VALIDATE_POINTER(pos, x) \
SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_POINTER_VALUE(x) \
((void *) SCM_CELL_WORD_1 (x))
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
- SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
+ SCM_IMMUTABLE_CELL (c_name, scm_tc11_pointer, ptr)
SCM_API void *scm_to_pointer (SCM pointer);
SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);
diff --git a/libguile/frames.c b/libguile/frames.c
index 0bb4057..ef73961 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -51,7 +51,7 @@ scm_c_make_frame (enum scm_vm_frame_kind kind, const struct
scm_frame *frame)
p->fp_offset = frame->fp_offset;
p->sp_offset = frame->sp_offset;
p->ip = frame->ip;
- return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
+ return scm_cell (scm_tc11_frame | (kind << 12), (scm_t_bits)p);
}
void
diff --git a/libguile/frames.h b/libguile/frames.h
index 76055f5..62cae31 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -133,8 +133,8 @@ enum scm_vm_frame_kind
SCM_VM_FRAME_KIND_CONT
};
-#define SCM_VM_FRAME_P(x) (SCM_HAS_TYP7 (x, scm_tc7_frame))
-#define SCM_VM_FRAME_KIND(x) ((enum scm_vm_frame_kind) (SCM_CELL_WORD_0 (x)
>> 8))
+#define SCM_VM_FRAME_P(x) (SCM_HAS_TYP11 (x, scm_tc11_frame))
+#define SCM_VM_FRAME_KIND(x) ((enum scm_vm_frame_kind) (SCM_CELL_WORD_0 (x)
>> 12))
#define SCM_VM_FRAME_DATA(x) ((struct scm_frame *)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA (f)->stack_holder
#define SCM_VM_FRAME_FP_OFFSET(f) SCM_VM_FRAME_DATA (f)->fp_offset
diff --git a/libguile/gc.c b/libguile/gc.c
index 5bbe1d9..5c31c24 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -479,7 +479,7 @@ scm_storage_prehistory ()
higher bits of the type tag are used to store a pointer (that is, a
pointer to an 8-octet aligned region). */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
- GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
+ GC_REGISTER_DISPLACEMENT (scm_tc5_struct);
/* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 28ca6b3..3b428b6 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -49,13 +49,13 @@ scm_is_array (SCM obj)
if (!SCM_HEAP_OBJECT_P (obj))
return 0;
- switch (SCM_TYP7 (obj))
+ switch (SCM_TYP11 (obj))
{
- case scm_tc7_string:
- case scm_tc7_vector:
- case scm_tc7_bitvector:
- case scm_tc7_bytevector:
- case scm_tc7_array:
+ case scm_tc11_string:
+ case scm_tc11_vector:
+ case scm_tc11_bitvector:
+ case scm_tc11_bytevector:
+ case scm_tc11_array:
return 1;
default:
return 0;
diff --git a/libguile/goops.c b/libguile/goops.c
index fd312a8..17160d4 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -205,8 +205,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
{
switch (SCM_ITAG3 (x))
{
- case scm_tc3_int_1:
- case scm_tc3_int_2:
+ case scm_tcs_fixnums:
return class_integer;
case scm_tc3_imm24:
@@ -220,45 +219,43 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_unknown;
case scm_tc3_cons:
- switch (SCM_TYP7 (x))
+ switch (SCM_TYP11 (x))
{
- case scm_tcs_cons_nimcar:
- return class_pair;
- case scm_tc7_symbol:
+ case scm_tc11_symbol:
return class_symbol;
- case scm_tc7_vector:
- case scm_tc7_wvect:
+ case scm_tc11_vector:
+ case scm_tc11_wvect:
return class_vector;
- case scm_tc7_pointer:
+ case scm_tc11_pointer:
return class_foreign;
- case scm_tc7_hashtable:
+ case scm_tc11_hashtable:
return class_hashtable;
- case scm_tc7_fluid:
+ case scm_tc11_fluid:
return class_fluid;
- case scm_tc7_dynamic_state:
+ case scm_tc11_dynamic_state:
return class_dynamic_state;
- case scm_tc7_frame:
+ case scm_tc11_frame:
return class_frame;
- case scm_tc7_keyword:
+ case scm_tc11_keyword:
return class_keyword;
- case scm_tc7_syntax:
+ case scm_tc11_syntax:
return class_syntax;
- case scm_tc7_atomic_box:
+ case scm_tc11_atomic_box:
return class_atomic_box;
- case scm_tc7_vm_cont:
+ case scm_tc11_vm_cont:
return class_vm_cont;
- case scm_tc7_bytevector:
+ case scm_tc11_bytevector:
if (SCM_BYTEVECTOR_ELEMENT_TYPE (x) == SCM_ARRAY_ELEMENT_TYPE_VU8)
return class_bytevector;
else
return class_uvec;
- case scm_tc7_array:
+ case scm_tc11_array:
return class_array;
- case scm_tc7_bitvector:
+ case scm_tc11_bitvector:
return class_bitvector;
- case scm_tc7_string:
+ case scm_tc11_string:
return class_string;
- case scm_tc7_number:
+ case scm_tc11_number:
switch SCM_TYP16 (x) {
case scm_tc16_big:
return class_integer;
@@ -269,14 +266,14 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return class_fraction;
}
- case scm_tc7_program:
+ case scm_tc11_program:
if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
&& SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
return class_primitive_generic;
else
return class_procedure;
- case scm_tc7_smob:
+ case scm_tcs_smob:
{
scm_t_bits type = SCM_TYP16 (x);
if (type != scm_tc16_port_with_ps)
@@ -284,7 +281,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
x = SCM_PORT_WITH_PS_PORT (x);
/* fall through to ports */
}
- case scm_tc7_port:
+ case scm_tc11_port:
{
scm_t_port_type *ptob = SCM_PORT_TYPE (x);
if (SCM_INPUT_PORT_P (x))
@@ -330,13 +327,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
return class_unknown;
}
-
- case scm_tc3_struct:
- case scm_tc3_tc7_1:
- case scm_tc3_tc7_2:
- /* case scm_tc3_unused: */
- /* Never reached */
- break;
}
return class_unknown;
}
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index b99cc67..3eb0cff 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -345,7 +345,7 @@ create_subr (int define, const char *name,
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ ret = scm_words (scm_tc11_program | (nfree << 20) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (idx, nreq, nopt, rest));
record_subr_name (idx, sname);
if (generic_loc)
diff --git a/libguile/hash.c b/libguile/hash.c
index d6e93da..deefeb2 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -287,13 +287,13 @@ 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_TYP11(obj))
{
/* FIXME: do better for structs, variables, ... Also the hashes
are currently associative, which ain't the right thing. */
- case scm_tc7_smob:
+ case scm_tcs_smob:
return scm_raw_ihashq (SCM_TYP16 (obj));
- case scm_tc7_number:
+ case scm_tc11_number:
if (scm_is_integer (obj))
{
SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
@@ -303,14 +303,14 @@ scm_raw_ihash (SCM obj, size_t depth)
}
else
return scm_i_string_hash (scm_number_to_string (obj, scm_from_int
(10)));
- case scm_tc7_string:
+ case scm_tc11_string:
return scm_i_string_hash (obj);
- case scm_tc7_symbol:
+ case scm_tc11_symbol:
return scm_i_symbol_hash (obj);
- case scm_tc7_pointer:
+ case scm_tc11_pointer:
return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj));
- case scm_tc7_wvect:
- case scm_tc7_vector:
+ case scm_tc11_wvect:
+ case scm_tc11_vector:
{
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
size_t i = depth / 2;
@@ -320,7 +320,7 @@ scm_raw_ihash (SCM obj, size_t depth)
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
return h;
}
- case scm_tc7_syntax:
+ case scm_tc11_syntax:
{
unsigned long h;
h = scm_raw_ihash (scm_syntax_expression (obj), depth);
@@ -328,17 +328,19 @@ scm_raw_ihash (SCM obj, size_t depth)
h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
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));
+ if (scm_is_pair (obj))
+ {
+ if (depth)
+ return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
+ ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
+ else
+ return scm_raw_ihashq (0);
+ }
+ else
+ return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index b4f004c..ce08961 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -97,7 +97,7 @@ make_hash_table (unsigned long k, const char *func_name)
t->upper = 9 * n / 10;
/* FIXME: we just need two words of storage, not three */
- return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
+ return scm_double_cell (scm_tc11_hashtable, SCM_UNPACK (vector),
(scm_t_bits)t, 0);
}
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 61e81b3..43e33f8 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -26,7 +26,7 @@
-#define SCM_HASHTABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_hashtable))
+#define SCM_HASHTABLE_P(x) (SCM_HAS_TYP11 (x, scm_tc11_hashtable))
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
#define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h)
diff --git a/libguile/jit.c b/libguile/jit.c
index 6cea8bb..82c6252 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1228,7 +1228,7 @@ emit_load_fp_slot (scm_jit_state *j, jit_gpr_t dst,
uint32_t slot)
static jit_reloc_t
emit_branch_if_immediate (scm_jit_state *j, jit_gpr_t r)
{
- return jit_bmsi (j->jit, r, 6);
+ return jit_bmsi (j->jit, r, 7); /* TAGS-SENSITIVE */
}
static void
@@ -1263,10 +1263,10 @@ emit_branch_if_heap_object_not_tc (scm_jit_state *j,
jit_gpr_t r, jit_gpr_t t,
}
static jit_reloc_t
-emit_branch_if_heap_object_not_tc7 (scm_jit_state *j, jit_gpr_t r, jit_gpr_t t,
- scm_t_bits tc7)
+emit_branch_if_heap_object_not_tc11 (scm_jit_state *j, jit_gpr_t r, jit_gpr_t
t,
+ scm_t_bits tc11)
{
- return emit_branch_if_heap_object_not_tc (j, r, t, 0x7f, tc7);
+ return emit_branch_if_heap_object_not_tc (j, r, t, 0x7ff, tc11);
}
static void
@@ -1638,7 +1638,7 @@ compile_subr_call (scm_jit_state *j, uint32_t idx)
jit_retval (j->jit, ret);
immediate = emit_branch_if_immediate (j, ret);
- not_values = emit_branch_if_heap_object_not_tc7 (j, ret, t, scm_tc7_values);
+ not_values = emit_branch_if_heap_object_not_tc11 (j, ret, t,
scm_tc11_values);
emit_call_2 (j, scm_vm_intrinsics.unpack_values_object, thread_operand (),
jit_operand_gpr (JIT_OPERAND_ABI_POINTER, ret));
emit_reload_fp (j);
@@ -2194,16 +2194,16 @@ compile_call_scm_from_scm_scm (scm_jit_state *j,
uint8_t dst, uint8_t a, uint8_t
emit_sp_ref_scm (j, T1, b);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
- jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
- jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
- jit_subi (j->jit, T0, T0, scm_tc2_int);
+ jit_subi (j->jit, T0, T0, scm_fixnum_tag);
+ jit_subi (j->jit, T2, T1, scm_fixnum_tag);
+ jit_orr (j->jit, T2, T2, T0); /* TAGS-SENSITIVE */
+ jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
fast = jit_bxaddr (j->jit, T0, T1);
has_fast = 1;
/* Restore previous value before slow path. */
jit_subr (j->jit, T0, T0, T1);
- jit_addi (j->jit, T0, T0, scm_tc2_int);
- jit_patch_here (j->jit, a_not_inum);
- jit_patch_here (j->jit, b_not_inum);
+ jit_patch_here (j->jit, not_inum);
+ jit_addi (j->jit, T0, T0, scm_fixnum_tag);
break;
}
case SCM_VM_INTRINSIC_SUB:
@@ -2212,16 +2212,16 @@ compile_call_scm_from_scm_scm (scm_jit_state *j,
uint8_t dst, uint8_t a, uint8_t
emit_sp_ref_scm (j, T1, b);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
- jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
- jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
- jit_subi (j->jit, T1, T1, scm_tc2_int);
+ jit_subi (j->jit, T1, T1, scm_fixnum_tag);
+ jit_subi (j->jit, T2, T0, scm_fixnum_tag);
+ jit_orr (j->jit, T2, T2, T1); /* TAGS-SENSITIVE */
+ jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
fast = jit_bxsubr (j->jit, T0, T1);
has_fast = 1;
/* Restore previous values before slow path. */
jit_addr (j->jit, T0, T0, T1);
- jit_addi (j->jit, T1, T1, scm_tc2_int);
- jit_patch_here (j->jit, a_not_inum);
- jit_patch_here (j->jit, b_not_inum);
+ jit_patch_here (j->jit, not_inum);
+ jit_addi (j->jit, T1, T1, scm_fixnum_tag);
break;
}
default:
@@ -2254,8 +2254,9 @@ compile_call_scm_from_scm_uimm (scm_jit_state *j, uint8_t
dst, uint8_t a, uint8_
{
emit_sp_ref_scm (j, T0, a);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
- scm_t_bits addend = b << 2;
- jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
+ scm_t_bits addend = b << scm_fixnum_tag_size;
+ jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
+ jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
fast = jit_bxaddi (j->jit, T0, addend);
has_fast = 1;
/* Restore previous value before slow path. */
@@ -2267,8 +2268,9 @@ compile_call_scm_from_scm_uimm (scm_jit_state *j, uint8_t
dst, uint8_t a, uint8_
{
emit_sp_ref_scm (j, T0, a);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
- scm_t_bits subtrahend = b << 2;
- jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
+ scm_t_bits subtrahend = b << scm_fixnum_tag_size;
+ jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
+ jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
fast = jit_bxsubi (j->jit, T0, subtrahend);
has_fast = 1;
/* Restore previous value before slow path. */
@@ -2463,7 +2465,7 @@ compile_tag_char (scm_jit_state *j, uint16_t dst,
uint16_t src)
#else
emit_sp_ref_u64_lower_half (j, T0, src);
#endif
- emit_lshi (j, T0, T0, 8);
+ emit_lshi (j, T0, T0, 8); /* TAGS-SENSITIVE */
emit_addi (j, T0, T0, scm_tc8_char);
emit_sp_set_scm (j, dst, T0);
}
@@ -2472,7 +2474,7 @@ static void
compile_untag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
{
emit_sp_ref_scm (j, T0, src);
- emit_rshi (j, T0, T0, 8);
+ emit_rshi (j, T0, T0, 8); /* TAGS-SENSITIVE */
#if SIZEOF_UINTPTR_T >= 8
emit_sp_set_u64 (j, dst, T0);
#else
@@ -3295,8 +3297,10 @@ compile_less (scm_jit_state *j, uint16_t a, uint16_t b)
emit_sp_ref_scm (j, T0, a);
emit_sp_ref_scm (j, T1, b);
+ /* TAGS-SENSITIVE */
emit_andr (j, T2, T0, T1);
- fast = jit_bmsi (j->jit, T2, scm_tc2_int);
+ emit_comr (j, T2, T2);
+ fast = jit_bmci (j->jit, T2, scm_fixnum_tag_mask);
emit_call_2 (j, scm_vm_intrinsics.less_p,
jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0),
@@ -3411,7 +3415,7 @@ compile_check_positional_arguments (scm_jit_state *j,
uint32_t nreq, uint32_t ex
head);
jit_patch_there
(j->jit,
- emit_branch_if_heap_object_not_tc7 (j, obj, obj, scm_tc7_keyword),
+ emit_branch_if_heap_object_not_tc11 (j, obj, obj, scm_tc11_keyword),
head);
jit_patch_here (j->jit, lt);
add_inter_instruction_patch (j, gt, target);
@@ -3557,11 +3561,11 @@ static void
compile_untag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
{
emit_sp_ref_scm (j, T0, a);
- emit_rshi (j, T0, T0, 2);
+ emit_rshi (j, T0, T0, scm_fixnum_tag_size);
#if SIZEOF_UINTPTR_T >= 8
emit_sp_set_s64 (j, dst, T0);
#else
- /* FIXME: Untested! */
+ /* FIXME: Untested!, and also not updated for new tagging
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
emit_rshi (j, T1, T0, 31);
emit_sp_set_s64 (j, dst, T0, T1);
#endif
@@ -3575,8 +3579,8 @@ compile_tag_fixnum (scm_jit_state *j, uint16_t dst,
uint16_t a)
#else
emit_sp_ref_s32 (j, T0, a);
#endif
- emit_lshi (j, T0, T0, 2);
- emit_addi (j, T0, T0, scm_tc2_int);
+ emit_lshi (j, T0, T0, scm_fixnum_tag_size);
+ emit_addi (j, T0, T0, scm_fixnum_tag);
emit_sp_set_scm (j, dst, T0);
}
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 0d0c11e..b70b3bc 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -43,7 +43,7 @@
static SCM keyword_obarray;
-#define SCM_KEYWORDP(x) (SCM_HAS_TYP7 (x, scm_tc7_keyword))
+#define SCM_KEYWORDP(x) (SCM_HAS_TYP11 (x, scm_tc11_keyword))
#define SCM_KEYWORD_SYMBOL(x) (SCM_CELL_OBJECT_1 (x))
SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
@@ -72,7 +72,7 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
- keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol));
+ keyword = scm_cell (scm_tc11_keyword, SCM_UNPACK (symbol));
scm_hashq_set_x (keyword_obarray, symbol, keyword);
}
scm_dynwind_end ();
diff --git a/libguile/modules.c b/libguile/modules.c
index 0e8f083..1cc55d0 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -910,7 +910,7 @@ static void
scm_post_boot_init_modules ()
{
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
- scm_module_tag = SCM_UNPACK (module_type) + scm_tc3_struct;
+ scm_module_tag = SCM_UNPACK (module_type) + scm_tc5_struct;
resolve_module_var = scm_c_lookup ("resolve-module");
define_module_star_var = scm_c_lookup ("define-module*");
diff --git a/libguile/numbers.h b/libguile/numbers.h
index b472ab8..0aa3533 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -1,7 +1,7 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2018
+/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2019
Free Software Foundation, Inc.
This file is part of Guile.
@@ -38,7 +38,7 @@
* In the current implementation, Inums must also fit within a long
* because that's what GMP's mpz_*_si functions accept. */
typedef long scm_t_inum;
-#define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2)
+#define SCM_I_FIXNUM_BIT (SCM_SIZEOF_UINTPTR_T * 8 -
scm_fixnum_tag_size)
#define SCM_MOST_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1))
#define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 1))
@@ -67,18 +67,18 @@ typedef long scm_t_inum;
NOTE: X must not perform side effects. */
#ifdef __GNUC__
-# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), 2))
+# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x),
scm_fixnum_tag_size))
#else
-# define SCM_I_INUM(x) \
- (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \
- ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2) \
- : (scm_t_inum) (SCM_UNPACK (x) >> 2))
+# define SCM_I_INUM(x) \
+ (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \
+ ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> scm_fixnum_tag_size) \
+ : (scm_t_inum) (SCM_UNPACK (x) >> scm_fixnum_tag_size))
#endif
-#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x))
+#define SCM_I_INUMP(x) ((SCM_UNPACK (x) & scm_fixnum_tag_mask) ==
scm_fixnum_tag)
#define SCM_I_NINUMP(x) (!SCM_I_INUMP (x))
#define SCM_I_MAKINUM(x) \
- (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int))
+ (SCM_PACK ((((scm_t_bits) (x)) << scm_fixnum_tag_size) + scm_fixnum_tag))
/* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */
#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
@@ -130,19 +130,20 @@ typedef long scm_t_inum;
*/
-/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only
- * differ in one bit: This way, checking if an object is an inexact number can
- * be done quickly (using the TYP16S macro). */
+/* Note that scm_tc16_double and scm_tc16_complex are given tc16-codes that
+ * only differ in one bit: This way, checking if an object is an inexact
+ * number can be done quickly. */
-/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP
- * and SCM_NUMP) */
-#define scm_tc16_big (scm_tc7_number + 1 * 256L)
-#define scm_tc16_real (scm_tc7_number + 2 * 256L)
-#define scm_tc16_complex (scm_tc7_number + 3 * 256L)
-#define scm_tc16_fraction (scm_tc7_number + 4 * 256L)
+/* Number subtype 1 to 4 (note the dependency on SCM_INEXACTP) */
+#define scm_tc16_big (scm_tc11_number + (1 << 12))
+#define scm_tc16_real (scm_tc11_number + (2 << 12))
+#define scm_tc16_complex (scm_tc11_number + (3 << 12))
+#define scm_tc16_fraction (scm_tc11_number + (4 << 12))
-#define SCM_INEXACTP(x) \
- (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
+#define SCM_INEXACTP(x) \
+ (SCM_NIMP (x) \
+ && ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex)) \
+ == (scm_tc16_real & scm_tc16_complex)))
#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
@@ -155,7 +156,7 @@ typedef long scm_t_inum;
#define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
-#define SCM_NUMP(x) (SCM_HAS_TYP7 (x, scm_tc7_number))
+#define SCM_NUMP(x) (SCM_HAS_TYP11 (x, scm_tc11_number))
#define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction))
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
diff --git a/libguile/ports.c b/libguile/ports.c
index 0ec4c14..2d920f7 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -760,7 +760,7 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob,
unsigned long mode_bits,
pt = scm_gc_typed_calloc (scm_t_port);
- ret = scm_words (scm_tc7_port | mode_bits | SCM_OPN, 4);
+ ret = scm_words (scm_tc11_port | mode_bits | SCM_OPN, 4);
SCM_SET_CELL_WORD_1 (ret, stream);
SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) pt);
SCM_SET_CELL_WORD_3 (ret, (scm_t_bits) ptob);
diff --git a/libguile/ports.h b/libguile/ports.h
index 44ef29d..84687ba 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -40,16 +40,16 @@ SCM_INTERNAL SCM scm_i_port_weak_set;
there is a flag indicating whether the port is open or not, and then
some "mode bits": flags indicating whether the port is an input
and/or an output port and how Guile should buffer the port. */
-#define SCM_OPN (1U<<8) /* Is the port open? */
-#define SCM_RDNG (1U<<9) /* Is it a readable port? */
-#define SCM_WRTNG (1U<<10) /* Is it writable? */
-#define SCM_BUF0 (1U<<11) /* Is it unbuffered? */
-#define SCM_BUFLINE (1U<<12) /* Is it line-buffered? */
+#define SCM_OPN (1U<<12) /* Is the port open? */
+#define SCM_RDNG (1U<<13) /* Is it a readable port? */
+#define SCM_WRTNG (1U<<14) /* Is it writable? */
+#define SCM_BUF0 (1U<<15) /* Is it unbuffered? */
+#define SCM_BUFLINE (1U<<16) /* Is it line-buffered? */
#ifdef BUILDING_LIBGUILE
-#define SCM_F_PORT_FINALIZING (1U<<13) /* Port is being closed via GC. */
+#define SCM_F_PORT_FINALIZING (1U<<17) /* Port is being closed via GC. */
#endif
-#define SCM_PORTP(x) (SCM_HAS_TYP7 (x, scm_tc7_port))
+#define SCM_PORTP(x) (SCM_HAS_TYP11 (x, scm_tc11_port))
#define SCM_OPPORTP(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_INPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OUTPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) &
SCM_WRTNG))
diff --git a/libguile/print.c b/libguile/print.c
index b10f0f8..ce46243 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -593,16 +593,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
switch (SCM_ITAG3 (exp))
{
- case scm_tc3_tc7_1:
- case scm_tc3_tc7_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.
- */
- scm_ipruk ("immediate", exp, port);
- break;
- case scm_tc3_int_1:
- case scm_tc3_int_2:
+ case scm_tcs_fixnums:
scm_intprint (SCM_I_INUM (exp), 10, port);
break;
case scm_tc3_imm24:
@@ -625,7 +616,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
break;
case scm_tc3_cons:
- switch (SCM_TYP7 (exp))
+ switch (SCM_TYP11 (exp))
{
case scm_tcs_struct:
{
@@ -647,16 +638,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *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_tc7_number:
+ case scm_tc11_number:
switch SCM_TYP16 (exp) {
case scm_tc16_big:
scm_bigprint (exp, port, pstate);
@@ -672,10 +657,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
}
break;
- case scm_tc7_stringbuf:
+ case scm_tc11_stringbuf:
scm_i_print_stringbuf (exp, port, pstate);
break;
- case scm_tc7_string:
+ case scm_tc11_string:
{
size_t len = scm_i_string_length (exp);
@@ -688,7 +673,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
scm_remember_upto_here_1 (exp);
break;
- case scm_tc7_symbol:
+ case scm_tc11_symbol:
if (scm_i_symbol_is_interned (exp))
{
print_symbol (exp, port);
@@ -703,91 +688,98 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_putc ('>', port);
}
break;
- case scm_tc7_variable:
+ case scm_tc11_variable:
scm_i_variable_print (exp, port, pstate);
break;
- case scm_tc7_values:
+ case scm_tc11_values:
scm_puts ("#<values (", port);
print_vector_or_weak_vector (exp, scm_i_nvalues (exp),
scm_c_value_ref, port, pstate);
scm_puts (">", port);
break;
- case scm_tc7_program:
+ case scm_tc11_program:
scm_i_program_print (exp, port, pstate);
break;
- case scm_tc7_pointer:
+ case scm_tc11_pointer:
scm_i_pointer_print (exp, port, pstate);
break;
- case scm_tc7_hashtable:
+ case scm_tc11_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
- case scm_tc7_weak_set:
+ case scm_tc11_weak_set:
scm_i_weak_set_print (exp, port, pstate);
break;
- case scm_tc7_weak_table:
+ case scm_tc11_weak_table:
scm_i_weak_table_print (exp, port, pstate);
break;
- case scm_tc7_fluid:
+ case scm_tc11_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
- case scm_tc7_dynamic_state:
+ case scm_tc11_dynamic_state:
scm_i_dynamic_state_print (exp, port, pstate);
break;
- case scm_tc7_frame:
+ case scm_tc11_frame:
scm_i_frame_print (exp, port, pstate);
break;
- case scm_tc7_keyword:
+ case scm_tc11_keyword:
scm_puts ("#:", port);
scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate);
break;
- case scm_tc7_syntax:
+ case scm_tc11_syntax:
scm_i_syntax_print (exp, port, pstate);
break;
- case scm_tc7_atomic_box:
+ case scm_tc11_atomic_box:
scm_i_atomic_box_print (exp, port, pstate);
break;
- case scm_tc7_vm_cont:
+ case scm_tc11_vm_cont:
scm_i_vm_cont_print (exp, port, pstate);
break;
- case scm_tc7_array:
+ case scm_tc11_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
- case scm_tc7_bytevector:
+ case scm_tc11_bytevector:
scm_i_print_bytevector (exp, port, pstate);
break;
- case scm_tc7_bitvector:
+ case scm_tc11_bitvector:
scm_i_print_bitvector (exp, port, pstate);
break;
- case scm_tc7_wvect:
+ case scm_tc11_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts ("#w(", port);
print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp),
scm_c_weak_vector_ref, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
- case scm_tc7_vector:
+ case scm_tc11_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts ("#(", port);
print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp),
scm_c_vector_ref, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
- case scm_tc7_port:
+ case scm_tc11_port:
{
scm_t_port_type *ptob = SCM_PORT_TYPE (exp);
if (ptob->print && ptob->print (exp, port, pstate))
break;
goto punk;
}
- case scm_tc7_smob:
+ case scm_tcs_smob:
ENTER_NESTED_DATA (pstate, exp, circref);
SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
default:
- /* case scm_tcs_closures: */
+ if (scm_is_pair (exp))
+ {
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist ("(", exp, ')', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
+ }
+ /* fall through */
punk:
scm_ipruk ("type", exp, port);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index fb59213..b94d3eb 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -26,20 +26,20 @@
* Programs
*/
-#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
+#define SCM_PROGRAM_P(x) (SCM_HAS_TYP11 (x, scm_tc11_program))
#define SCM_PROGRAM_CODE(x) ((uint32_t *) SCM_CELL_WORD_1 (x))
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES
(x)[i]=(v))
-#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 20)
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-#define SCM_F_PROGRAM_IS_BOOT 0x100
-#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
-#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
-#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
-#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
-#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
+#define SCM_F_PROGRAM_IS_BOOT 0x1000
+#define SCM_F_PROGRAM_IS_PRIMITIVE 0x2000
+#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x4000
+#define SCM_F_PROGRAM_IS_CONTINUATION 0x8000
+#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x10000
+#define SCM_F_PROGRAM_IS_FOREIGN 0x20000
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE)
@@ -52,7 +52,7 @@
static inline SCM
scm_i_make_program (const uint32_t *code)
{
- return scm_cell (scm_tc7_program, (scm_t_bits)code);
+ return scm_cell (scm_tc11_program, (scm_t_bits)code);
}
#endif
diff --git a/libguile/scm.h b/libguile/scm.h
index b4c605e..6c7913f 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -288,7 +288,7 @@ typedef uintptr_t scm_t_bits;
Heap Objects
- All object types not mentioned above in the list of immediate objects
+ All object types not mentioned above in the list of immedate objects
are represented as heap objects. The amount of memory referenced by
a heap object depends on the object's type, namely on the set of
attributes that have to be stored with objects of that type. Every
@@ -420,28 +420,25 @@ typedef uintptr_t scm_t_bits;
-/* 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. */
+#define SCM_IMP(x) (7 & SCM_UNPACK (x))
#define SCM_NIMP(x) (!SCM_IMP (x))
#define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x))
-/* 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. */
-
/* 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 variable holds a heap object, and second, by checking that
tc1==0 holds for the SCM_CELL_TYPE of the SCM variable. */
-#define SCM_I_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
+#define SCM_I_CONSP(x) \
+ (!SCM_IMP (x) && ((15 & SCM_CELL_TYPE (x)) != scm_tc4_non_pair_heap_object))
-/* Definitions for tc2: */
+/* Definitions for immediate numbers: */
-#define scm_tc2_int 2
+#define scm_fixnum_tag 15
+#define scm_fixnum_tag_mask 15
+#define scm_fixnum_tag_size 4
/* Definitions for tc3: */
@@ -449,63 +446,83 @@ typedef uintptr_t scm_t_bits;
#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
+#define scm_tc3_cons 0
+#define scm_tc3_imm24 6
+#define scm_tcs_fixnums 7
+
+
+/* Definitions for tc4: */
+
+#define scm_tc4_non_pair_heap_object 0xe
+
+
+/* Definitions for tc5: */
+
+#define scm_tc5_struct (scm_tc4_non_pair_heap_object + 0x10)
+
+
+/* Definitions for tc6: */
+
+#define scm_tc6_misc_heap (scm_tc4_non_pair_heap_object + 0x20)
/* Definitions for tc7: */
+#define scm_tc7_smob (scm_tc4_non_pair_heap_object + 0x40)
+
#define SCM_ITAG7(x) (0x7f & SCM_UNPACK (x))
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
+#define SCM_HAS_TYP7(x, tag) (SCM_NIMP (x) && SCM_TYP7 (x) == (tag))
+
+
+/* Definitions for tc11: */
+
+#define SCM_ITAG11(x) (0x7ff & SCM_UNPACK (x))
+#define SCM_TYP11(x) (0x7ff & SCM_CELL_TYPE (x))
#define SCM_HAS_HEAP_TYPE(x, type, tag) \
(SCM_NIMP (x) && type (x) == (tag))
-#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
+#define SCM_HAS_TYP11(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP11, tag))
+
+#define SCM_MAKE_HEAP_TYPE(x) (((x) << 6) + scm_tc6_misc_heap)
/* These type codes form part of the ABI and cannot be changed in a
- stable series. The low bits of each must have the tc3 of a heap
- object type code (see above). If you do change them in a development
- series, change them also in (system vm assembler) and (system base
- types). Bonus points if you change the build to define these tag
- values in only one place! */
-
-#define scm_tc7_symbol 0x05
-#define scm_tc7_variable 0x07
-#define scm_tc7_vector 0x0d
-#define scm_tc7_wvect 0x0f
-#define scm_tc7_string 0x15
-#define scm_tc7_number 0x17
-#define scm_tc7_hashtable 0x1d
-#define scm_tc7_pointer 0x1f
-#define scm_tc7_fluid 0x25
-#define scm_tc7_stringbuf 0x27
-#define scm_tc7_dynamic_state 0x2d
-#define scm_tc7_frame 0x2f
-#define scm_tc7_keyword 0x35
-#define scm_tc7_atomic_box 0x37
-#define scm_tc7_syntax 0x3d
-#define scm_tc7_values 0x3f
-#define scm_tc7_program 0x45
-#define scm_tc7_vm_cont 0x47
-#define scm_tc7_bytevector 0x4d
-#define scm_tc7_unused_4f 0x4f
-#define scm_tc7_weak_set 0x55
-#define scm_tc7_weak_table 0x57
-#define scm_tc7_array 0x5d
-#define scm_tc7_bitvector 0x5f
-#define scm_tc7_unused_65 0x65
-#define scm_tc7_unused_67 0x67
-#define scm_tc7_unused_6d 0x6d
-#define scm_tc7_unused_6f 0x6f
-#define scm_tc7_unused_75 0x75
-#define scm_tc7_smob 0x77
-#define scm_tc7_port 0x7d
-#define scm_tc7_unused_7f 0x7f
+ stable series. If you do change them in a development series,
+ change them also in (system vm assembler) and (system base types).
+ Bonus points if you change the build to define these tag values
+ in only one place! */
+
+#define scm_tc11_symbol SCM_MAKE_HEAP_TYPE (0)
+#define scm_tc11_variable SCM_MAKE_HEAP_TYPE (1)
+#define scm_tc11_vector SCM_MAKE_HEAP_TYPE (2)
+#define scm_tc11_wvect SCM_MAKE_HEAP_TYPE (3)
+#define scm_tc11_string SCM_MAKE_HEAP_TYPE (4)
+#define scm_tc11_number SCM_MAKE_HEAP_TYPE (5)
+#define scm_tc11_hashtable SCM_MAKE_HEAP_TYPE (6)
+#define scm_tc11_pointer SCM_MAKE_HEAP_TYPE (7)
+#define scm_tc11_fluid SCM_MAKE_HEAP_TYPE (8)
+#define scm_tc11_stringbuf SCM_MAKE_HEAP_TYPE (9)
+#define scm_tc11_dynamic_state SCM_MAKE_HEAP_TYPE (10)
+#define scm_tc11_frame SCM_MAKE_HEAP_TYPE (11)
+#define scm_tc11_keyword SCM_MAKE_HEAP_TYPE (12)
+#define scm_tc11_atomic_box SCM_MAKE_HEAP_TYPE (13)
+#define scm_tc11_syntax SCM_MAKE_HEAP_TYPE (14)
+#define scm_tc11_values SCM_MAKE_HEAP_TYPE (15)
+#define scm_tc11_program SCM_MAKE_HEAP_TYPE (16)
+#define scm_tc11_vm_cont SCM_MAKE_HEAP_TYPE (17)
+#define scm_tc11_bytevector SCM_MAKE_HEAP_TYPE (18)
+#define scm_tc11_weak_set SCM_MAKE_HEAP_TYPE (19)
+#define scm_tc11_weak_table SCM_MAKE_HEAP_TYPE (20)
+#define scm_tc11_array SCM_MAKE_HEAP_TYPE (21)
+#define scm_tc11_bitvector SCM_MAKE_HEAP_TYPE (22)
+#define scm_tc11_port SCM_MAKE_HEAP_TYPE (23)
+#define scm_tc11_unused_24 SCM_MAKE_HEAP_TYPE (24)
+#define scm_tc11_unused_25 SCM_MAKE_HEAP_TYPE (25)
+#define scm_tc11_unused_26 SCM_MAKE_HEAP_TYPE (26)
+#define scm_tc11_unused_27 SCM_MAKE_HEAP_TYPE (27)
+#define scm_tc11_unused_28 SCM_MAKE_HEAP_TYPE (28)
+#define scm_tc11_unused_29 SCM_MAKE_HEAP_TYPE (29)
+#define scm_tc11_unused_30 SCM_MAKE_HEAP_TYPE (30)
+#define scm_tc11_unused_31 SCM_MAKE_HEAP_TYPE (31)
/* Definitions for tc16: */
@@ -521,9 +538,9 @@ typedef uintptr_t scm_t_bits;
enum scm_tc8_tags
{
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
- scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
- scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
- scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
+ scm_tc8_char = scm_tc3_imm24 + 0x10, /* characters */
+ scm_tc8_unused_0 = scm_tc3_imm24 + 0x20,
+ scm_tc8_unused_1 = scm_tc3_imm24 + 0x30
};
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
@@ -644,65 +661,54 @@ enum scm_tc8_tags
/* 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. */
-
-/* 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
-
-/* Pairs with heap objects in the 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
+ When switching on SCM_TYP11 of a SCM value, use these fake case
+ labels to catch types that use fewer than 11 bits for tagging. */
+
+/* Smobs. */
+#define scm_tcs_smob \
+ scm_tc7_smob + 0x000: case scm_tc7_smob + 0x080:\
+ case scm_tc7_smob + 0x100: case scm_tc7_smob + 0x180:\
+ case scm_tc7_smob + 0x200: case scm_tc7_smob + 0x280:\
+ case scm_tc7_smob + 0x300: case scm_tc7_smob + 0x380:\
+ case scm_tc7_smob + 0x400: case scm_tc7_smob + 0x480:\
+ case scm_tc7_smob + 0x500: case scm_tc7_smob + 0x580:\
+ case scm_tc7_smob + 0x600: case scm_tc7_smob + 0x680:\
+ case scm_tc7_smob + 0x700: case scm_tc7_smob + 0x780
/* 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
+ scm_tc5_struct + 0x00: case scm_tc5_struct + 0x20:\
+ case scm_tc5_struct + 0x40: case scm_tc5_struct + 0x60:\
+ case scm_tc5_struct + 0x80: case scm_tc5_struct + 0xa0:\
+ case scm_tc5_struct + 0xc0: case scm_tc5_struct + 0xe0:\
+ case scm_tc5_struct + 0x100: case scm_tc5_struct + 0x120:\
+ case scm_tc5_struct + 0x140: case scm_tc5_struct + 0x160:\
+ case scm_tc5_struct + 0x180: case scm_tc5_struct + 0x1a0:\
+ case scm_tc5_struct + 0x1c0: case scm_tc5_struct + 0x1e0:\
+ case scm_tc5_struct + 0x200: case scm_tc5_struct + 0x220:\
+ case scm_tc5_struct + 0x240: case scm_tc5_struct + 0x260:\
+ case scm_tc5_struct + 0x280: case scm_tc5_struct + 0x2a0:\
+ case scm_tc5_struct + 0x2c0: case scm_tc5_struct + 0x2e0:\
+ case scm_tc5_struct + 0x300: case scm_tc5_struct + 0x320:\
+ case scm_tc5_struct + 0x340: case scm_tc5_struct + 0x360:\
+ case scm_tc5_struct + 0x380: case scm_tc5_struct + 0x3a0:\
+ case scm_tc5_struct + 0x3c0: case scm_tc5_struct + 0x3e0:\
+ case scm_tc5_struct + 0x400: case scm_tc5_struct + 0x420:\
+ case scm_tc5_struct + 0x440: case scm_tc5_struct + 0x460:\
+ case scm_tc5_struct + 0x480: case scm_tc5_struct + 0x4a0:\
+ case scm_tc5_struct + 0x4c0: case scm_tc5_struct + 0x4e0:\
+ case scm_tc5_struct + 0x500: case scm_tc5_struct + 0x520:\
+ case scm_tc5_struct + 0x540: case scm_tc5_struct + 0x560:\
+ case scm_tc5_struct + 0x580: case scm_tc5_struct + 0x5a0:\
+ case scm_tc5_struct + 0x5c0: case scm_tc5_struct + 0x5e0:\
+ case scm_tc5_struct + 0x600: case scm_tc5_struct + 0x620:\
+ case scm_tc5_struct + 0x640: case scm_tc5_struct + 0x660:\
+ case scm_tc5_struct + 0x680: case scm_tc5_struct + 0x6a0:\
+ case scm_tc5_struct + 0x6c0: case scm_tc5_struct + 0x6e0:\
+ case scm_tc5_struct + 0x700: case scm_tc5_struct + 0x720:\
+ case scm_tc5_struct + 0x740: case scm_tc5_struct + 0x760:\
+ case scm_tc5_struct + 0x780: case scm_tc5_struct + 0x7a0:\
+ case scm_tc5_struct + 0x7c0: case scm_tc5_struct + 0x7e0
diff --git a/libguile/strings.c b/libguile/strings.c
index 8f6a47e..c6efb60 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -88,7 +88,7 @@ SCM_SYMBOL (sym_error, "error");
#define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE
#define STRINGBUF_F_MUTABLE SCM_I_STRINGBUF_F_MUTABLE
-#define STRINGBUF_TAG scm_tc7_stringbuf
+#define STRINGBUF_TAG scm_tc11_stringbuf
#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
#define STRINGBUF_MUTABLE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_MUTABLE)
@@ -232,7 +232,7 @@ narrow_stringbuf (SCM buf)
/* Copy-on-write strings.
*/
-#define STRING_TAG scm_tc7_string
+#define STRING_TAG scm_tc11_string
#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
#define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
@@ -241,18 +241,18 @@ narrow_stringbuf (SCM buf)
#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
-#define IS_STRING(str) (SCM_HAS_TYP7 (str, STRING_TAG))
+#define IS_STRING(str) (SCM_HAS_TYP11 (str, STRING_TAG))
/* Read-only strings.
*/
-#define RO_STRING_TAG scm_tc7_ro_string
+#define RO_STRING_TAG scm_tc11_ro_string
#define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
/* Mutation-sharing substrings
*/
-#define SH_STRING_TAG (scm_tc7_string + 0x100)
+#define SH_STRING_TAG (scm_tc11_string + 0x1000)
#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
/* START and LENGTH as for STRINGs. */
@@ -754,7 +754,7 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
name = scm_i_substring_copy (name, 0, length);
buf = STRING_STRINGBUF (name);
- return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ return scm_double_cell (scm_tc11_symbol | flags, SCM_UNPACK (buf),
(scm_t_bits) hash, SCM_UNPACK (props));
}
@@ -765,7 +765,7 @@ scm_i_c_make_symbol (const char *name, size_t len,
SCM buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (buf), name, len);
- return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ return scm_double_cell (scm_tc11_symbol | flags, SCM_UNPACK (buf),
(scm_t_bits) hash, SCM_UNPACK (props));
}
diff --git a/libguile/strings.h b/libguile/strings.h
index 3f92d8c..eef2e70 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -193,7 +193,7 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
} \
c_name = \
{ \
- scm_tc7_stringbuf, \
+ scm_tc11_stringbuf, \
sizeof (contents) - 1, \
contents \
}
@@ -201,7 +201,7 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
#define SCM_IMMUTABLE_STRING(c_name, contents) \
SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents);
\
SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
- scm_tc7_ro_string, \
+ scm_tc11_ro_string, \
(scm_t_bits) &scm_i_paste (c_name, \
_stringbuf), \
(scm_t_bits) 0, \
@@ -214,11 +214,11 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
/* internal constants */
/* Type tag for read-only strings. */
-#define scm_tc7_ro_string (scm_tc7_string + 0x200)
+#define scm_tc11_ro_string (scm_tc11_string + 0x2000)
/* Flags for shared and wide strings. */
-#define SCM_I_STRINGBUF_F_WIDE 0x400
-#define SCM_I_STRINGBUF_F_MUTABLE 0x800
+#define SCM_I_STRINGBUF_F_WIDE 0x4000
+#define SCM_I_STRINGBUF_F_MUTABLE 0x8000
SCM_INTERNAL void scm_i_print_stringbuf (SCM exp, SCM port,
scm_print_state *pstate);
@@ -290,7 +290,7 @@ SCM_API SCM scm_sys_stringbuf_hist (void);
SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
- return SCM_HAS_TYP7 (x, scm_tc7_string);
+ return SCM_HAS_TYP11 (x, scm_tc11_string);
}
#endif
diff --git a/libguile/struct.c b/libguile/struct.c
index 3dbcc71..73b2cf7 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -328,7 +328,12 @@ scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words)
{
SCM ret;
- ret = scm_words (vtable_bits | scm_tc3_struct, n_words + 1);
+ /* FIXME: only vtables need this alignment, but for now we apply it to
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ all structs. */
+ assert ((vtable_bits & 0x1f) == 0);
+ ret = scm_words (vtable_bits | scm_tc5_struct,
+ (n_words + 1 + 0x1f) & ~0x1f); /* XXX Alignment hack,
might not work reliably. */
+ assert ((SCM_UNPACK (ret) & 0x1f) == 0); /* XXX alignment check */
/* vtable_bits can be 0 when making a vtable vtable */
if (vtable_bits && SCM_VTABLE_INSTANCE_FINALIZER (SCM_PACK (vtable_bits)))
@@ -441,7 +446,12 @@ SCM_DEFINE (scm_make_struct_simple, "make-struct/simple",
1, 0, 1,
if (n_init != SCM_VTABLE_SIZE (vtable))
SCM_MISC_ERROR ("Wrong number of initializers.", SCM_EOL);
- ret = scm_words (SCM_UNPACK (vtable) | scm_tc3_struct, n_init + 1);
+ /* FIXME: only vtables need this alignment, but for now we apply it to
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ all structs. */
+ assert ((SCM_UNPACK (vtable) & 0x1f) == 0);
+ ret = scm_words (SCM_UNPACK (vtable) | scm_tc5_struct,
+ (n_init + 1 + 0x1f) & ~0x1f); /* XXX Alignment hack, might
not work reliably. */
+ assert ((SCM_UNPACK (ret) & 0x1f) == 0); /* XXX alignment check */
for (i = 0; i < n_init; i++, init = scm_cdr (init))
{
@@ -509,7 +519,8 @@ scm_i_make_vtable_vtable (SCM fields)
obj = scm_i_alloc_struct (0, nfields);
/* Make it so that the vtable of OBJ is itself. */
- SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc3_struct);
+ assert ((SCM_UNPACK (obj) & 0x1f) == 0);
+ SCM_SET_CELL_WORD_0 (obj, SCM_UNPACK (obj) | scm_tc5_struct);
/* Manually initialize fields. */
SCM_STRUCT_SLOT_SET (obj, scm_vtable_index_layout, layout);
set_vtable_access_fields (obj);
diff --git a/libguile/struct.h b/libguile/struct.h
index c953351..7cfdbde 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -109,7 +109,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_NIMP(X) && (SCM_CELL_TYPE(X) &
0x1f) == scm_tc5_struct)
#define SCM_STRUCT_SLOTS(X) (SCM_CELL_OBJECT_LOC(X, 1))
#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)
@@ -142,7 +142,7 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_VTABLE_UNBOXED_FIELDS(X) ((uint32_t*) 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_tc5_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)))
diff --git a/libguile/symbols.h b/libguile/symbols.h
index e2a1d17..4646020 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -30,12 +30,12 @@
-#define scm_is_symbol(x) (SCM_HAS_TYP7 (x, scm_tc7_symbol))
+#define scm_is_symbol(x) (SCM_HAS_TYP11 (x, scm_tc11_symbol))
#define scm_i_symbol_hash(x) ((unsigned long) SCM_CELL_WORD_2 (x))
#define scm_i_symbol_is_interned(x) \
(!(SCM_CELL_WORD_0 (x) & SCM_I_F_SYMBOL_UNINTERNED))
-#define SCM_I_F_SYMBOL_UNINTERNED 0x100
+#define SCM_I_F_SYMBOL_UNINTERNED 0x1000
#define SCM_VALIDATE_SYMBOL(pos, str) \
do { \
diff --git a/libguile/syntax.c b/libguile/syntax.c
index 2da4e39..e9e1103 100644
--- a/libguile/syntax.c
+++ b/libguile/syntax.c
@@ -40,7 +40,7 @@
static int
scm_is_syntax (SCM x)
{
- return SCM_HAS_TYP7 (x, scm_tc7_syntax);
+ return SCM_HAS_TYP11 (x, scm_tc11_syntax);
}
#define SCM_VALIDATE_SYNTAX(pos, scm) \
@@ -61,7 +61,7 @@ SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 0, 0,
"Make a new syntax object.")
#define FUNC_NAME s_scm_make_syntax
{
- return scm_double_cell (scm_tc7_syntax, SCM_UNPACK (exp),
+ return scm_double_cell (scm_tc11_syntax, SCM_UNPACK (exp),
SCM_UNPACK (wrap), SCM_UNPACK (module));
}
#undef FUNC_NAME
diff --git a/libguile/values.c b/libguile/values.c
index 522a8f5..44ef437 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -96,11 +96,11 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
{
size_t i;
- if ((size_t) n > (size_t) (UINTPTR_MAX >> 8))
+ if ((size_t) n > (size_t) (UINTPTR_MAX >> 12))
scm_error (scm_out_of_range_key, FUNC_NAME, "Too many values",
SCM_EOL, SCM_EOL);
- result = scm_words ((((scm_t_bits) n) << 8) | scm_tc7_values, n + 1);
+ result = scm_words ((((scm_t_bits) n) << 12) | scm_tc11_values, n + 1);
for (i = 0; i < n; i++, args = SCM_CDR (args))
SCM_SET_CELL_OBJECT (result, i + 1, SCM_CAR (args));
}
@@ -122,7 +122,7 @@ scm_c_values (SCM *base, size_t nvalues)
scm_error (scm_out_of_range_key, "scm_c_values", "Too many values",
SCM_EOL, SCM_EOL);
- ret = scm_words ((((scm_t_bits) nvalues) << 8) | scm_tc7_values, nvalues +
1);
+ ret = scm_words ((((scm_t_bits) nvalues) << 12) | scm_tc11_values, nvalues +
1);
for (i = 0; i < nvalues; i++)
SCM_SET_CELL_OBJECT (ret, i + 1, base[i]);
@@ -135,7 +135,7 @@ scm_values_2 (SCM a, SCM b)
{
SCM ret;
- ret = scm_words ((2 << 8) | scm_tc7_values, 3);
+ ret = scm_words ((2 << 12) | scm_tc11_values, 3);
SCM_SET_CELL_OBJECT_1 (ret, a);
SCM_SET_CELL_OBJECT_2 (ret, b);
@@ -147,7 +147,7 @@ scm_values_3 (SCM a, SCM b, SCM c)
{
SCM ret;
- ret = scm_words ((3 << 8) | scm_tc7_values, 4);
+ ret = scm_words ((3 << 12) | scm_tc11_values, 4);
SCM_SET_CELL_OBJECT_1 (ret, a);
SCM_SET_CELL_OBJECT_2 (ret, b);
SCM_SET_CELL_OBJECT_3 (ret, c);
diff --git a/libguile/values.h b/libguile/values.h
index e5f0043..94ab6ce 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -27,14 +27,14 @@
static inline int
scm_is_values (SCM x)
{
- return SCM_HAS_TYP7 (x, scm_tc7_values);
+ return SCM_HAS_TYP11 (x, scm_tc11_values);
}
#ifdef BUILDING_LIBGUILE
static inline size_t
scm_i_nvalues (SCM x)
{
- return SCM_CELL_WORD_0 (x) >> 8;
+ return SCM_CELL_WORD_0 (x) >> 12;
}
static inline SCM
diff --git a/libguile/variable.c b/libguile/variable.c
index 96c6bfe..a4bb985 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -52,7 +52,7 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state
*pstate)
static SCM
make_variable (SCM init)
{
- return scm_cell (scm_tc7_variable, SCM_UNPACK (init));
+ return scm_cell (scm_tc11_variable, SCM_UNPACK (init));
}
SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0,
diff --git a/libguile/variable.h b/libguile/variable.h
index 07d2658..b18ceca 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -30,7 +30,7 @@
/* Variables
*/
-#define SCM_VARIABLEP(X) (SCM_HAS_TYP7 (X, scm_tc7_variable))
+#define SCM_VARIABLEP(X) (SCM_HAS_TYP11 (X, scm_tc11_variable))
#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1 (V)
#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
#define SCM_VARIABLE_LOC(V) (SCM_CELL_OBJECT_LOC ((V), 1))
diff --git a/libguile/vectors.c b/libguile/vectors.c
index e716e52..84ea128 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -250,7 +250,7 @@ scm_c_make_vector (size_t k, SCM fill)
SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
- vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
+ vector = scm_words ((k << 12) | scm_tc11_vector, k + 1);
for (j = 0; j < k; ++j)
SCM_SIMPLE_VECTOR_SET (vector, j, fill);
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 41e2c89..398bd3f 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -74,18 +74,19 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
/* Internals */
-/* Vectors residualized into compiled objects have scm_tc7_vector in the
- low 7 bits, but also an additional bit set to indicate
+/* Vectors residualized into compiled objects have scm_tc11_vector in the
+ low 11 bits, but also an additional bit set to indicate
immutability. */
-#define SCM_F_VECTOR_IMMUTABLE 0x80UL
+#define SCM_F_VECTOR_IMMUTABLE 0x800UL
#define SCM_I_IS_MUTABLE_VECTOR(x) \
(SCM_NIMP (x) && \
- ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \
- == scm_tc7_vector))
-#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))
+ ((SCM_CELL_TYPE (x) & (0x7ff | SCM_F_VECTOR_IMMUTABLE)) \
+ == scm_tc11_vector))
+#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP11 (x, scm_tc11_vector))
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))
-#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
+/* XXXXXXX On 32-bit systems, the length will be quite limited. Fix. */
+#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 12)
SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 062dc00..f2dcc91 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -333,8 +333,8 @@ VM_NAME (scm_thread *thread)
{
uint32_t n;
SYNC_IP ();
- VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ());
- ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1);
+ VM_ASSERT (nvals <= (UINTPTR_MAX >> 12), abort ());
+ ret = scm_words ((nvals << 12) | scm_tc11_values, nvals + 1);
for (n = 0; n < nvals; n++)
SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (first_value + n));
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 82cdae9..6c5d19b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -182,7 +182,7 @@ capture_stack (union scm_vm_stack_element *stack_top,
memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom));
p->dynstack = dynstack;
p->flags = flags;
- return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p);
+ return scm_cell (scm_tc11_vm_cont, (scm_t_bits) p);
}
SCM
@@ -301,7 +301,7 @@ invoke_hook (scm_thread *thread, SCM hook)
frame = alloca (sizeof (*frame) + 8);
frame = (scm_t_cell *) ROUND_UP ((uintptr_t) frame, 8UL);
- frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
+ frame->word_0 = SCM_PACK (scm_tc11_frame | (SCM_VM_FRAME_KIND_VM << 12));
frame->word_1 = SCM_PACK_POINTER (&c_frame);
scm_frame = SCM_PACK_POINTER (frame);
@@ -485,7 +485,7 @@ define_vm_builtins (void)
size_t sz = sizeof (builtin##_code); \
vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
vm_builtin_##builtin = \
- scm_cell (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \
+ scm_cell (scm_tc11_program | SCM_F_PROGRAM_IS_PRIMITIVE, \
(scm_t_bits)vm_builtin_##builtin##_code); \
}
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
diff --git a/libguile/vm.h b/libguile/vm.h
index d227f26..9977f7d 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -113,7 +113,7 @@ struct scm_vm_cont {
uint32_t flags;
};
-#define SCM_VM_CONT_P(OBJ) (SCM_HAS_TYP7 (OBJ, scm_tc7_vm_cont))
+#define SCM_VM_CONT_P(OBJ) (SCM_HAS_TYP11 (OBJ, scm_tc11_vm_cont))
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags &
SCM_F_VM_CONT_PARTIAL)
#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags &
SCM_F_VM_CONT_REWINDABLE)
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 8cf1b82..0382cf1 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -141,7 +141,7 @@ typedef struct {
} scm_t_weak_set;
-#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
+#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP11 (x, scm_tc11_weak_set))
#define SCM_VALIDATE_WEAK_SET(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set")
#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x))
@@ -674,7 +674,7 @@ make_weak_set (unsigned long k)
set->min_size_index = i;
scm_i_pthread_mutex_init (&set->lock, NULL);
- return scm_cell (scm_tc7_weak_set, (scm_t_bits)set);
+ return scm_cell (scm_tc11_weak_set, (scm_t_bits)set);
}
void
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 1e4d8d3..e46a240 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -152,7 +152,7 @@ typedef struct {
} scm_t_weak_table;
-#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
+#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP11 (x, scm_tc11_weak_table))
#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
@@ -444,7 +444,7 @@ make_weak_table (unsigned long k, scm_t_weak_table_kind
kind)
table->last_gc_no = GC_get_gc_no ();
scm_i_pthread_mutex_init (&table->lock, NULL);
- return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
+ return scm_cell (scm_tc11_weak_table, (scm_t_bits)table);
}
void
diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c
index b087891..ae35ae3 100644
--- a/libguile/weak-vector.c
+++ b/libguile/weak-vector.c
@@ -59,7 +59,7 @@ scm_c_make_weak_vector (size_t len, SCM fill)
wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
"weak vector"));
- SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
+ SCM_SET_CELL_WORD_0 (wv, (len << 12) | scm_tc11_wvect);
if (SCM_HEAP_OBJECT_P (fill))
{
diff --git a/libguile/weak-vector.h b/libguile/weak-vector.h
index e22f63c..d03c574 100644
--- a/libguile/weak-vector.h
+++ b/libguile/weak-vector.h
@@ -27,7 +27,7 @@
/* Weak vectors. */
-#define SCM_I_WVECTP(x) (SCM_HAS_TYP7 (x, scm_tc7_wvect))
+#define SCM_I_WVECTP(x) (SCM_HAS_TYP11 (x, scm_tc11_wvect))
SCM_API SCM scm_make_weak_vector (SCM len, SCM fill);
SCM_API SCM scm_weak_vector (SCM l);
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 77c8fae..f61f1f9 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -544,7 +544,7 @@ term."
(letk ktag0
($kargs ('closure) (closure)
($continue ktag1 src
- ($primcall 'load-u64 (+ %tc7-program (ash nfree 16))
()))))
+ ($primcall 'load-u64 (+ %tc11-program (ash nfree 20))
()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate `(closure . ,(+ nfree 2))
@@ -571,7 +571,7 @@ term."
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
- ($primcall 'load-u64 (+ %tc7-vector (ash nfree 8)) ()))))
+ ($primcall 'load-u64 (+ %tc11-vector (ash nfree 12))
()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate `(vector . ,(1+ nfree))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index ad43eeb..15c0ade 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -166,8 +166,8 @@
(from-sp (slot idx))))
(($ $primcall 'scm-ref/tag annotation (obj))
(let ((tag (match annotation
- ('pair %tc1-pair)
- ('struct %tc3-struct))))
+ ('pair 0)
+ ('struct %tc5-struct))))
(emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
(($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
(emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
@@ -298,8 +298,8 @@
(from-sp (slot val))))
(($ $primcall 'scm-set!/tag annotation (obj val))
(let ((tag (match annotation
- ('pair %tc1-pair)
- ('struct %tc3-struct))))
+ ('pair 0)
+ ('struct %tc5-struct))))
(emit-scm-set!/tag asm (from-sp (slot obj)) tag
(from-sp (slot val)))))
(($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
@@ -464,7 +464,7 @@
(#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates.
- (#('pair? #f (a)) (unary emit-pair? a))
+ (#('non-pair-heap-object? #f (a)) (unary emit-non-pair-heap-object? a))
(#('struct? #f (a)) (unary emit-struct? a))
(#('symbol? #f (a)) (unary emit-symbol? a))
(#('variable? #f (a)) (unary emit-variable? a))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 6c8884a..716a8a2 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -104,8 +104,8 @@
($continue kcast src
($primcall 'assume-u64 `(0 . ,(target-max-vector-length))
(ulen)))))
(letk krsh
- ($kargs ('w0) (w0)
- ($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
+ ($kargs ('w0) (w0) ;TAGS-SENSITIVE
+ ($continue kassume src ($primcall 'ursh/immediate 12 (w0)))))
(letk kv
($kargs () ()
($continue krsh src
@@ -313,7 +313,7 @@
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
- ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
+ ($primcall 'load-u64 (+ %tc11-vector (ash size 12)) ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate `(vector . ,nwords) ()))))))
@@ -338,11 +338,11 @@
(letk ktag1
($kargs ('w0-high) (w0-high)
($continue ktag2 src
- ($primcall 'uadd/immediate %tc7-vector (w0-high)))))
+ ($primcall 'uadd/immediate %tc11-vector (w0-high)))))
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
- ($primcall 'ulsh/immediate 8 (usize)))))
+ ($primcall 'ulsh/immediate 12 (usize))))) ;TAGS-SENSITIVE
(letk kalloc
($kargs ('nwords) (nwords)
($continue ktag0 src
@@ -403,7 +403,7 @@
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
- ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
+ ($primcall 'load-u64 (+ %tc11-vector (ash size 12)) ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate `(vector . ,nwords) ()))))))
@@ -415,12 +415,18 @@
"Wrong type argument in position 1 (expecting pair): ~S")
('mutable-pair?
"Wrong type argument in position 1 (expecting mutable pair): ~S")))
+ (define pred*
+ (match pred
+ ('pair?
+ 'non-pair-heap-object?)
+ ('mutable-pair?
+ (error "ensure-pair: mutable pairs support not yet implemented"))))
(define not-pair (vector 'wrong-type-arg (symbol->string op) msg))
(with-cps cps
(letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x))))
(let$ body (is-pair))
(letk k ($kargs () () ,body))
- (letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x))))
+ (letk kheap-object ($kargs () () ($branch k knot-pair src pred* #f (x))))
(build-term ($branch knot-pair kheap-object src 'heap-object? #f (x)))))
(define-primcall-converter cons
@@ -502,7 +508,7 @@
(letk ktag0
($kargs ('obj) (obj)
($continue ktag1 src
- ($primcall 'load-u64 %tc7-variable ()))))
+ ($primcall 'load-u64 %tc11-variable ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate '(box . 2) ()))))))
@@ -1133,7 +1139,7 @@
(lambda (cps k src op param s idx)
(define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S"))
- (define stringbuf-f-wide #x400)
+ (define stringbuf-f-wide #x4000) ;TAGS-SENSITIVE
(ensure-string
cps src op s
(lambda (cps ulen)
@@ -1203,7 +1209,7 @@
(lambda (cps k src op param s idx ch)
(define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S"))
- (define stringbuf-f-wide #x400)
+ (define stringbuf-f-wide #x4000) ;TAGS-SENSITIVE
(ensure-string
cps src op s
(lambda (cps ulen)
@@ -1312,7 +1318,7 @@
(letk ktag0
($kargs ('obj) (obj)
($continue ktag1 src
- ($primcall 'load-u64 %tc7-atomic-box ()))))
+ ($primcall 'load-u64 %tc11-atomic-box ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-words/immediate '(atomic-box . 2) ()))))))
@@ -2132,11 +2138,17 @@
(convert-args cps args
(lambda (cps args)
(if (heap-type-predicate? name)
- (with-cps cps
- (letk kt* ($kargs () ()
- ($branch kf kt src name #f args)))
- (build-term
- ($branch kf kt* src 'heap-object? #f args)))
+ (if (eq? name 'pair?)
;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ (with-cps cps
+ (letk kt* ($kargs () ()
+ ($branch kt kf src 'non-pair-heap-object?
#f args)))
+ (build-term
+ ($branch kf kt* src 'heap-object? #f args)))
+ (with-cps cps
+ (letk kt* ($kargs () ()
+ ($branch kf kt src name #f args)))
+ (build-term
+ ($branch kf kt* src 'heap-object? #f args))))
(with-cps cps
(build-term ($branch kf kt src name #f args)))))))
(($ <conditional> src test consequent alternate)
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index b9f2fe9..6eeb1b5 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -157,6 +157,10 @@
(visit-immediate-tags define-immediate-type-predicate)
(visit-heap-tags define-heap-type-predicate)
+;; Special case handling for 'pair?'.
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+(hashq-set! *heap-type-predicates* 'pair? #t)
+(define-branching-primitive 'pair? 1)
+
(define (branching-primitive? name)
"Is @var{name} a primitive that can only appear in $branch CPS terms?"
(hashq-ref *branching-primitive-arities* name))
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 2088cd8..1746bdd 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -1,6 +1,6 @@
;;; Compilation targets
-;; Copyright (C) 2011-2014,2017-2018 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014,2017-2019 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
@@ -172,23 +172,33 @@ SCM words."
;; address space.
(/ (target-max-size-t) (target-word-size)))
+;; TAGS-SENSITIVE
(define (target-max-vector-length)
"Return the maximum vector length of the target platform, in units of
SCM words."
- ;; Vector size fits in first word; the low 8 bits are taken by the
+ ;; Vector size fits in first word; the low 12 bits are taken by the
;; type tag. Additionally, restrict to 48-bit address space.
- (1- (ash 1 (min (- (* (target-word-size) 8) 8) 48))))
+ (1- (ash 1 (min (- (* (target-word-size) 8) 12) 48))))
+;; TAGS-SENSITIVE
(define (target-most-negative-fixnum)
"Return the most negative integer representable as a fixnum on the
target platform."
- (- (ash 1 (- (* (target-word-size) 8) 3))))
+ (case (target-word-size)
+ ((4) #x-40000000)
+ ((8) #x-800000000000000)
+ (else (error "unexpected word size"))))
+;; TAGS-SENSITIVE
(define (target-most-positive-fixnum)
"Return the most positive integer representable as a fixnum on the
target platform."
- (1- (ash 1 (- (* (target-word-size) 8) 3))))
+ (case (target-word-size)
+ ((4) #x3fffffff)
+ ((8) #x7ffffffFFFFFFFF)
+ (else (error "unexpected word size"))))
+;; TAGS-SENSITIVE
(define (target-fixnum? n)
(and (exact-integer? n)
(<= (target-most-negative-fixnum)
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 418c9fe..5a9d4d7 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -1,5 +1,5 @@
;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2019 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 as published by
@@ -308,16 +308,24 @@ KIND/SUB-KIND."
(lambda (io port)
(match io
(($ <inferior-object> kind sub-kind address)
- (format port "#<~a ~:[~*~;~a ~]~x>"
+ (format port "#<~a~:[~*~; ~a~]~:[~*~; ~x~]>"
kind sub-kind sub-kind
- address)))))
+ address address)))))
-(define (inferior-smob backend type-number address)
+(define (inferior-smob backend type-number flags word1 address)
"Return an object representing the SMOB at ADDRESS whose type is
TYPE-NUMBER."
- (inferior-object 'smob
- (or (type-number->name backend 'smob type-number)
- type-number)
+ (inferior-object (let ((type-name (or (type-number->name backend 'smob
+ type-number)
+ (string->symbol
+ (string-append "smob-"
(number->string type-number))))))
+ (if (zero? flags)
+ type-name
+ (string->symbol (string-append
+ (symbol->string type-name)
+ "/"
+ (number->string flags 16)))))
+ (number->string word1 16)
address))
(define (inferior-port-type backend address)
@@ -393,32 +401,32 @@ using BACKEND."
(or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
(let ((port (memory-port backend address)))
(match-cell port
- (((vtable-address & 7 = %tc3-struct))
+ (((vtable-address & #x1f = %tc5-struct))
(address->inferior-struct address
- (- vtable-address %tc3-struct)
+ (- vtable-address %tc5-struct)
backend))
- (((_ & #x7f = %tc7-symbol) buf hash props)
+ (((_ & #x7ff = %tc11-symbol) buf hash props)
(match (cell->object buf backend)
(($ <stringbuf> string)
(string->symbol string))))
- (((_ & #x7f = %tc7-variable) obj)
+ (((_ & #x7ff = %tc11-variable) obj)
(inferior-object 'variable address))
- (((_ & #x7f = %tc7-string) buf start len)
+ (((_ & #x7ff = %tc11-string) buf start len)
(match (cell->object buf backend)
(($ <stringbuf> string)
(substring string start (+ start len)))))
- (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
+ (((_ & #x047ff = %tc11-stringbuf) len (bytevector buf len))
(stringbuf (iconv:bytevector->string buf "ISO-8859-1")))
- (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
+ (((_ & #x047ff = (bitwise-ior #x4000 %tc11-stringbuf))
len (bytevector buf (* 4 len)))
(stringbuf (iconv:bytevector->string buf
(match (native-endianness)
('little "UTF-32LE")
('big "UTF-32BE")))))
- (((_ & #x7f = %tc7-bytevector) len address)
+ (((_ & #x7ff = %tc11-bytevector) len address)
(let ((bv-port (memory-port backend address len)))
(get-bytevector-n bv-port len)))
- ((((len << 8) || %tc7-vector))
+ ((((len << 12) || %tc11-vector))
(let ((words (get-bytevector-n port (* len %word-size)))
(vector (make-vector len)))
(visited (address -> vector)
@@ -430,16 +438,33 @@ using BACKEND."
(bytevector->uint-list words (native-endianness)
%word-size)))
vector)))
- (((_ & #x7f = %tc7-weak-vector))
+ (((_ & #x7ff = %tc11-weak-vector))
(inferior-object 'weak-vector address)) ; TODO: show elements
- (((_ & #x7f = %tc7-fluid) init-value)
+ (((_ & #x7ff = %tc11-fluid) init-value)
(inferior-object 'fluid address))
- (((_ & #x7f = %tc7-dynamic-state))
+ (((_ & #x7ff = %tc11-dynamic-state))
(inferior-object 'dynamic-state address))
- ((((flags << 8) || %tc7-port))
+ ((((flags << 12) || %tc11-port))
(inferior-port backend (logand flags #xff) address))
- (((_ & #x7f = %tc7-program))
- (inferior-object 'program address))
+ (((bits & #x7ff = %tc11-program) code)
+ (let ((num-free-vars (ash bits -20))
+ (flags (filter-map (match-lambda
+ ((mask . flag-name)
+ (and (logtest mask bits) flag-name)))
+ '((#x01000 . boot)
+ (#x02000 . prim)
+ (#x04000 . prim-generic)
+ (#x08000 . cont)
+ (#x10000 . partial-cont)
+ (#x20000 . foreign)))))
+ (inferior-object (cons* 'program flags
+ (unfold zero?
+ (lambda (n)
+ (number->string (get-word port)
16))
+ 1-
+ num-free-vars))
+ (number->string code 16)
+ address)))
(((_ & #xffff = %tc16-bignum))
(inferior-object 'bignum address))
(((_ & #xffff = %tc16-flonum) pad)
@@ -447,57 +472,64 @@ using BACKEND."
(port (memory-port backend address (sizeof double)))
(words (get-bytevector-n port (sizeof double))))
(bytevector-ieee-double-ref words 0 (native-endianness))))
- (((_ & #x7f = %tc7-heap-number) mpi)
+ (((_ & #x7ff = %tc11-heap-number) mpi)
(inferior-object 'number address))
- (((_ & #x7f = %tc7-hash-table) buckets meta-data unused)
+ (((_ & #x7ff = %tc11-hash-table) buckets meta-data unused)
(inferior-object 'hash-table address))
- (((_ & #x7f = %tc7-pointer) address)
+ (((_ & #x7ff = %tc11-pointer) address)
(make-pointer address))
- (((_ & #x7f = %tc7-keyword) symbol)
+ (((_ & #x7ff = %tc11-keyword) symbol)
(symbol->keyword (cell->object symbol backend)))
- (((_ & #x7f = %tc7-syntax) expression wrap module)
+ (((_ & #x7ff = %tc11-syntax) expression wrap module)
(cond-expand
(guile-2.2
- (make-syntax (cell->object expression backend)
- (cell->object wrap backend)
- (cell->object module backend)))
+ (make-syntax (scm->object expression backend)
+ (scm->object wrap backend)
+ (scm->object module backend)))
(else
- (inferior-object 'syntax address))))
- (((_ & #x7f = %tc7-vm-continuation))
+ (vector 'syntax-object
+ (scm->object expression backend)
+ (scm->object wrap backend)
+ (scm->object module backend)))))
+ (((_ & #x7ff = %tc11-vm-continuation))
(inferior-object 'vm-continuation address))
- (((_ & #x7f = %tc7-weak-set))
+ (((_ & #x7ff = %tc11-weak-set))
(inferior-object 'weak-set address))
- (((_ & #x7f = %tc7-weak-table))
+ (((_ & #x7ff = %tc11-weak-table))
(inferior-object 'weak-table address))
- (((_ & #x7f = %tc7-array))
+ (((_ & #x7ff = %tc11-array))
(inferior-object 'array address))
- (((_ & #x7f = %tc7-bitvector))
+ (((_ & #x7ff = %tc11-bitvector))
(inferior-object 'bitvector address))
- ((((smob-type << 8) || %tc7-smob) word1)
- (inferior-smob backend smob-type address))))))
+ (((bits & #x7f = %tc7-smob) word1)
+ (let ((smob-type (bit-extract bits 8 16))
+ (flags (ash bits -16)))
+ (inferior-smob backend smob-type flags word1 address)))))))
(define* (scm->object bits #:optional (backend %ffi-memory-backend))
"Return the Scheme object corresponding to BITS, the bits of an 'SCM'
object."
(match-scm bits
- (((integer << 2) || %tc2-fixnum)
+ (((integer << %fixnum-tag-size) || %fixnum-tag)
integer)
((address & 7 = %tc3-heap-object)
- (let* ((type (dereference-word backend address))
- (pair? (= (logand type #b1) %tc1-pair)))
- (if pair?
- (or (and=> (vhash-assv address (%visited-cells)) cdr)
- (let ((car type)
- (cdrloc (+ address %word-size))
- (pair (cons *unspecified* *unspecified*)))
- (visited (address -> pair)
- (set-car! pair (scm->object car backend))
- (set-cdr! pair
- (scm->object (dereference-word backend cdrloc)
- backend))
- pair)))
- (cell->object address backend))))
+ (if (zero? address)
+ (inferior-object 'NULL #f) ;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ (let* ((type (dereference-word backend address))
+ (pair? (not (= (logand type 15) %tc4-non-pair-heap-object))))
+ (if pair?
+ (or (and=> (vhash-assv address (%visited-cells)) cdr)
+ (let ((car type)
+ (cdrloc (+ address %word-size))
+ (pair (cons *unspecified* *unspecified*)))
+ (visited (address -> pair)
+ (set-car! pair (scm->object car backend))
+ (set-cdr! pair
+ (scm->object (dereference-word backend cdrloc)
+ backend))
+ pair)))
+ (cell->object address backend)))))
(((char << 8) || %tc8-char)
(integer->char char))
((= %tc16-false) #f)
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index 9e4e4cc..25b26dc 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -1,5 +1,5 @@
;;; Details on internal value representation.
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017-2019 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 as published by
@@ -16,7 +16,9 @@
(define-module (system base types internal)
#:export (;; Immediate tags.
- %tc2-fixnum
+ %fixnum-tag
+ %fixnum-tag-mask
+ %fixnum-tag-size
%tc3-heap-object
%tc8-char
%tc16-false
@@ -29,34 +31,34 @@
visit-immediate-tags
;; Heap object tags (cell types).
- %tc1-pair
- %tc3-struct
- %tc7-symbol
- %tc7-variable
- %tc7-vector
- %tc8-immutable-vector
- %tc8-mutable-vector
- %tc7-weak-vector
- %tc7-string
- %tc7-heap-number
- %tc7-hash-table
- %tc7-pointer
- %tc7-fluid
- %tc7-stringbuf
- %tc7-dynamic-state
- %tc7-frame
- %tc7-keyword
- %tc7-atomic-box
- %tc7-syntax
- %tc7-program
- %tc7-vm-continuation
- %tc7-bytevector
- %tc7-weak-set
- %tc7-weak-table
- %tc7-array
- %tc7-bitvector
- %tc7-port
+ %tc4-non-pair-heap-object
+ %tc5-struct
%tc7-smob
+ %tc11-symbol
+ %tc11-variable
+ %tc11-vector
+ %tc12-immutable-vector
+ %tc12-mutable-vector
+ %tc11-weak-vector
+ %tc11-string
+ %tc11-heap-number
+ %tc11-hash-table
+ %tc11-pointer
+ %tc11-fluid
+ %tc11-stringbuf
+ %tc11-dynamic-state
+ %tc11-frame
+ %tc11-keyword
+ %tc11-atomic-box
+ %tc11-syntax
+ %tc11-program
+ %tc11-vm-continuation
+ %tc11-bytevector
+ %tc11-weak-set
+ %tc11-weak-table
+ %tc11-array
+ %tc11-bitvector
+ %tc11-port
%tc16-bignum
%tc16-flonum
%tc16-complex
@@ -71,7 +73,7 @@
;;;
-;;; Tags---keep in sync with libguile/tags.h!
+;;; Tags---keep in sync with libguile/scm.h!
;;;
(define-syntax define-tags
@@ -93,91 +95,113 @@
tag)
...)))))))))
+;;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+;; For now, this file defines tags for 64-bit word size. TODO: support
+;; tags that vary depending on the target word size.
(define-tags immediate-tags
;; 321076543210 321076543210
- (fixnum fixnum? #b11 #b10)
(heap-object heap-object? #b111 #b000)
- (char char? #b11111111 #b00001100)
- (false eq-false? #b111111111111 #b000000000100)
- (nil eq-nil? #b111111111111 #b000100000100)
- (null eq-null? #b111111111111 #b001100000100)
- (true eq-true? #b111111111111 #b010000000100)
- (unspecified unspecified? #b111111111111 #b100000000100)
- (undefined undefined? #b111111111111 #b100100000100)
- (eof eof-object? #b111111111111 #b101000000100)
+ (fixnum fixnum? #b1111 #b1111)
+ ;;(fixrat fixrat? #b1111 #b0111)
+ (char char? #b11111111 #b00010110)
+ (false eq-false? #b111111111111 #b000000000110)
+ (nil eq-nil? #b111111111111 #b000100000110)
+ (null eq-null? #b111111111111 #b001100000110)
+ (true eq-true? #b111111111111 #b010000000110)
+ (unspecified unspecified? #b111111111111 #b100000000110)
+ (undefined undefined? #b111111111111 #b100100000110)
+ (eof eof-object? #b111111111111 #b101000000110)
- ;;(nil eq-nil? #b111111111111 #b000100000100)
- ;;(eol eq-null? #b111111111111 #b001100000100)
- ;;(false eq-false? #b111111111111 #b000000000100)
- (null+nil null? #b110111111111 #b000100000100)
- (false+nil false? #b111011111111 #b000000000100)
- (null+false+nil nil? #b110011111111 #b000000000100))
+ ;;(false eq-false? #b111111111111 #b000000000110)
+ ;;(nil eq-nil? #b111111111111 #b000100000110)
+ ;;(null eq-null? #b111111111111 #b001100000110)
+ (null+nil null? #b110111111111 #b000100000110)
+ (false+nil false? #b111011111111 #b000000000110)
+ (null+false+nil nil? #b110011111111 #b000000000110))
(define-tags heap-tags
- ;; 321076543210 321076543210
- (pair pair? #b1 #b0)
- (struct struct? #b111 #b001)
- ;; For tc7 values, low bits 2 and 0 must be 1.
- (symbol symbol? #b1111111 #b0000101)
- (variable variable? #b1111111 #b0000111)
- (vector vector? #b1111111 #b0001101)
- (immutable-vector immutable-vector? #b11111111 #b10001101)
- (mutable-vector mutable-vector? #b11111111 #b00001101)
- (weak-vector weak-vector? #b1111111 #b0001111)
- (string string? #b1111111 #b0010101)
- (heap-number heap-number? #b1111111 #b0010111)
- (hash-table hash-table? #b1111111 #b0011101)
- (pointer pointer? #b1111111 #b0011111)
- (fluid fluid? #b1111111 #b0100101)
- (stringbuf stringbuf? #b1111111 #b0100111)
- (dynamic-state dynamic-state? #b1111111 #b0101101)
- (frame frame? #b1111111 #b0101111)
- (keyword keyword? #b1111111 #b0110101)
- (atomic-box atomic-box? #b1111111 #b0110111)
- (syntax syntax? #b1111111 #b0111101)
- ;;(unused unused #b1111111 #b0111111)
- (program program? #b1111111 #b1000101)
- (vm-continuation vm-continuation? #b1111111 #b1000111)
- (bytevector bytevector? #b1111111 #b1001101)
- ;;(unused unused #b1111111 #b1001111)
- (weak-set weak-set? #b1111111 #b1010101)
- (weak-table weak-table? #b1111111 #b1010111)
- (array array? #b1111111 #b1011101)
- (bitvector bitvector? #b1111111 #b1011111)
- ;;(unused unused #b1111111 #b1100101)
- ;;(unused unused #b1111111 #b1100111)
- ;;(unused unused #b1111111 #b1101101)
- ;;(unused unused #b1111111 #b1101111)
- ;;(unused unused #b1111111 #b1110101)
- (smob smob? #b1111111 #b1110111)
- (port port? #b1111111 #b1111101)
- ;;(unused unused #b1111111 #b1111111)
-
- ;(heap-number heap-number? #b1111111 #b0010111)
- (bignum bignum? #b111111111111 #b000100010111)
- (flonum flonum? #b111111111111 #b001000010111)
- (complex compnum? #b111111111111 #b001100010111)
- (fraction fracnum? #b111111111111 #b010000010111))
+ ;; 321076543210 321076543210
+ (non-pair-heap-object
+ non-pair-heap-object? #b1111 #b1110)
+ (struct struct? #b11111 #b11110)
+ (smob smob? #b1111111 #b1001110)
+ (symbol symbol? #b11111111111 #b00000101110)
+ (variable variable? #b11111111111 #b00001101110)
+ (vector vector? #b11111111111 #b00010101110)
+ (immutable-vector immutable-vector? #b111111111111 #b100010101110)
+ (mutable-vector mutable-vector? #b111111111111 #b000010101110)
+ (weak-vector weak-vector? #b11111111111 #b00011101110)
+ (string string? #b11111111111 #b00100101110)
+ (heap-number heap-number? #b11111111111 #b00101101110)
+ (hash-table hash-table? #b11111111111 #b00110101110)
+ (pointer pointer? #b11111111111 #b00111101110)
+ (fluid fluid? #b11111111111 #b01000101110)
+ (stringbuf stringbuf? #b11111111111 #b01001101110)
+ (dynamic-state dynamic-state? #b11111111111 #b01010101110)
+ (frame frame? #b11111111111 #b01011101110)
+ (keyword keyword? #b11111111111 #b01100101110)
+ (atomic-box atomic-box? #b11111111111 #b01101101110)
+ (syntax syntax? #b11111111111 #b01110101110)
+ ;;(values values? #b11111111111 #b01111101110)
+ (program program? #b11111111111 #b10000101110)
+ (vm-continuation vm-continuation? #b11111111111 #b10001101110)
+ (bytevector bytevector? #b11111111111 #b10010101110)
+ (weak-set weak-set? #b11111111111 #b10011101110)
+ (weak-table weak-table? #b11111111111 #b10100101110)
+ (array array? #b11111111111 #b10101101110)
+ (bitvector bitvector? #b11111111111 #b10110101110)
+ (port port? #b11111111111 #b10111101110)
+ ;;(unused unused #b11111111111 #b11000101110)
+ ;;(unused unused #b11111111111 #b11001101110)
+ ;;(unused unused #b11111111111 #b11010101110)
+ ;;(unused unused #b11111111111 #b11011101110)
+ ;;(unused unused #b11111111111 #b11100101110)
+ ;;(unused unused #b11111111111 #b11101101110)
+ ;;(unused unused #b11111111111 #b11110101110)
+ ;;(unused unused #b11111111111 #b11111101110)
+
+ ;(heap-number heap-number? #b11111111111 #b00101101110)
+ (bignum bignum? #b1111111111111111 #b0001000101101110)
+ (flonum flonum? #b1111111111111111 #b0010000101101110)
+ (complex compnum? #b1111111111111111 #b0011000101101110)
+ (fraction fracnum? #b1111111111111111 #b0100000101101110))
+
+(eval-when (expand)
+ (define configurable-width-tag-names
+ '(fixnum #;fixrat #;heap-object #;struct))
+ (define historic-tc16-names
+ '(false nil null true unspecified undefined eof)))
(define-syntax define-tag
(lambda (x)
- (define (id-append ctx a b)
- (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+ (define (id-append ctx . ids)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum ids))))
(define (def prefix name tag)
#`(define #,(id-append name prefix name) #,tag))
+ (define (def* name mask tag)
+ #`(begin
+ (define #,(id-append name #'% name #'-tag-mask) #,mask)
+ (define #,(id-append name #'% name #'-tag-size) (logcount #,mask))
+ (define #,(id-append name #'% name #'-tag) #,tag)))
(syntax-case x ()
- ((_ name pred #b1 tag) (def #'%tc1- #'name #'tag))
- ((_ name pred #b11 tag) (def #'%tc2- #'name #'tag))
+ ((_ name pred mask tag)
+ (member (syntax->datum #'name) configurable-width-tag-names)
+ (def* #'name #'mask #'tag))
((_ name pred #b111 tag) (def #'%tc3- #'name #'tag))
+ ((_ name pred #b1111 tag) (def #'%tc4- #'name #'tag))
+ ((_ name pred #b11111 tag) (def #'%tc5- #'name #'tag))
((_ name pred #b1111111 tag) (def #'%tc7- #'name #'tag))
((_ name pred #b11111111 tag) (def #'%tc8- #'name #'tag))
+ ((_ name pred #b11111111111 tag) (def #'%tc11- #'name #'tag))
;; Only 12 bits of mask but for historic reasons these are called
;; tc16 values.
- ((_ name pred #b111111111111 tag) (def #'%tc16- #'name #'tag))
+ ((_ name pred #b111111111111 tag)
+ (member (syntax->datum #'name) historic-tc16-names)
+ (def #'%tc16- #'name #'tag))
+ ((_ name pred #b111111111111 tag) (def #'%tc12- #'name #'tag))
+ ((_ name pred #b1111111111111111 tag) (def #'%tc16- #'name #'tag))
((_ name pred mask tag)
- #`(begin
- (define #,(id-append #'name #'name #'-mask) mask)
- (define #,(id-append #'name #'name #'-tag) tag))))))
+ (def* #'name #'mask #'tag)))))
(visit-immediate-tags define-tag)
(visit-heap-tags define-tag)
@@ -205,13 +229,13 @@
(error "expected #f and '() to differ in exactly two bit positions"))
(call-with-values (lambda () (common-bits %tc16-null %tc16-nil))
(lambda (mask tag)
- (unless (= mask null+nil-mask) (error "unexpected mask for null?"))
- (unless (= tag null+nil-tag) (error "unexpected tag for null?"))))
+ (unless (= mask %null+nil-tag-mask) (error "unexpected mask for
null?"))
+ (unless (= tag %null+nil-tag) (error "unexpected tag for null?"))))
(call-with-values (lambda () (common-bits %tc16-false %tc16-nil))
(lambda (mask tag)
- (unless (= mask false+nil-mask) (error "unexpected mask for false?"))
- (unless (= tag false+nil-tag) (error "unexpected tag for false?"))))
+ (unless (= mask %false+nil-tag-mask) (error "unexpected mask for
false?"))
+ (unless (= tag %false+nil-tag) (error "unexpected tag for false?"))))
(call-with-values (lambda () (common-bits %tc16-false %tc16-null))
(lambda (mask tag)
- (unless (= mask null+false+nil-mask) (error "unexpected mask for
nil?"))
- (unless (= tag null+false+nil-tag) (error "unexpected tag for
nil?"))))))
+ (unless (= mask %null+false+nil-tag-mask) (error "unexpected mask for
nil?"))
+ (unless (= tag %null+false+nil-tag) (error "unexpected tag for
nil?"))))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f3682f7..cfda4f9 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -110,7 +110,7 @@
(emit-throw/value* . emit-throw/value)
(emit-throw/value+data* . emit-throw/value+data)
- emit-pair?
+ emit-non-pair-heap-object?
emit-struct?
emit-symbol?
emit-variable?
@@ -1097,28 +1097,36 @@ lists. This procedure can be called many times before
calling
(define (immediate-bits asm x)
"Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise."
- (define tc2-int 2)
(if (exact-integer? x)
;; Object is an immediate if it is a fixnum on the target.
(call-with-values (lambda ()
(case (asm-word-size asm)
- ((4) (values (- #x20000000)
- #x1fffffff))
- ((8) (values (- #x2000000000000000)
- #x1fffffffFFFFFFFF))
+ ;; TAGS-SENSITIVE
+ ((4) (values #x-40000000
+ #x3fffffff
+ 1 ;fixint tag
+ 1)) ;fixint shift
+ ((8) (values #x-800000000000000
+ #x7ffffffFFFFFFFF
+ 15 ;fixint tag
+ 4)) ;fixint shift
(else (error "unexpected word size"))))
- (lambda (fixnum-min fixnum-max)
- (and (<= fixnum-min x fixnum-max)
- (let ((fixnum-bits (if (negative? x)
- (+ fixnum-max 1 (logand x fixnum-max))
+ (lambda (fixint-min fixint-max fixint-tag fixint-shift)
+ (and (<= fixint-min x fixint-max)
+ (let ((fixint-bits (if (negative? x)
+ (+ fixint-max 1 (logand x fixint-max))
x)))
- (logior (ash fixnum-bits 2) tc2-int)))))
+ (logior (ash fixint-bits fixint-shift) fixint-tag)))))
;; Otherwise, the object will be immediate on the target if and
;; only if it is immediate on the host. Except for integers,
;; which we handle specially above, any immediate value is an
;; immediate on both 32-bit and 64-bit targets.
+ ;;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ ;; XXX in the new tagging scheme, the following will rarely if
+ ;; ever be sufficient when cross-compiling.
(let ((bits (object-address x)))
- (and (not (zero? (logand bits 6)))
+ ;; TAGS-SENSITIVE
+ (and (not (= (logand bits 7) %tc3-heap-object))
bits))))
(define-record-type <stringbuf>
@@ -1603,27 +1611,31 @@ should be .data or .rodata), and return the resulting
linker object.
(+ address
(modulo (- alignment (modulo address alignment)) alignment)))
- (define tc7-vector #x0d)
- (define vector-immutable-flag #x80)
+ ;; TAGS-SENSITIVE
+ (define (htag x)
+ (+ #x2e (ash x 6))) ;temporarily hacked for 64-bit only!
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
- (define tc7-string #x15)
- (define string-read-only-flag #x200)
+ (define tc11-vector (htag 2))
+ (define vector-immutable-flag #x800)
- (define tc7-stringbuf #x27)
- (define stringbuf-wide-flag #x400)
+ (define tc11-string (htag 4))
+ (define string-read-only-flag #x2000)
- (define tc7-syntax #x3d)
+ (define tc11-stringbuf (htag 9))
+ (define stringbuf-wide-flag #x4000)
- (define tc7-program #x45)
+ (define tc11-syntax (htag 14))
- (define tc7-bytevector #x4d)
- ;; This flag is intended to be left-shifted by 7 bits.
+ (define tc11-program (htag 16))
+
+ (define tc11-bytevector (htag 18))
+ ;; This flag is intended to be left-shifted by 11 bits.
(define bytevector-immutable-flag #x200)
- (define tc7-array #x5d)
+ (define tc11-array (htag 21))
- (define tc7-bitvector #x5f)
- (define bitvector-immutable-flag #x80)
+ (define tc11-bitvector (htag 22))
+ (define bitvector-immutable-flag #x800)
(let ((word-size (asm-word-size asm))
(endianness (asm-endianness asm)))
@@ -1673,7 +1685,7 @@ should be .data or .rodata), and return the resulting
linker object.
((stringbuf? obj)
(let* ((x (stringbuf-string obj))
(len (string-length x))
- (tag (logior tc7-stringbuf
+ (tag (logior tc11-stringbuf
(if (= (string-bytes-per-char x) 1)
0
stringbuf-wide-flag))))
@@ -1707,10 +1719,10 @@ should be .data or .rodata), and return the resulting
linker object.
((static-procedure? obj)
(case word-size
((4)
- (bytevector-u32-set! buf pos tc7-program endianness)
+ (bytevector-u32-set! buf pos tc11-program endianness)
(bytevector-u32-set! buf (+ pos 4) 0 endianness))
((8)
- (bytevector-u64-set! buf pos tc7-program endianness)
+ (bytevector-u64-set! buf pos tc11-program endianness)
(bytevector-u64-set! buf (+ pos 8) 0 endianness))
(else (error "bad word size"))))
@@ -1722,7 +1734,7 @@ should be .data or .rodata), and return the resulting
linker object.
(values))
((string? obj)
- (let ((tag (logior tc7-string string-read-only-flag)))
+ (let ((tag (logior tc11-string string-read-only-flag)))
(case word-size
((4)
(bytevector-u32-set! buf pos tag endianness)
@@ -1742,7 +1754,7 @@ should be .data or .rodata), and return the resulting
linker object.
((simple-vector? obj)
(let* ((len (vector-length obj))
- (tag (logior tc7-vector vector-immutable-flag (ash len 8))))
+ (tag (logior tc11-vector vector-immutable-flag (ash len 12))))
(case word-size
((4) (bytevector-u32-set! buf pos tag endianness))
((8) (bytevector-u64-set! buf pos tag endianness))
@@ -1762,8 +1774,8 @@ should be .data or .rodata), and return the resulting
linker object.
((syntax? obj)
(case word-size
- ((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
- ((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
+ ((4) (bytevector-u32-set! buf pos tc11-syntax endianness))
+ ((8) (bytevector-u64-set! buf pos tc11-syntax endianness))
(else (error "bad word size")))
(write-constant-reference buf (+ pos (* 1 word-size))
(syntax-expression obj))
@@ -1777,14 +1789,14 @@ should be .data or .rodata), and return the resulting
linker object.
((simple-uniform-vector? obj)
(let ((tag (if (bitvector? obj)
- (logior tc7-bitvector
+ (logior tc11-bitvector
bitvector-immutable-flag)
- (logior tc7-bytevector
+ (logior tc11-bytevector
;; Bytevector immutable flag also shifted
- ;; left.
+ ;; left. TAGS-SENSITIVE
(ash (logior bytevector-immutable-flag
(array-type-code obj))
- 7)))))
+ 11)))))
(case word-size
((4)
(bytevector-u32-set! buf pos tag endianness)
@@ -1820,7 +1832,7 @@ should be .data or .rodata), and return the resulting
linker object.
((array? obj)
(let-values
;; array tag + rank + contp flag: see libguile/arrays.h .
- (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
+ (((tag) (logior tc11-array (ash (array-rank obj) 17) (ash 1 16)))
((bv-set! bvs-set!)
(case word-size
((4) (values bytevector-u32-set! bytevector-s32-set!))
- [Guile-commits] branch wip-new-tagging created (now f08e08b), Mark H. Weaver, 2019/06/06
- [Guile-commits] 01/07: fix typo, Mark H. Weaver, 2019/06/06
- [Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic., Mark H. Weaver, 2019/06/06
- [Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc., Mark H. Weaver, 2019/06/06
- [Guile-commits] 06/07: DRAFT: Add immediate floats (iflos)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures., Mark H. Weaver, 2019/06/06
- [Guile-commits] 04/07: WIP: New tagging v8,
Mark H. Weaver <=