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

WIP: New tagging v9

Browse source
This commit is contained in:
Mark H Weaver 2019-06-08 21:12:43 -04:00
parent 92a7168fbe
commit 87c1f272e1
53 changed files with 757 additions and 386 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/alist.c
View file

@ -98,7 +98,7 @@ SCM_DEFINE (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
#define FUNC_NAME s_scm_sloppy_assoc #define FUNC_NAME s_scm_sloppy_assoc
{ {
/* Immediate values can be checked using `eq?'. */ /* Immediate values can be checked using `eq?'. */
if (SCM_IMP (key)) if (!SCM_HEAP_OBJECT_P (key))
return scm_sloppy_assq (key, alist); return scm_sloppy_assq (key, alist);
for (; scm_is_pair (alist); alist = SCM_CDR (alist)) for (; scm_is_pair (alist); alist = SCM_CDR (alist))
@ -179,7 +179,7 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0,
SCM ls = alist; SCM ls = alist;
/* Immediate values can be checked using `eq?'. */ /* Immediate values can be checked using `eq?'. */
if (SCM_IMP (key)) if (!SCM_HEAP_OBJECT_P (key))
return scm_assq (key, alist); return scm_assq (key, alist);
for(; scm_is_pair (ls); ls = SCM_CDR (ls)) for(; scm_is_pair (ls); ls = SCM_CDR (ls))

2
libguile/array-handle.c
View file

@ -170,7 +170,7 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len,
void void
scm_array_get_handle (SCM array, scm_t_array_handle *h) scm_array_get_handle (SCM array, scm_t_array_handle *h)
{ {
if (!SCM_HEAP_OBJECT_P (array)) if (!SCM_THOB_P (array))
scm_wrong_type_arg_msg (NULL, 0, array, "array"); scm_wrong_type_arg_msg (NULL, 0, array, "array");
h->array = array; h->array = array;

2
libguile/arrays.c
View file

@ -635,7 +635,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
int ndim, i, k; int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_THOB_P (ra), ra, SCM_ARG1, FUNC_NAME);
switch (scm_c_array_rank (ra)) switch (scm_c_array_rank (ra))
{ {

2
libguile/arrays.h
View file

@ -66,7 +66,7 @@ SCM_API SCM scm_array_rank (SCM ra);
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) (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(x) (SCM_HAS_TYP7 (x, scm_tc7_array))
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17)) #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)) #define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))

2
libguile/bitvectors.c
View file

@ -48,7 +48,7 @@
#define IS_BITVECTOR(obj) SCM_HAS_TYP7 ((obj), scm_tc7_bitvector) #define IS_BITVECTOR(obj) SCM_HAS_TYP7 ((obj), scm_tc7_bitvector)
#define IS_MUTABLE_BITVECTOR(x) \ #define IS_MUTABLE_BITVECTOR(x) \
(SCM_NIMP (x) && \ (SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \ ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \
== scm_tc7_bitvector)) == scm_tc7_bitvector))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj)) #define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))

2
libguile/bytevectors.h
View file

@ -132,7 +132,7 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
#define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL #define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL
#define SCM_MUTABLE_BYTEVECTOR_P(x) \ #define SCM_MUTABLE_BYTEVECTOR_P(x) \
(SCM_NIMP (x) && \ (SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \ ((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \
== scm_tc7_bytevector)) == scm_tc7_bytevector))

36
libguile/eq.c
View file

@ -159,7 +159,7 @@ scm_i_fraction_equalp (SCM x, SCM y)
int int
scm_i_heap_numbers_equal_p (SCM x, SCM y) scm_i_heap_numbers_equal_p (SCM x, SCM y)
{ {
if (SCM_IMP (x)) abort(); if (!SCM_THOB_P (x)) abort();
switch (SCM_TYP16 (x)) switch (SCM_TYP16 (x))
{ {
case scm_tc16_big: case scm_tc16_big:
@ -216,9 +216,9 @@ SCM scm_eqv_p (SCM x, SCM y)
{ {
if (scm_is_eq (x, y)) if (scm_is_eq (x, y))
return SCM_BOOL_T; return SCM_BOOL_T;
if (SCM_IMP (x)) if (!SCM_THOB_P (x))
return SCM_BOOL_F; return SCM_BOOL_F;
if (SCM_IMP (y)) if (!SCM_THOB_P (y))
return SCM_BOOL_F; return SCM_BOOL_F;
/* this ensures that types and scm_length are the same. */ /* this ensures that types and scm_length are the same. */
@ -299,18 +299,28 @@ scm_equal_p (SCM x, SCM y)
SCM_TICK; SCM_TICK;
if (scm_is_eq (x, y)) if (scm_is_eq (x, y))
return SCM_BOOL_T; return SCM_BOOL_T;
if (SCM_IMP (x))
return SCM_BOOL_F; if (scm_is_pair (x))
if (SCM_IMP (y))
return SCM_BOOL_F;
if (scm_is_pair (x) && scm_is_pair (y))
{ {
if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) if (scm_is_pair (y))
return SCM_BOOL_F; {
x = SCM_CDR(x); if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
y = SCM_CDR(y); return SCM_BOOL_F;
goto tailrecurse; x = SCM_CDR(x);
y = SCM_CDR(y);
goto tailrecurse;
}
else
return SCM_BOOL_F;
} }
else if (scm_is_pair (y))
return SCM_BOOL_F;
if (!SCM_THOB_P (x))
return SCM_BOOL_F;
if (!SCM_THOB_P (y))
return SCM_BOOL_F;
if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y)) if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
{ {
int i = SCM_SMOBNUM (x); int i = SCM_SMOBNUM (x);

9
libguile/eval.h
View file

@ -31,15 +31,6 @@
*/ */
/* {Ilocs}
*
* Ilocs are relative pointers into local environment structures.
*
*/
#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc)
/* {Evaluator} /* {Evaluator}

15
libguile/evalext.c
View file

@ -64,16 +64,17 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
"Return #t for objects which Guile considers self-evaluating") "Return #t for objects which Guile considers self-evaluating")
#define FUNC_NAME s_scm_self_evaluating_p #define FUNC_NAME s_scm_self_evaluating_p
{ {
switch (SCM_ITAG3 (obj)) switch (SCM_ITAG (obj))
{ {
case scm_tc3_int_1: case scm_itags_fixnum:
case scm_tc3_int_2: /* immediate numbers */
/* inum */
return SCM_BOOL_T; return SCM_BOOL_T;
case scm_tc3_imm24: case scm_itags_imm24:
/* characters, booleans, other immediates */ /* characters, booleans, other immediates */
return scm_from_bool (!scm_is_null_and_not_nil (obj)); return scm_from_bool (!scm_is_null_and_not_nil (obj));
case scm_tc3_cons: case scm_itags_pair:
return SCM_BOOL_F;
case scm_itags_thob:
switch (SCM_TYP7 (obj)) switch (SCM_TYP7 (obj))
{ {
case scm_tc7_vector: case scm_tc7_vector:

2
libguile/gc-inline.h
View file

@ -166,7 +166,7 @@ scm_inline_words (scm_thread *thread, scm_t_bits car, uint32_t n_words)
static inline SCM static inline SCM
scm_inline_cons (scm_thread *thread, SCM x, SCM y) scm_inline_cons (scm_thread *thread, SCM x, SCM y)
{ {
return scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y)); return SCM_ADD_PAIR_TAG (scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y)));
} }

4
libguile/gc.c
View file

@ -478,9 +478,9 @@ scm_storage_prehistory ()
/* We only need to register a displacement for those types for which the /* We only need to register a displacement for those types for which the
higher bits of the type tag are used to store a pointer (that is, a higher bits of the type tag are used to store a pointer (that is, a
pointer to an 8-octet aligned region). */ pointer to an 8-octet aligned region). */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons); GC_REGISTER_DISPLACEMENT (scm_thob_tag);
GC_REGISTER_DISPLACEMENT (scm_pair_tag);
GC_REGISTER_DISPLACEMENT (scm_tc3_struct); GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
/* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */ /* Sanity check. */
if (!GC_is_visible (&scm_protects)) if (!GC_is_visible (&scm_protects))

11
libguile/gc.h
View file

@ -77,8 +77,15 @@ typedef struct scm_t_cell
#define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v)) #define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v))
#define SCM_CELL_OBJECT_LOC(x, n) (&SCM_GC_CELL_OBJECT ((x), (n))) #define SCM_CELL_OBJECT_LOC(x, n) (&SCM_GC_CELL_OBJECT ((x), (n)))
#define SCM_CARLOC(x) (SCM_CELL_OBJECT_LOC ((x), 0))
#define SCM_CDRLOC(x) (SCM_CELL_OBJECT_LOC ((x), 1)) #define SCM_ADD_POINTER_TAG(tag, x) (SCM_PACK (SCM_UNPACK (x) + (tag)))
#define SCM_REMOVE_POINTER_TAG(tag, x) (SCM_PACK (SCM_UNPACK (x) - (tag)))
#define SCM_ADD_PAIR_TAG(x) (SCM_ADD_POINTER_TAG (scm_pair_tag, (x)))
#define SCM_REMOVE_PAIR_TAG(x) (SCM_REMOVE_POINTER_TAG (scm_pair_tag, (x)))
#define SCM_CARLOC(x) (SCM_CELL_OBJECT_LOC (SCM_REMOVE_PAIR_TAG (x), 0))
#define SCM_CDRLOC(x) (SCM_CELL_OBJECT_LOC (SCM_REMOVE_PAIR_TAG (x), 1))
#define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x) #define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x)
#define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t)) #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t))

2
libguile/generalized-arrays.c
View file

@ -46,7 +46,7 @@ SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
int int
scm_is_array (SCM obj) scm_is_array (SCM obj)
{ {
if (!SCM_HEAP_OBJECT_P (obj)) if (!SCM_THOB_P (obj))
return 0; return 0;
switch (SCM_TYP7 (obj)) switch (SCM_TYP7 (obj))

2
libguile/generalized-arrays.h
View file

@ -34,7 +34,7 @@
#define SCM_VALIDATE_ARRAY(pos, v) \ #define SCM_VALIDATE_ARRAY(pos, v) \
do { \ do { \
SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \ SCM_ASSERT (SCM_THOB_P (v) \
&& scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \ && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
v, pos, FUNC_NAME); \ v, pos, FUNC_NAME); \
} while (0) } while (0)

26
libguile/goops.c
View file

@ -203,13 +203,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
"Return the class of @var{x}.") "Return the class of @var{x}.")
#define FUNC_NAME s_scm_class_of #define FUNC_NAME s_scm_class_of
{ {
switch (SCM_ITAG3 (x)) switch (SCM_ITAG (x))
{ {
case scm_tc3_int_1: case scm_itags_fixnum:
case scm_tc3_int_2:
return class_integer; return class_integer;
case scm_tc3_imm24: case scm_itags_imm24:
if (SCM_CHARP (x)) if (SCM_CHARP (x))
return class_char; return class_char;
else if (scm_is_bool (x)) else if (scm_is_bool (x))
@ -219,11 +218,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else else
return class_unknown; return class_unknown;
case scm_tc3_cons: case scm_itags_pair:
return class_pair;
case scm_itags_thob:
switch (SCM_TYP7 (x)) switch (SCM_TYP7 (x))
{ {
case scm_tcs_cons_nimcar:
return class_pair;
case scm_tc7_symbol: case scm_tc7_symbol:
return class_symbol; return class_symbol;
case scm_tc7_vector: case scm_tc7_vector:
@ -325,18 +325,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_i_define_class_for_vtable (vtable); return scm_i_define_class_for_vtable (vtable);
} }
default: default:
if (scm_is_pair (x)) return class_unknown;
return class_pair;
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; return class_unknown;
} }

97
libguile/hash.c
View file

@ -284,62 +284,63 @@ scm_raw_ihashq (scm_t_bits key)
static unsigned long static unsigned long
scm_raw_ihash (SCM obj, size_t depth) scm_raw_ihash (SCM obj, size_t depth)
{ {
if (SCM_IMP (obj)) if (SCM_THOB_P (obj))
return scm_raw_ihashq (SCM_UNPACK (obj)); switch (SCM_TYP7(obj))
{
switch (SCM_TYP7(obj)) /* FIXME: do better for structs, variables, ... Also the hashes
{ are currently associative, which ain't the right thing. */
/* FIXME: do better for structs, variables, ... Also the hashes case scm_tc7_smob:
are currently associative, which ain't the right thing. */ return scm_raw_ihashq (SCM_TYP16 (obj));
case scm_tc7_smob: case scm_tc7_number:
return scm_raw_ihashq (SCM_TYP16 (obj)); if (scm_is_integer (obj))
case scm_tc7_number: {
if (scm_is_integer (obj)) SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
if (scm_is_inexact (obj))
obj = scm_inexact_to_exact (obj);
return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
}
else
return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
case scm_tc7_string:
return scm_i_string_hash (obj);
case scm_tc7_symbol:
return scm_i_symbol_hash (obj);
case scm_tc7_pointer:
return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj));
case scm_tc7_wvect:
case scm_tc7_vector:
{ {
SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM); size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
if (scm_is_inexact (obj)) size_t i = depth / 2;
obj = scm_inexact_to_exact (obj); unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n))); if (len)
while (i--)
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
return h;
} }
else case scm_tc7_syntax:
return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10))); {
case scm_tc7_string: unsigned long h;
return scm_i_string_hash (obj); h = scm_raw_ihash (scm_syntax_expression (obj), depth);
case scm_tc7_symbol: h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
return scm_i_symbol_hash (obj); h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
case scm_tc7_pointer: return h;
return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj)); }
case scm_tc7_wvect: case scm_tcs_struct:
case scm_tc7_vector: return scm_i_struct_hash (obj, depth);
{ default:
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj); return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
size_t i = depth / 2;
unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
if (len)
while (i--)
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
return h;
} }
case scm_tc7_syntax: else if (scm_is_pair (obj))
{ {
unsigned long h;
h = scm_raw_ihash (scm_syntax_expression (obj), depth);
h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
return h;
}
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
if (depth) if (depth)
return (scm_raw_ihash (SCM_CAR (obj), depth / 2) return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
^ scm_raw_ihash (SCM_CDR (obj), depth / 2)); ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
else else
return scm_raw_ihashq (scm_tc3_cons); return scm_raw_ihashq (0);
case scm_tcs_struct:
return scm_i_struct_hash (obj, depth);
default:
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
} }
else /* immediate */
return scm_raw_ihashq (SCM_UNPACK (obj));
} }

1
libguile/instructions.c
View file

@ -52,6 +52,7 @@ SCM_SYMBOL (sym_bang, "!");
M(X8_S8_S8_S8) \ M(X8_S8_S8_S8) \
M(X8_S8_C8_S8) \ M(X8_S8_C8_S8) \
M(X8_S8_S8_C8) \ M(X8_S8_S8_C8) \
M(X8_S8_C8_C8) \
M(C8_C24) \ M(C8_C24) \
M(C8_S24) \ M(C8_S24) \
M(C32) /* Unsigned. */ \ M(C32) /* Unsigned. */ \

108
libguile/jit.c
View file

@ -1226,9 +1226,9 @@ emit_load_fp_slot (scm_jit_state *j, jit_gpr_t dst, uint32_t slot)
} }
static jit_reloc_t static jit_reloc_t
emit_branch_if_immediate (scm_jit_state *j, jit_gpr_t r) emit_branch_if_not_thob (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 static void
@ -1637,7 +1637,7 @@ compile_subr_call (scm_jit_state *j, uint32_t idx)
clear_scratch_register_state (j); clear_scratch_register_state (j);
jit_retval (j->jit, ret); jit_retval (j->jit, ret);
immediate = emit_branch_if_immediate (j, ret); immediate = emit_branch_if_not_thob (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_tc7 (j, ret, t, scm_tc7_values);
emit_call_2 (j, scm_vm_intrinsics.unpack_values_object, thread_operand (), emit_call_2 (j, scm_vm_intrinsics.unpack_values_object, thread_operand (),
jit_operand_gpr (JIT_OPERAND_ABI_POINTER, ret)); jit_operand_gpr (JIT_OPERAND_ABI_POINTER, ret));
@ -2041,6 +2041,20 @@ compile_allocate_words_immediate (scm_jit_state *j, uint16_t dst, uint16_t nword
emit_sp_set_scm (j, dst, t); emit_sp_set_scm (j, dst, t);
} }
static void
compile_tagged_allocate_words_immediate (scm_jit_state *j, uint8_t dst, uint8_t nwords, uint8_t tag)
{
jit_gpr_t t = T0;
emit_store_current_ip (j, t);
emit_call_2 (j, scm_vm_intrinsics.allocate_words, thread_operand (),
jit_operand_imm (JIT_OPERAND_ABI_WORD, nwords));
emit_retval (j, t);
emit_addi (j, t, t, tag);
emit_reload_sp (j);
emit_sp_set_scm (j, dst, t);
}
static void static void
compile_scm_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx) compile_scm_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx)
{ {
@ -2087,6 +2101,15 @@ compile_scm_ref_immediate (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t i
emit_sp_set_scm (j, dst, T0); emit_sp_set_scm (j, dst, T0);
} }
static void
compile_tagged_scm_ref_immediate (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t byte_offset_u)
{
int8_t byte_offset = byte_offset_u;
emit_sp_ref_scm (j, T0, obj);
emit_ldxi (j, T0, T0, byte_offset);
emit_sp_set_scm (j, dst, T0);
}
static void static void
compile_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t idx, uint8_t val) compile_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t idx, uint8_t val)
{ {
@ -2095,6 +2118,15 @@ compile_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t idx, uint8_t v
jit_stxi (j->jit, idx * sizeof (SCM), T0, T1); jit_stxi (j->jit, idx * sizeof (SCM), T0, T1);
} }
static void
compile_tagged_scm_set_immediate (scm_jit_state *j, uint8_t obj, uint8_t byte_offset_u, uint8_t val)
{
int8_t byte_offset = byte_offset_u;
emit_sp_ref_scm (j, T0, obj);
emit_sp_ref_scm (j, T1, val);
jit_stxi (j->jit, byte_offset, T0, T1);
}
static void static void
compile_word_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx) compile_word_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx)
{ {
@ -2194,16 +2226,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); emit_sp_ref_scm (j, T1, b);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0); op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1); 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_subi (j->jit, T0, T0, scm_fixnum_tag);
jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int); jit_subi (j->jit, T2, T1, scm_fixnum_tag);
jit_subi (j->jit, T0, T0, scm_tc2_int); 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); fast = jit_bxaddr (j->jit, T0, T1);
has_fast = 1; has_fast = 1;
/* Restore previous value before slow path. */ /* Restore previous value before slow path. */
jit_subr (j->jit, T0, T0, T1); jit_subr (j->jit, T0, T0, T1);
jit_addi (j->jit, T0, T0, scm_tc2_int); jit_patch_here (j->jit, not_inum);
jit_patch_here (j->jit, a_not_inum); jit_addi (j->jit, T0, T0, scm_fixnum_tag);
jit_patch_here (j->jit, b_not_inum);
break; break;
} }
case SCM_VM_INTRINSIC_SUB: case SCM_VM_INTRINSIC_SUB:
@ -2212,16 +2244,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); emit_sp_ref_scm (j, T1, b);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0); op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1); 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_subi (j->jit, T1, T1, scm_fixnum_tag);
jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int); jit_subi (j->jit, T2, T0, scm_fixnum_tag);
jit_subi (j->jit, T1, T1, scm_tc2_int); 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); fast = jit_bxsubr (j->jit, T0, T1);
has_fast = 1; has_fast = 1;
/* Restore previous values before slow path. */ /* Restore previous values before slow path. */
jit_addr (j->jit, T0, T0, T1); jit_addr (j->jit, T0, T0, T1);
jit_addi (j->jit, T1, T1, scm_tc2_int); jit_patch_here (j->jit, not_inum);
jit_patch_here (j->jit, a_not_inum); jit_addi (j->jit, T1, T1, scm_fixnum_tag);
jit_patch_here (j->jit, b_not_inum);
break; break;
} }
default: default:
@ -2254,8 +2286,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); emit_sp_ref_scm (j, T0, a);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0); op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
scm_t_bits addend = b << 2; scm_t_bits addend = b << scm_fixnum_tag_size;
jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2); 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); fast = jit_bxaddi (j->jit, T0, addend);
has_fast = 1; has_fast = 1;
/* Restore previous value before slow path. */ /* Restore previous value before slow path. */
@ -2267,8 +2300,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); emit_sp_ref_scm (j, T0, a);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0); op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
scm_t_bits subtrahend = b << 2; scm_t_bits subtrahend = b << scm_fixnum_tag_size;
jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2); 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); fast = jit_bxsubi (j->jit, T0, subtrahend);
has_fast = 1; has_fast = 1;
/* Restore previous value before slow path. */ /* Restore previous value before slow path. */
@ -2370,6 +2404,14 @@ compile_make_non_immediate (scm_jit_state *j, uint32_t dst, const void *data)
emit_sp_set_scm (j, dst, T0); emit_sp_set_scm (j, dst, T0);
} }
static void
compile_make_tagged_non_immediate (scm_jit_state *j, uint32_t dst, uint32_t tag, const void *data)
{
emit_movi (j, T0, (uintptr_t)data);
emit_addi (j, T0, T0, tag);
emit_sp_set_scm (j, dst, T0);
}
static void static void
compile_static_ref (scm_jit_state *j, uint32_t dst, void *loc) compile_static_ref (scm_jit_state *j, uint32_t dst, void *loc)
{ {
@ -2465,7 +2507,7 @@ compile_tag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
#else #else
emit_sp_ref_u64_lower_half (j, T0, src); emit_sp_ref_u64_lower_half (j, T0, src);
#endif #endif
emit_lshi (j, T0, T0, 8); emit_lshi (j, T0, T0, 8); /* TAGS-SENSITIVE */
emit_addi (j, T0, T0, scm_tc8_char); emit_addi (j, T0, T0, scm_tc8_char);
emit_sp_set_scm (j, dst, T0); emit_sp_set_scm (j, dst, T0);
} }
@ -2474,7 +2516,7 @@ static void
compile_untag_char (scm_jit_state *j, uint16_t dst, uint16_t src) compile_untag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
{ {
emit_sp_ref_scm (j, T0, 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 #if SIZEOF_UINTPTR_T >= 8
emit_sp_set_u64 (j, dst, T0); emit_sp_set_u64 (j, dst, T0);
#else #else
@ -3298,7 +3340,8 @@ compile_less (scm_jit_state *j, uint16_t a, uint16_t b)
emit_sp_ref_scm (j, T1, b); emit_sp_ref_scm (j, T1, b);
emit_andr (j, T2, T0, T1); 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, emit_call_2 (j, scm_vm_intrinsics.less_p,
jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0), jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0),
@ -3409,7 +3452,7 @@ compile_check_positional_arguments (scm_jit_state *j, uint32_t nreq, uint32_t ex
emit_ldr (j, obj, walk); emit_ldr (j, obj, walk);
jit_patch_there jit_patch_there
(j->jit, (j->jit,
emit_branch_if_immediate (j, obj), emit_branch_if_not_thob (j, obj),
head); head);
jit_patch_there jit_patch_there
(j->jit, (j->jit,
@ -3559,11 +3602,11 @@ static void
compile_untag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a) compile_untag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
{ {
emit_sp_ref_scm (j, T0, 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 #if SIZEOF_UINTPTR_T >= 8
emit_sp_set_s64 (j, dst, T0); emit_sp_set_s64 (j, dst, T0);
#else #else
/* FIXME: Untested! */ /* FIXME: Untested!, and also not updated for new tagging XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
emit_rshi (j, T1, T0, 31); emit_rshi (j, T1, T0, 31);
emit_sp_set_s64 (j, dst, T0, T1); emit_sp_set_s64 (j, dst, T0, T1);
#endif #endif
@ -3577,8 +3620,8 @@ compile_tag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
#else #else
emit_sp_ref_s32 (j, T0, a); emit_sp_ref_s32 (j, T0, a);
#endif #endif
emit_lshi (j, T0, T0, 2); emit_lshi (j, T0, T0, scm_fixnum_tag_size);
emit_addi (j, T0, T0, scm_tc2_int); emit_addi (j, T0, T0, scm_fixnum_tag);
emit_sp_set_scm (j, dst, T0); emit_sp_set_scm (j, dst, T0);
} }
@ -4260,6 +4303,15 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
comp (j, a, b); \ comp (j, a, b); \
} }
#define COMPILE_X8_S12_C12__N32(j, comp) \
{ \
uint16_t a, b; \
int32_t c; \
UNPACK_12_12 (j->ip[0], a, b); \
c = j->ip[1]; \
comp (j, a, b, j->ip + c); \
}
#define COMPILE_X8_S8_C8_S8(j, comp) \ #define COMPILE_X8_S8_C8_S8(j, comp) \
{ \ { \
uint8_t a, b, c; \ uint8_t a, b, c; \
@ -4270,6 +4322,8 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
COMPILE_X8_S8_C8_S8 (j, comp) COMPILE_X8_S8_C8_S8 (j, comp)
#define COMPILE_X8_S8_S8_S8(j, comp) \ #define COMPILE_X8_S8_S8_S8(j, comp) \
COMPILE_X8_S8_C8_S8 (j, comp) COMPILE_X8_S8_C8_S8 (j, comp)
#define COMPILE_X8_S8_C8_C8(j, comp) \
COMPILE_X8_S8_C8_S8 (j, comp)
#define COMPILE_X8_S8_I16(j, comp) \ #define COMPILE_X8_S8_I16(j, comp) \
{ \ { \

6
libguile/list.c
View file

@ -40,9 +40,9 @@
/* creating lists */ /* creating lists */
#define SCM_I_CONS(cell, x, y) \ #define SCM_I_CONS(cell, x, y) \
do { \ do { \
cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \ cell = SCM_ADD_PAIR_TAG (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y))); \
} while (0) } while (0)
SCM SCM

2
libguile/modules.h
View file

@ -31,7 +31,7 @@ SCM_API int scm_module_system_booted_p;
SCM_API scm_t_bits scm_module_tag; SCM_API scm_t_bits scm_module_tag;
#define SCM_MODULEP(OBJ) \ #define SCM_MODULEP(OBJ) \
(!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) (SCM_THOB_P (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
#define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module") #define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module")

2
libguile/numbers.c
View file

@ -148,7 +148,7 @@ VARARG_MPZ_ITERATOR (mpz_clear)
#define SCM_I_NUMTAG_COMPLEX scm_tc16_complex #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
#define SCM_I_NUMTAG(x) \ #define SCM_I_NUMTAG(x) \
(SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \ (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
: (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \ : (!SCM_THOB_P(x) ? SCM_I_NUMTAG_NOTNUM \
: (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \ : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
: SCM_I_NUMTAG_NOTNUM))) : SCM_I_NUMTAG_NOTNUM)))
*/ */

33
libguile/numbers.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_NUMBERS_H #ifndef SCM_NUMBERS_H
#define 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. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -38,7 +38,7 @@
* In the current implementation, Inums must also fit within a long * In the current implementation, Inums must also fit within a long
* because that's what GMP's mpz_*_si functions accept. */ * because that's what GMP's mpz_*_si functions accept. */
typedef long scm_t_inum; 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_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1))
#define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 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. */ NOTE: X must not perform side effects. */
#ifdef __GNUC__ #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 #else
# define SCM_I_INUM(x) \ # define SCM_I_INUM(x) \
(SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \ (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \
? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2) \ ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> scm_fixnum_tag_size) \
: (scm_t_inum) (SCM_UNPACK (x) >> 2)) : (scm_t_inum) (SCM_UNPACK (x) >> scm_fixnum_tag_size))
#endif #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_NINUMP(x) (!SCM_I_INUMP (x))
#define SCM_I_MAKINUM(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. */ /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */
#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) #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 /* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that
* differ in one bit: This way, checking if an object is an inexact number can * only differ in one bit: This way, checking if an object is an inexact
* be done quickly (using the TYP16S macro). */ * number can be done quickly. */
/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP /* Number subtype 1 to 4 (note the dependency on SCM_INEXACTP) */
* and SCM_NUMP) */
#define scm_tc16_big (scm_tc7_number + 1 * 256L) #define scm_tc16_big (scm_tc7_number + 1 * 256L)
#define scm_tc16_real (scm_tc7_number + 2 * 256L) #define scm_tc16_real (scm_tc7_number + 2 * 256L)
#define scm_tc16_complex (scm_tc7_number + 3 * 256L) #define scm_tc16_complex (scm_tc7_number + 3 * 256L)
#define scm_tc16_fraction (scm_tc7_number + 4 * 256L) #define scm_tc16_fraction (scm_tc7_number + 4 * 256L)
#define SCM_INEXACTP(x) \ #define SCM_INEXACTP(x) \
(!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real) (SCM_THOB_P (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_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex)) #define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))

14
libguile/pairs.h
View file

@ -67,11 +67,11 @@
/* #nil is null. */ /* #nil is null. */
#define scm_is_null(x) (scm_is_null_or_nil(x)) #define scm_is_null(x) (scm_is_null_or_nil(x))
#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x))) #define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (SCM_REMOVE_PAIR_TAG (x))))
#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x))) #define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (SCM_REMOVE_PAIR_TAG (x))))
#define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v)))) #define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 (SCM_REMOVE_PAIR_TAG (x), (v))))
#define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v)))) #define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 (SCM_REMOVE_PAIR_TAG (x), (v))))
#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) #define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) #define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
@ -152,7 +152,7 @@ SCM_INLINE SCM scm_cdr (SCM x);
SCM_INLINE_IMPLEMENTATION SCM SCM_INLINE_IMPLEMENTATION SCM
scm_cons (SCM x, SCM y) scm_cons (SCM x, SCM y)
{ {
return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); return SCM_ADD_PAIR_TAG (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)));
} }
SCM_INLINE_IMPLEMENTATION int SCM_INLINE_IMPLEMENTATION int
@ -163,7 +163,7 @@ scm_is_pair (SCM x)
Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
the fetch of the tag word from x is done before confirming it's a the fetch of the tag word from x is done before confirming it's a
non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a tagged heap object (SCM_THOB_P). Needless to say that bombs if x is
immediate. This was seen to afflict scm_srfi1_split_at and something immediate. This was seen to afflict scm_srfi1_split_at and something
deep in the bowels of ceval(). In both cases segvs resulted from deep in the bowels of ceval(). In both cases segvs resulted from
deferencing a random immediate value. srfi-1.test exposes the problem deferencing a random immediate value. srfi-1.test exposes the problem
@ -219,7 +219,7 @@ scm_is_mutable_pair (SCM x)
read-only, shareable section of the file. Attempting to mutate a read-only, shareable section of the file. Attempting to mutate a
pair in the read-only section would cause a segmentation fault, so pair in the read-only section would cause a segmentation fault, so
to avoid that, we really do need to enforce the restriction. */ to avoid that, we really do need to enforce the restriction. */
return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (x)); return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (SCM_REMOVE_PAIR_TAG (x)));
} }
#endif /* BUILDING_LIBGUILE */ #endif /* BUILDING_LIBGUILE */

30
libguile/print.c
View file

@ -591,21 +591,12 @@ print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
static void static void
iprin1 (SCM exp, SCM port, scm_print_state *pstate) iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
switch (SCM_ITAG3 (exp)) switch (SCM_ITAG (exp))
{ {
case scm_tc3_tc7_1: case scm_itags_fixnum:
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:
scm_intprint (SCM_I_INUM (exp), 10, port); scm_intprint (SCM_I_INUM (exp), 10, port);
break; break;
case scm_tc3_imm24: case scm_itags_imm24:
if (SCM_CHARP (exp)) if (SCM_CHARP (exp))
{ {
if (SCM_WRITINGP (pstate)) if (SCM_WRITINGP (pstate))
@ -624,7 +615,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_ipruk ("immediate", exp, port); scm_ipruk ("immediate", exp, port);
} }
break; break;
case scm_tc3_cons: case scm_itags_pair:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist ("(", exp, ')', port, pstate);
EXIT_NESTED_DATA (pstate);
break;
case scm_itags_thob:
switch (SCM_TYP7 (exp)) switch (SCM_TYP7 (exp))
{ {
case scm_tcs_struct: case scm_tcs_struct:
@ -647,12 +643,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate); EXIT_NESTED_DATA (pstate);
} }
break; 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: circref:
print_circref (port, pstate, exp); print_circref (port, pstate, exp);
break; break;
@ -787,7 +777,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate); EXIT_NESTED_DATA (pstate);
break; break;
default: default:
/* case scm_tcs_closures: */ /* fall through */
punk: punk:
scm_ipruk ("type", exp, port); scm_ipruk ("type", exp, port);
} }

2
libguile/procprop.c
View file

@ -324,7 +324,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
return src; return src;
if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc) if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
&& SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc)))) && SCM_THOB_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
continue; continue;
} }
while (0); while (0);

4
libguile/read.c
View file

@ -764,7 +764,7 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
str = scm_string_downcase_x (str); str = scm_string_downcase_x (str);
result = scm_string_to_symbol (str); result = scm_string_to_symbol (str);
} }
else if (SCM_NIMP (result)) else if (SCM_HEAP_OBJECT_P (result))
result = maybe_annotate_source (result, port, opts, line, column); result = maybe_annotate_source (result, port, opts, line, column);
scm_set_port_column_x (port, scm_set_port_column_x (port,
@ -1661,7 +1661,7 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
if (opts->record_positions_p && SCM_NIMP (got) if (opts->record_positions_p && SCM_HEAP_OBJECT_P (got)
&& !scm_i_has_source_properties (got)) && !scm_i_has_source_properties (got))
scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port)); scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));

78
libguile/scm.h
View file

@ -420,43 +420,52 @@ typedef uintptr_t scm_t_bits;
/* Checking if a SCM variable holds an immediate or a heap object. This /* Checking if a SCM variable holds a tagged heap object (thob). */
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))
#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 #define scm_thob_tag 0
for the definition of the following macros: SCM_I_FIXNUM_BIT, #define scm_thob_tag_mask 7
SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */ #define scm_thob_tag_size 3
#define SCM_THOB_P(x) ((SCM_UNPACK (x) & scm_thob_tag_mask) == scm_thob_tag)
#define scm_pair_tag 6
#define scm_pair_tag_mask 15
#define scm_pair_tag_size 4
/* Checking if a SCM variable holds a pair (for historical reasons, in /* 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 Guile also known as a cons-cell). */
the SCM variable holds a heap object, and second, by checking that #define SCM_I_CONSP(x) \
tc1==0 holds for the SCM_CELL_TYPE of the SCM variable. */ ((SCM_UNPACK (x) & scm_pair_tag_mask) == scm_pair_tag)
#define SCM_I_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
#define SCM_HEAP_OBJECT_P(x) (SCM_THOB_P (x) || SCM_I_CONSP (x))
/* Definitions for tc2: */ /* Definitions for immediate tags: */
#define scm_tc2_int 2 #define scm_itag_mask 15
#define scm_itag_mask_size 4
#define SCM_ITAG(x) (SCM_UNPACK (x) & scm_itag_mask)
#define scm_itags_thob 0: case 8
#define scm_itags_fixnum 15
#define scm_itags_pair 6
#define scm_itags_imm24 14
#define scm_fixnum_tag 15
#define scm_fixnum_tag_mask 15
#define scm_fixnum_tag_size 4
/* Definitions for tc3: */ /* Definitions for tc3: */
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
#define scm_tc3_cons 0
#define scm_tc3_struct 1 #define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0)
#define scm_tc3_unused 3
#define scm_tc3_imm24 4 /* Definitions for tc4: */
#define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4) #define scm_tc4_imm24 14
#define scm_tc3_tc7_2 7
/* Definitions for tc7: */ /* Definitions for tc7: */
@ -464,15 +473,14 @@ typedef uintptr_t scm_t_bits;
#define SCM_ITAG7(x) (0x7f & SCM_UNPACK (x)) #define SCM_ITAG7(x) (0x7f & SCM_UNPACK (x))
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x)) #define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
#define SCM_HAS_HEAP_TYPE(x, type, tag) \ #define SCM_HAS_HEAP_TYPE(x, type, tag) \
(SCM_NIMP (x) && type (x) == (tag)) (SCM_THOB_P (x) && type (x) == (tag))
#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag)) #define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
/* These type codes form part of the ABI and cannot be changed in a /* 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 stable series. If you do change them in a development series,
object type code (see above). If you do change them in a development change them also in (system vm assembler) and (system base types).
series, change them also in (system vm assembler) and (system base Bonus points if you change the build to define these tag values
types). Bonus points if you change the build to define these tag in only one place! */
values in only one place! */
#define scm_tc7_symbol 0x05 #define scm_tc7_symbol 0x05
#define scm_tc7_variable 0x07 #define scm_tc7_variable 0x07
@ -520,10 +528,10 @@ typedef uintptr_t scm_t_bits;
enum scm_tc8_tags enum scm_tc8_tags
{ {
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */ scm_tc8_flag = scm_tc4_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */ scm_tc8_char = scm_tc4_imm24 + 0x10, /* characters */
scm_tc8_unused_0 = scm_tc3_imm24 + 0x10, scm_tc8_unused_0 = scm_tc4_imm24 + 0x20,
scm_tc8_unused_1 = scm_tc3_imm24 + 0x18 scm_tc8_unused_1 = scm_tc4_imm24 + 0x30
}; };
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff) #define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)

12
libguile/srcprop.c
View file

@ -103,7 +103,9 @@ scm_t_bits scm_tc16_srcprops;
static int static int
supports_source_props (SCM obj) supports_source_props (SCM obj)
{ {
return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj); return (SCM_THOB_P (obj)
? (!scm_is_symbol (obj) && !scm_is_keyword (obj))
: scm_is_pair (obj));
} }
@ -188,7 +190,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
"Return the source property association list of @var{obj}.") "Return the source property association list of @var{obj}.")
#define FUNC_NAME s_scm_source_properties #define FUNC_NAME s_scm_source_properties
{ {
if (SCM_IMP (obj)) if (!SCM_HEAP_OBJECT_P (obj))
return SCM_EOL; return SCM_EOL;
else else
{ {
@ -204,7 +206,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
#define SCM_VALIDATE_NIM(pos, scm) \ #define SCM_VALIDATE_NIM(pos, scm) \
SCM_MAKE_VALIDATE_MSG (pos, scm, NIMP, "non-immediate") SCM_MAKE_VALIDATE_MSG (pos, scm, HEAP_OBJECT_P, "non-immediate")
/* Perhaps this procedure should look through an alist /* Perhaps this procedure should look through an alist
and try to make a srcprops-object...? */ and try to make a srcprops-object...? */
@ -226,7 +228,7 @@ int
scm_i_has_source_properties (SCM obj) scm_i_has_source_properties (SCM obj)
#define FUNC_NAME "%set-source-properties" #define FUNC_NAME "%set-source-properties"
{ {
if (SCM_IMP (obj)) if (!SCM_HEAP_OBJECT_P (obj))
return 0; return 0;
else else
return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F)); return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
@ -257,7 +259,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
{ {
SCM p; SCM p;
if (SCM_IMP (obj)) if (!SCM_HEAP_OBJECT_P (obj))
return SCM_BOOL_F; return SCM_BOOL_F;
p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);

2
libguile/struct.c
View file

@ -322,7 +322,7 @@ struct_finalizer_trampoline (void *ptr, void *unused_data)
} }
/* A struct is a sequence of words preceded by a pointer to the struct's /* A struct is a sequence of words preceded by a pointer to the struct's
vtable. The vtable reference is tagged with the struct tc3. */ vtable. The vtable reference is tagged with the struct tag. */
static SCM static SCM
scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words) scm_i_alloc_struct (scm_t_bits vtable_bits, int n_words)
{ {

2
libguile/struct.h
View file

@ -109,7 +109,7 @@
typedef void (*scm_t_struct_finalize) (SCM obj); 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_THOB_P(X) && (SCM_CELL_TYPE (X) & 7) == scm_tc3_struct)
#define SCM_STRUCT_SLOTS(X) (SCM_CELL_OBJECT_LOC(X, 1)) #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_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
#define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V) #define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V)

2
libguile/vectors.h
View file

@ -79,7 +79,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
immutability. */ immutability. */
#define SCM_F_VECTOR_IMMUTABLE 0x80UL #define SCM_F_VECTOR_IMMUTABLE 0x80UL
#define SCM_I_IS_MUTABLE_VECTOR(x) \ #define SCM_I_IS_MUTABLE_VECTOR(x) \
(SCM_NIMP (x) && \ (SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \ ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \
== scm_tc7_vector)) == scm_tc7_vector))
#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector)) #define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))

94
libguile/vm-engine.c
View file

@ -3234,10 +3234,96 @@ VM_NAME (scm_thread *thread)
VM_DEFINE_OP (153, f64_set, "f64-set!", OP1 (X8_S8_S8_S8)) VM_DEFINE_OP (153, f64_set, "f64-set!", OP1 (X8_S8_S8_S8))
PTR_SET (double, F64); PTR_SET (double, F64);
VM_DEFINE_OP (154, unused_154, NULL, NOP) /* make-tagged-non-immediate dst:12 tag:12 offset:32
VM_DEFINE_OP (155, unused_155, NULL, NOP) *
VM_DEFINE_OP (156, unused_156, NULL, NOP) * Load a pointer to statically allocated memory into DST, with TAG
VM_DEFINE_OP (157, unused_157, NULL, NOP) * applied. The object's memory will be found OFFSET 32-bit words
* away from the current instruction pointer. OFFSET is a signed
* value. The intention here is that the compiler would produce an
* object file containing the words of a non-immediate object, and
* this instruction creates a pointer to that memory, effectively
* resurrecting that object.
*
* Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader.
*/
VM_DEFINE_OP (154, make_tagged_non_immediate, "make-tagged-non-immediate", DOP2 (X8_S12_C12, N32))
{
uint32_t dst, tag;
int32_t offset;
uint32_t* loc;
scm_t_bits unpacked;
UNPACK_12_12 (op, dst, tag);
offset = ip[1];
loc = ip + offset;
unpacked = (scm_t_bits) loc;
VM_ASSERT (!(unpacked & scm_pair_tag_mask), abort()); /* temporary debugging hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
SP_SET (dst, SCM_PACK (unpacked + tag));
NEXT (2);
}
/* tagged-scm-ref/immediate dst:8 obj:8 byte-offset:8
*
* Load the SCM object at BYTE-OFFSET from local OBJ, and store it to
* DST. BYTE-OFFSET is a int8_t immediate. The resulting address
* must be aligned on a word boundary. This is intended to be used
* when OBJ is a tagged pointer, with BYTE-OFFSET equal to the true
* byte offset minus OBJ's pointer tag.
*/
VM_DEFINE_OP (155, tagged_scm_ref_immediate, "tagged-scm-ref/immediate", DOP1 (X8_S8_S8_C8))
{
uint8_t dst, obj;
int8_t byte_offset;
UNPACK_8_8_8 (op, dst, obj, byte_offset);
SP_SET (dst, SCM_CELL_OBJECT_0 (SCM_PACK (byte_offset + SCM_UNPACK (SP_REF (obj)))));
NEXT (1);
}
/* tagged-scm-set!/immediate obj:8 byte-offset:8 val:8
*
* Store the SCM local VAL into object OBJ at BYTE-OFFSET.
* BYTE-OFFSET is an int8_t immediate. The resulting address must be
* aligned on a word boundary. This is intended to be used when OBJ
* is a tagged pointer, with BYTE-OFFSET equal to the true byte offset
* minus OBJ's pointer tag.
*/
VM_DEFINE_OP (156, tagged_scm_set_immediate, "tagged-scm-set!/immediate", OP1 (X8_S8_C8_S8))
{
uint8_t obj, val;
int8_t byte_offset;
UNPACK_8_8_8 (op, obj, byte_offset, val);
SCM_SET_CELL_OBJECT_0 (SCM_PACK (byte_offset + SCM_UNPACK (SP_REF (obj))),
SP_REF (val));
NEXT (1);
}
/* tagged-allocate-words/immediate dst:8 count:8 tag:8
*
* Allocate a fresh GC-traced object consisting of COUNT words and
* store it into DST with TAG applied. COUNT and TAG are immediates.
*/
VM_DEFINE_OP (157, tagged_allocate_words_immediate, "tagged-allocate-words/immediate", DOP1 (X8_S8_C8_C8))
{
uint8_t dst, size, tag;
UNPACK_8_8_8 (op, dst, size, tag);
SYNC_IP ();
SP_SET (dst, SCM_PACK (tag + SCM_UNPACK (CALL_INTRINSIC (allocate_words, (thread, size)))));
NEXT (1);
}
VM_DEFINE_OP (158, unused_158, NULL, NOP) VM_DEFINE_OP (158, unused_158, NULL, NOP)
VM_DEFINE_OP (159, unused_159, NULL, NOP) VM_DEFINE_OP (159, unused_159, NULL, NOP)
VM_DEFINE_OP (160, unused_160, NULL, NOP) VM_DEFINE_OP (160, unused_160, NULL, NOP)

4
libguile/vm.c
View file

@ -748,8 +748,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
break; break;
case SLOT_DESC_UNUSED: case SLOT_DESC_UNUSED:
case SLOT_DESC_LIVE_GC: case SLOT_DESC_LIVE_GC:
if (SCM_NIMP (sp->as_scm) && if (SCM_HEAP_OBJECT_P (sp->as_scm)
sp->as_ptr >= lower && sp->as_ptr <= upper) && sp->as_ptr >= lower && sp->as_ptr <= upper)
mark_stack_ptr = GC_mark_and_push (sp->as_ptr, mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
mark_stack_ptr, mark_stack_ptr,
mark_stack_limit, mark_stack_limit,

10
libguile/weak-set.c
View file

@ -419,9 +419,12 @@ resize_set (scm_t_weak_set *set)
new_entries[new_k].hash = copy.hash; new_entries[new_k].hash = copy.hash;
new_entries[new_k].key = copy.key; new_entries[new_k].key = copy.key;
if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) if (SCM_THOB_P (SCM_PACK (copy.key)))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key, SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
(void *) new_entries[new_k].key); (void *) new_entries[new_k].key);
else if (scm_is_pair (SCM_PACK (copy.key)))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
(void *) (new_entries[new_k].key - scm_pair_tag));
} }
} }
@ -580,9 +583,12 @@ weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
entries[k].hash = hash; entries[k].hash = hash;
entries[k].key = SCM_UNPACK (obj); entries[k].key = SCM_UNPACK (obj);
if (SCM_HEAP_OBJECT_P (obj)) if (SCM_THOB_P (obj))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key, SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
(void *) SCM2PTR (obj)); (void *) SCM2PTR (obj));
else if (scm_is_pair (obj))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
(void *) SCM2PTR (SCM_REMOVE_PAIR_TAG (obj)));
return obj; return obj;
} }

8
libguile/weak-table.c
View file

@ -118,13 +118,17 @@ register_disappearing_links (scm_t_weak_entry *entry,
&& (kind == SCM_WEAK_TABLE_KIND_KEY && (kind == SCM_WEAK_TABLE_KIND_KEY
|| kind == SCM_WEAK_TABLE_KIND_BOTH)) || kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key, SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
SCM2PTR (k)); (scm_is_pair (k)
? SCM2PTR (SCM_REMOVE_PAIR_TAG (k))
: SCM2PTR (k)));
if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v) if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE && (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH)) || kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value, SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
SCM2PTR (v)); (scm_is_pair (v)
? SCM2PTR (SCM_REMOVE_PAIR_TAG (v))
: SCM2PTR (v)));
} }
static void static void

5
libguile/weak-vector.c
View file

@ -245,9 +245,12 @@ scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
elts[k] = x; elts[k] = x;
if (SCM_HEAP_OBJECT_P (x)) if (SCM_THOB_P (x))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k], SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
SCM2PTR (x)); SCM2PTR (x));
else if (scm_is_pair (x))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
SCM2PTR (SCM_REMOVE_PAIR_TAG (x)));
} }
#undef FUNC_NAME #undef FUNC_NAME

7
module/language/bytecode.scm
View file

@ -51,7 +51,9 @@
((X8_F12_F12) 2) ((X8_F12_F12) 2)
((X8_S8_S8_S8) 3) ((X8_S8_S8_S8) 3)
((X8_S8_S8_C8) 3) ((X8_S8_S8_C8) 3)
((X8_S8_C8_S8) 3))) ((X8_S8_C8_S8) 3)
((X8_S8_C8_C8) 3)
(else (error "unknown first word type" word))))
(define (tail-word-arity word) (define (tail-word-arity word)
(case word (case word
((C32) 1) ((C32) 1)
@ -74,7 +76,8 @@
((X8_S24) 1) ((X8_S24) 1)
((X8_F24) 1) ((X8_F24) 1)
((X8_C24) 1) ((X8_C24) 1)
((X8_L24) 1))) ((X8_L24) 1)
(else (error "unknown tail word type" word))))
(match args (match args
((arg0 . args) ((arg0 . args)
(fold (lambda (arg arity) (fold (lambda (arg arity)

2
module/language/cps/closure-conversion.scm
View file

@ -555,7 +555,7 @@ term."
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'allocate-words/immediate `(pair . 2) ()))))) ($primcall 'tagged-allocate-words/immediate `(pair . 2) ())))))
;; Well-known callee with more than two free variables; the closure ;; Well-known callee with more than two free variables; the closure
;; is a vector. ;; is a vector.
(#(#t nfree) (#(#t nfree)

30
module/language/cps/compile-bytecode.scm
View file

@ -38,6 +38,7 @@
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language cps intset) #:use-module (language cps intset)
#:use-module (system vm assembler) #:use-module (system vm assembler)
#:use-module (system base target)
#:use-module (system base types internal) #:use-module (system base types internal)
#:export (compile-bytecode)) #:export (compile-bytecode))
@ -161,16 +162,29 @@
(emit-allocate-words asm (from-sp dst) (from-sp (slot nfields)))) (emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
(($ $primcall 'allocate-words/immediate (annotation . nfields)) (($ $primcall 'allocate-words/immediate (annotation . nfields))
(emit-allocate-words/immediate asm (from-sp dst) nfields)) (emit-allocate-words/immediate asm (from-sp dst) nfields))
(($ $primcall 'tagged-allocate-words/immediate (annotation . nfields))
(let ((tag (match annotation
('pair (target-pair-tag)))))
(emit-tagged-allocate-words/immediate asm (from-sp dst) nfields
tag)))
(($ $primcall 'scm-ref annotation (obj idx)) (($ $primcall 'scm-ref annotation (obj idx))
(emit-scm-ref asm (from-sp dst) (from-sp (slot obj)) (emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'scm-ref/tag annotation (obj)) (($ $primcall 'scm-ref/tag annotation (obj))
(let ((tag (match annotation (let ((tag (match annotation
('pair %tc1-pair) ('pair 0) ; TAGS-SENSITIVE
('struct %tc3-struct)))) ('struct %tc3-struct))))
(emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag))) (emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
(($ $primcall 'scm-ref/immediate (annotation . idx) (obj)) (($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
(emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx)) (emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
(($ $primcall 'tagged-scm-ref/immediate (annotation . idx) (obj))
(let* ((tag (match annotation
('pair (target-pair-tag))))
(byte-offset-u (modulo (- (* idx (target-word-size))
tag)
256)))
(emit-tagged-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
byte-offset-u)))
(($ $primcall 'word-ref annotation (obj idx)) (($ $primcall 'word-ref annotation (obj idx))
(emit-word-ref asm (from-sp dst) (from-sp (slot obj)) (emit-word-ref asm (from-sp dst) (from-sp (slot obj))
(from-sp (slot idx)))) (from-sp (slot idx))))
@ -298,13 +312,21 @@
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'scm-set!/tag annotation (obj val)) (($ $primcall 'scm-set!/tag annotation (obj val))
(let ((tag (match annotation (let ((tag (match annotation
('pair %tc1-pair) ('pair 0) ; TAGS-SENSITIVE
('struct %tc3-struct)))) ('struct %tc3-struct))))
(emit-scm-set!/tag asm (from-sp (slot obj)) tag (emit-scm-set!/tag asm (from-sp (slot obj)) tag
(from-sp (slot val))))) (from-sp (slot val)))))
(($ $primcall 'scm-set!/immediate (annotation . idx) (obj val)) (($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
(emit-scm-set!/immediate asm (from-sp (slot obj)) idx (emit-scm-set!/immediate asm (from-sp (slot obj)) idx
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'tagged-scm-set!/immediate (annotation . idx) (obj val))
(let* ((tag (match annotation
('pair (target-pair-tag))))
(byte-offset-u (modulo (- (* idx (target-word-size))
tag)
256)))
(emit-tagged-scm-set!/immediate asm (from-sp (slot obj)) byte-offset-u
(from-sp (slot val)))))
(($ $primcall 'word-set! annotation (obj idx val)) (($ $primcall 'word-set! annotation (obj idx val))
(emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx)) (emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
@ -451,7 +473,8 @@
(match (vector op param args) (match (vector op param args)
;; Immediate type tag predicates. ;; Immediate type tag predicates.
(#('fixnum? #f (a)) (unary emit-fixnum? a)) (#('fixnum? #f (a)) (unary emit-fixnum? a))
(#('heap-object? #f (a)) (unary emit-heap-object? a)) (#('thob? #f (a)) (unary emit-thob? a))
(#('pair? #f (a)) (unary emit-pair? a))
(#('char? #f (a)) (unary emit-char? a)) (#('char? #f (a)) (unary emit-char? a))
(#('eq-false? #f (a)) (unary emit-eq-false? a)) (#('eq-false? #f (a)) (unary emit-eq-false? a))
(#('eq-nil? #f (a)) (unary emit-eq-nil? a)) (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
@ -464,7 +487,6 @@
(#('false? #f (a)) (unary emit-false? a)) (#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a)) (#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates. ;; Heap type tag predicates.
(#('pair? #f (a)) (unary emit-pair? a))
(#('struct? #f (a)) (unary emit-struct? a)) (#('struct? #f (a)) (unary emit-struct? a))
(#('symbol? #f (a)) (unary emit-symbol? a)) (#('symbol? #f (a)) (unary emit-symbol? a))
(#('variable? #f (a)) (unary emit-variable? a)) (#('variable? #f (a)) (unary emit-variable? a))

7
module/language/cps/contification.scm
View file

@ -32,6 +32,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system base target)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps renumber) #:use-module (language cps renumber)
#:use-module (language cps utils) #:use-module (language cps utils)
@ -387,15 +388,15 @@ function set."
(letk ktail (letk ktail
($kargs () () ($kargs () ()
($continue kdone src ($continue kdone src
($primcall 'scm-set!/immediate '(pair . 1) (pair tail))))) ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
(letk khead (letk khead
($kargs ('pair) (pair) ($kargs ('pair) (pair)
($continue ktail src ($continue ktail src
($primcall 'scm-set!/immediate '(pair . 0) (pair v))))) ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair v)))))
(letk ktail (letk ktail
($kargs ('tail) (tail) ($kargs ('tail) (tail)
($continue khead src ($continue khead src
($primcall 'allocate-words/immediate '(pair . 2) ())))) ($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))
($ (build-list ktail src vals)))))) ($ (build-list ktail src vals))))))
(cond (cond
((and (not rest) (eqv? (length vals) nreq)) ((and (not rest) (eqv? (length vals) nreq))

1
module/language/cps/cse.scm
View file

@ -255,6 +255,7 @@ false. It could be that both true and false proofs are available."
((scm-set! p s i x) (x <- scm-ref p s i)) ((scm-set! p s i x) (x <- scm-ref p s i))
((scm-set!/tag p s x) (x <- scm-ref/tag p s)) ((scm-set!/tag p s x) (x <- scm-ref/tag p s))
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s)) ((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
((tagged-scm-set!/immediate p s x) (x <- tagged-scm-ref/immediate p s))
((word-set! p s i x) (x <- word-ref p s i)) ((word-set! p s i x) (x <- word-ref p s i))
((word-set!/immediate p s x) (x <- word-ref/immediate p s)) ((word-set!/immediate p s x) (x <- word-ref/immediate p s))
((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s)) ((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s))

1
module/language/cps/dce.scm
View file

@ -191,6 +191,7 @@ sites."
(match exp (match exp
(($ $primcall (($ $primcall
(or 'scm-set! 'scm-set!/tag 'scm-set!/immediate (or 'scm-set! 'scm-set!/tag 'scm-set!/immediate
'tagged-scm-set!/immediate
'word-set! 'word-set!/immediate) _ 'word-set! 'word-set!/immediate) _
(obj . _)) (obj . _))
(or (var-live? obj live-vars) (or (var-live? obj live-vars)

16
module/language/cps/effects-analysis.scm
View file

@ -305,7 +305,7 @@ the LABELS that are clobbered by the effects of LABEL."
((null? arg)) ((null? arg))
((false? arg)) ((false? arg))
((nil? arg)) ((nil? arg))
((heap-object? arg)) ((thob? arg))
((pair? arg)) ((pair? arg))
((symbol? arg)) ((symbol? arg))
((variable? arg)) ((variable? arg))
@ -363,6 +363,11 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . size) ((ann . size)
(&allocate (&allocate
(annotation->memory-kind ann))))) (annotation->memory-kind ann)))))
((tagged-allocate-words/immediate)
(match param
((ann . size)
(&allocate
(annotation->memory-kind ann)))))
((scm-ref obj idx) (&read-object ((scm-ref obj idx) (&read-object
(annotation->memory-kind param))) (annotation->memory-kind param)))
((scm-ref/tag obj) (&read-field ((scm-ref/tag obj) (&read-field
@ -371,6 +376,10 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . idx) ((ann . idx)
(&read-field (&read-field
(annotation->memory-kind ann) idx)))) (annotation->memory-kind ann) idx))))
((tagged-scm-ref/immediate obj) (match param
((ann . idx)
(&read-field
(annotation->memory-kind ann) idx))))
((scm-set! obj idx val) (&write-object ((scm-set! obj idx val) (&write-object
(annotation->memory-kind param))) (annotation->memory-kind param)))
((scm-set/tag! obj val) (&write-field ((scm-set/tag! obj val) (&write-field
@ -379,6 +388,11 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . idx) ((ann . idx)
(&write-field (&write-field
(annotation->memory-kind ann) idx)))) (annotation->memory-kind ann) idx))))
((tagged-scm-set!/immediate obj val)
(match param
((ann . idx)
(&write-field
(annotation->memory-kind ann) idx))))
((word-ref obj idx) (&read-object ((word-ref obj idx) (&read-object
(annotation->memory-kind param))) (annotation->memory-kind param)))
((word-ref/immediate obj) (match param ((word-ref/immediate obj) (match param

12
module/language/cps/reify-primitives.scm
View file

@ -216,7 +216,7 @@
(with-cps cps (with-cps cps
(letk kres (letk kres
($kargs ('var) (var) ($kargs ('var) (var)
($branch kbad k src 'heap-object? #f (var)))) ($branch kbad k src 'thob? #f (var))))
(build-term (build-term
($continue kres src ($continue kres src
($primcall 'lookup #f (mod-var name-var))))))) ($primcall 'lookup #f (mod-var name-var)))))))
@ -262,7 +262,7 @@
(letk kok ($kargs () () ($continue k src ($values (cached))))) (letk kok ($kargs () () ($continue k src ($values (cached)))))
(letk ktest (letk ktest
($kargs ('cached) (cached) ($kargs ('cached) (cached)
($branch kinit kok src 'heap-object? #f (cached)))) ($branch kinit kok src 'thob? #f (cached))))
(build-term (build-term
($continue ktest src ($continue ktest src
($primcall 'cache-ref cache-key ())))))))) ($primcall 'cache-ref cache-key ()))))))))
@ -296,7 +296,7 @@
(letk kok ($kargs () () ($continue k src ($values (cached))))) (letk kok ($kargs () () ($continue k src ($values (cached)))))
(letk ktest (letk ktest
($kargs ('cached) (cached) ($kargs ('cached) (cached)
($branch kinit kok src 'heap-object? #f (cached)))) ($branch kinit kok src 'thob? #f (cached))))
(build-term (build-term
($continue ktest src ($continue ktest src
($primcall 'cache-ref cache-key ())))))))) ($primcall 'cache-ref cache-key ()))))))))
@ -531,6 +531,12 @@
(setk label ($kargs names vars (setk label ($kargs names vars
($continue kop src ($continue kop src
($primcall 'load-u64 idx ())))))))))) ($primcall 'load-u64 idx ()))))))))))
;; TODO: Consider adding cases for
;; 'tagged-allocate-words/immediate',
;; 'tagged-scm-ref/immediate' and
;; 'tagged-scm-set!/immediate', although at present
;; those primitives are only used for pairs, where the
;; byte-offset will always fit within the S8 operand.
(_ cps)))))))) (_ cps))))))))
(param (error "unexpected param to reified primcall" name)) (param (error "unexpected param to reified primcall" name))
(else (else

8
module/language/cps/type-fold.scm
View file

@ -94,11 +94,11 @@
((eqv? type type*) (values #t #t)) ((eqv? type type*) (values #t #t))
(else (values #f #f)))))) (else (values #f #f))))))
(define-unary-branch-folder (heap-object? type min max) (define-unary-branch-folder (thob? type min max)
(define &immediate-types (logior &fixnum &char &special-immediate)) (define &non-thob-types (logior &pair &fixnum &char &special-immediate))
(cond (cond
((zero? (logand type &immediate-types)) (values #t #t)) ((zero? (logand type &non-thob-types)) (values #t #t))
((type<=? type &immediate-types) (values #t #f)) ((type<=? type &non-thob-types) (values #t #f))
(else (values #f #f)))) (else (values #f #f))))
(define-unary-branch-folder (heap-number? type min max) (define-unary-branch-folder (heap-number? type min max)

28
module/language/cps/types.scm
View file

@ -615,12 +615,12 @@ minimum, and maximum."
(when (eqv? (&type val) &special-immediate) (when (eqv? (&type val) &special-immediate)
(restrict! val &special-immediate (1+ &false) +inf.0))))) (restrict! val &special-immediate (1+ &false) +inf.0)))))
(define-predicate-inferrer (heap-object? val true?) (define-predicate-inferrer (thob? val true?)
(define &immediate-types (define &non-thob-types
(logior &fixnum &char &special-immediate)) (logior &pair &fixnum &char &special-immediate))
(define &heap-object-types (define &thob-types
(logand &all-types (lognot &immediate-types))) (logand &all-types (lognot &non-thob-types)))
(restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0)) (restrict! val (if true? &thob-types &non-thob-types) -inf.0 +inf.0))
(define-predicate-inferrer (heap-number? val true?) (define-predicate-inferrer (heap-number? val true?)
(define &heap-number-types (define &heap-number-types
@ -742,6 +742,11 @@ minimum, and maximum."
((annotation . size) ((annotation . size)
(define! result (annotation->type annotation) size size)))) (define! result (annotation->type annotation) size size))))
(define-type-inferrer/param (tagged-allocate-words/immediate param result)
(match param
((annotation . size)
(define! result (annotation->type annotation) size size))))
(define-type-inferrer/param (scm-ref param obj idx result) (define-type-inferrer/param (scm-ref param obj idx result)
(restrict! obj (annotation->type param) (restrict! obj (annotation->type param)
(1+ (&min/0 idx)) (target-max-size-t/scm)) (1+ (&min/0 idx)) (target-max-size-t/scm))
@ -753,6 +758,12 @@ minimum, and maximum."
(restrict! obj (annotation->type annotation) (1+ idx) +inf.0) (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
(define! result &all-types -inf.0 +inf.0)))) (define! result &all-types -inf.0 +inf.0))))
(define-type-inferrer/param (tagged-scm-ref/immediate param obj result)
(match param
((annotation . idx)
(restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
(define! result &all-types -inf.0 +inf.0))))
(define-type-inferrer/param (scm-ref/tag param obj result) (define-type-inferrer/param (scm-ref/tag param obj result)
(restrict! obj (annotation->type param) -inf.0 +inf.0) (restrict! obj (annotation->type param) -inf.0 +inf.0)
(define! result &all-types -inf.0 +inf.0)) (define! result &all-types -inf.0 +inf.0))
@ -767,6 +778,11 @@ minimum, and maximum."
((annotation . idx) ((annotation . idx)
(restrict! obj (annotation->type annotation) (1+ idx) +inf.0)))) (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
(define-type-inferrer/param (tagged-scm-set!/immediate param obj val)
(match param
((annotation . idx)
(restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
(define-type-inferrer/param (word-ref param obj idx result) (define-type-inferrer/param (word-ref param obj idx result)
(restrict! obj (annotation->type param) (restrict! obj (annotation->type param)
(1+ (&min/0 idx)) (target-max-size-t/scm)) (1+ (&min/0 idx)) (target-max-size-t/scm))

47
module/language/tree-il/compile-cps.scm
View file

@ -104,7 +104,7 @@
($continue kcast src ($continue kcast src
($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen))))) ($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen)))))
(letk krsh (letk krsh
($kargs ('w0) (w0) ($kargs ('w0) (w0) ;TAGS-SENSITIVE
($continue kassume src ($primcall 'ursh/immediate 8 (w0))))) ($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
(letk kv (letk kv
($kargs () () ($kargs () ()
@ -114,7 +114,7 @@
($kargs () () ($kargs () ()
($branch knot-vector kv src pred #f (v)))) ($branch knot-vector kv src pred #f (v))))
(build-term (build-term
($branch knot-vector kheap-object src 'heap-object? #f (v))))) ($branch knot-vector kheap-object src 'thob? #f (v)))))
(define (untag-fixnum-index-in-range cps src op idx slen have-index-in-range) (define (untag-fixnum-index-in-range cps src op idx slen have-index-in-range)
;; Precondition: SLEN is a non-negative S64 that is representable as a ;; Precondition: SLEN is a non-negative S64 that is representable as a
@ -342,7 +342,7 @@
(letk ktag0 (letk ktag0
($kargs ('v) (v) ($kargs ('v) (v)
($continue ktag1 src ($continue ktag1 src
($primcall 'ulsh/immediate 8 (usize))))) ($primcall 'ulsh/immediate 8 (usize))))) ;TAGS-SENSITIVE
(letk kalloc (letk kalloc
($kargs ('nwords) (nwords) ($kargs ('nwords) (nwords)
($continue ktag0 src ($continue ktag0 src
@ -420,8 +420,7 @@
(letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x)))) (letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x))))
(let$ body (is-pair)) (let$ body (is-pair))
(letk k ($kargs () () ,body)) (letk k ($kargs () () ,body))
(letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x)))) (build-term ($branch knot-pair k src 'pair? #f (x)))))
(build-term ($branch knot-pair kheap-object src 'heap-object? #f (x)))))
(define-primcall-converter cons (define-primcall-converter cons
(lambda (cps k src op param head tail) (lambda (cps k src op param head tail)
@ -433,14 +432,14 @@
(letk ktail (letk ktail
($kargs () () ($kargs () ()
($continue kdone src ($continue kdone src
($primcall 'scm-set!/immediate '(pair . 1) (pair tail))))) ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
(letk khead (letk khead
($kargs ('pair) (pair) ($kargs ('pair) (pair)
($continue ktail src ($continue ktail src
($primcall 'scm-set!/immediate '(pair . 0) (pair head))))) ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair head)))))
(build-term (build-term
($continue khead src ($continue khead src
($primcall 'allocate-words/immediate '(pair . 2) ())))))) ($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))))
(define-primcall-converter car (define-primcall-converter car
(lambda (cps k src op param pair) (lambda (cps k src op param pair)
@ -450,7 +449,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'scm-ref/immediate '(pair . 0) (pair))))))))) ($primcall 'tagged-scm-ref/immediate '(pair . 0) (pair)))))))))
(define-primcall-converter cdr (define-primcall-converter cdr
(lambda (cps k src op param pair) (lambda (cps k src op param pair)
@ -460,7 +459,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'scm-ref/immediate '(pair . 1) (pair))))))))) ($primcall 'tagged-scm-ref/immediate '(pair . 1) (pair)))))))))
(define-primcall-converter set-car! (define-primcall-converter set-car!
(lambda (cps k src op param pair val) (lambda (cps k src op param pair val)
@ -471,7 +470,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'scm-set!/immediate '(pair . 0) (pair val))))))))) ($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair val)))))))))
(define-primcall-converter set-cdr! (define-primcall-converter set-cdr!
(lambda (cps k src op param pair val) (lambda (cps k src op param pair val)
@ -482,7 +481,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'scm-set!/immediate '(pair . 1) (pair val))))))))) ($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair val)))))))))
(define-primcall-converter box (define-primcall-converter box
(lambda (cps k src op param val) (lambda (cps k src op param val)
@ -517,7 +516,7 @@
(let$ body (is-box)) (let$ body (is-box))
(letk k ($kargs () () ,body)) (letk k ($kargs () () ,body))
(letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x)))) (letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x))))
(build-term ($branch knot-box kheap-object src 'heap-object? #f (x))))) (build-term ($branch knot-box kheap-object src 'thob? #f (x)))))
(define-primcall-converter box-ref (define-primcall-converter box-ref
(lambda (cps k src op param box) (lambda (cps k src op param box)
@ -562,7 +561,7 @@
($continue k src ($primcall 'scm-ref/tag 'struct (x))))) ($continue k src ($primcall 'scm-ref/tag 'struct (x)))))
(letk kheap-object (letk kheap-object
($kargs () () ($branch knot-struct kvtable src 'struct? #f (x)))) ($kargs () () ($branch knot-struct kvtable src 'struct? #f (x))))
(build-term ($branch knot-struct kheap-object src 'heap-object? #f (x))))) (build-term ($branch knot-struct kheap-object src 'thob? #f (x)))))
(define-primcall-converter struct-vtable (define-primcall-converter struct-vtable
(lambda (cps k src op param struct) (lambda (cps k src op param struct)
@ -859,7 +858,7 @@
(with-cps cps (with-cps cps
(letk kf ($kargs () () ($throw src 'throw/value+data bad-type (x)))) (letk kf ($kargs () () ($throw src 'throw/value+data bad-type (x))))
(letk kheap-object ($kargs () () ($branch kf k src pred #f (x)))) (letk kheap-object ($kargs () () ($branch kf k src pred #f (x))))
(build-term ($branch kf kheap-object src 'heap-object? #f (x))))) (build-term ($branch kf kheap-object src 'thob? #f (x)))))
(define (prepare-bytevector-access cps src op pred bv idx width (define (prepare-bytevector-access cps src op pred bv idx width
have-ptr-and-uidx) have-ptr-and-uidx)
@ -1104,7 +1103,7 @@
($kargs () () ($kargs () ()
($branch knot-string ks src 'string? #f (x)))) ($branch knot-string ks src 'string? #f (x))))
(build-term (build-term
($branch knot-string kheap-object src 'heap-object? #f (x))))) ($branch knot-string kheap-object src 'thob? #f (x)))))
(define (ensure-char cps src op x have-char) (define (ensure-char cps src op x have-char)
(define msg "Wrong type argument (expecting char): ~S") (define msg "Wrong type argument (expecting char): ~S")
@ -1133,7 +1132,7 @@
(lambda (cps k src op param s idx) (lambda (cps k src op param s idx)
(define out-of-range (define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S")) #(out-of-range string-ref "Argument 2 out of range: ~S"))
(define stringbuf-f-wide #x400) (define stringbuf-f-wide #x400) ;TAGS-SENSITIVE
(ensure-string (ensure-string
cps src op s cps src op s
(lambda (cps ulen) (lambda (cps ulen)
@ -1203,7 +1202,7 @@
(lambda (cps k src op param s idx ch) (lambda (cps k src op param s idx ch)
(define out-of-range (define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S")) #(out-of-range string-ref "Argument 2 out of range: ~S"))
(define stringbuf-f-wide #x400) (define stringbuf-f-wide #x400) ;TAGS-SENSITIVE
(ensure-string (ensure-string
cps src op s cps src op s
(lambda (cps ulen) (lambda (cps ulen)
@ -1327,7 +1326,7 @@
(let$ body (is-atomic-box)) (let$ body (is-atomic-box))
(letk k ($kargs () () ,body)) (letk k ($kargs () () ,body))
(letk kheap-object ($kargs () () ($branch kbad k src 'atomic-box? #f (x)))) (letk kheap-object ($kargs () () ($branch kbad k src 'atomic-box? #f (x))))
(build-term ($branch kbad kheap-object src 'heap-object? #f (x))))) (build-term ($branch kbad kheap-object src 'thob? #f (x)))))
(define-primcall-converter atomic-box-ref (define-primcall-converter atomic-box-ref
(lambda (cps k src op param x) (lambda (cps k src op param x)
@ -1421,7 +1420,7 @@
($ (have-var box))))))) ($ (have-var box)))))))
(letk ktest ($kargs () () ,body)) (letk ktest ($kargs () () ,body))
(letk kbox ($kargs ('box) (box) (letk kbox ($kargs ('box) (box)
($branch kbad ktest src 'heap-object? #f (box)))) ($branch kbad ktest src 'thob? #f (box))))
(letk kname ($kargs ('name) (name-var) (letk kname ($kargs ('name) (name-var)
($continue kbox src ($continue kbox src
($primcall 'lookup #f (mod name-var))))) ($primcall 'lookup #f (mod name-var)))))
@ -2136,7 +2135,7 @@
(letk kt* ($kargs () () (letk kt* ($kargs () ()
($branch kf kt src name #f args))) ($branch kf kt src name #f args)))
(build-term (build-term
($branch kf kt* src 'heap-object? #f args))) ($branch kf kt* src 'thob? #f args)))
(with-cps cps (with-cps cps
(build-term ($branch kf kt src name #f args))))))) (build-term ($branch kf kt src name #f args)))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
@ -2459,10 +2458,8 @@ integer."
(heap-number? b) (heap-number? b)
(bool (primcall heap-numbers-equal? a b)))) (bool (primcall heap-numbers-equal? a b))))
('equal? ('equal?
;; Partially inline. ;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
(primcall-chain (heap-object? a) (primcall equal? a b)))))))
(heap-object? b)
(primcall equal? a b))))))))
(($ <primcall> src 'vector args) (($ <primcall> src 'vector args)
;; Expand to "allocate-vector" + "vector-init!". ;; Expand to "allocate-vector" + "vector-init!".

2
module/language/tree-il/cps-primitives.scm
View file

@ -162,7 +162,7 @@
(hashq-ref *branching-primitive-arities* name)) (hashq-ref *branching-primitive-arities* name))
(define (heap-type-predicate? name) (define (heap-type-predicate? name)
"Is @var{name} a predicate that needs guarding by @code{heap-object?} "Is @var{name} a predicate that needs guarding by @code{thob?}
before it is lowered to CPS?" before it is lowered to CPS?"
(hashq-ref *heap-type-predicates* name)) (hashq-ref *heap-type-predicates* name))

74
module/system/base/target.scm
View file

@ -1,6 +1,6 @@
;;; Compilation targets ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -34,7 +34,15 @@
target-most-negative-fixnum target-most-negative-fixnum
target-most-positive-fixnum target-most-positive-fixnum
target-fixnum?)) target-fixnum?
target-fixnum-tag
target-fixnum-tag-mask
target-fixnum-tag-bits
target-pair-tag
target-pair-tag-mask
target-pair-tag-bits))
@ -172,6 +180,7 @@ SCM words."
;; address space. ;; address space.
(/ (target-max-size-t) (target-word-size))) (/ (target-max-size-t) (target-word-size)))
;; TAGS-SENSITIVE
(define (target-max-vector-length) (define (target-max-vector-length)
"Return the maximum vector length of the target platform, in units of "Return the maximum vector length of the target platform, in units of
SCM words." SCM words."
@ -179,18 +188,75 @@ SCM words."
;; type tag. Additionally, restrict to 48-bit address space. ;; 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) 8) 48))))
;; TAGS-SENSITIVE
(define (target-most-negative-fixnum) (define (target-most-negative-fixnum)
"Return the most negative integer representable as a fixnum on the "Return the most negative integer representable as a fixnum on the
target platform." 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) (define (target-most-positive-fixnum)
"Return the most positive integer representable as a fixnum on the "Return the most positive integer representable as a fixnum on the
target platform." 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) (define (target-fixnum? n)
(and (exact-integer? n) (and (exact-integer? n)
(<= (target-most-negative-fixnum) (<= (target-most-negative-fixnum)
n n
(target-most-positive-fixnum)))) (target-most-positive-fixnum))))
;; TAGS-SENSITIVE
(define (target-fixnum-tag)
"Return the fixnum tag on the target platform."
(case (target-word-size)
((4) 1)
((8) 15)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-fixnum-tag-mask)
"Return the fixnum tag mask on the target platform."
(case (target-word-size)
((4) 1)
((8) 15)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-fixnum-tag-bits)
"Return the number of bits in the fixnum tag mask on the target platform."
(case (target-word-size)
((4) 1)
((8) 4)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-pair-tag)
"Return the pair tag on the target platform."
(case (target-word-size)
((4) 4)
((8) 6)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-pair-tag-mask)
"Return the pair tag mask on the target platform."
(case (target-word-size)
((4) 7)
((8) 15)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-pair-tag-bits)
"Return the number of bits in the pair tag mask on the target platform."
(case (target-word-size)
((4) 3)
((8) 4)
(else (error "unexpected word size"))))

94
module/system/base/types.scm
View file

@ -1,5 +1,5 @@
;;; 'SCM' type tag decoding. ;;; '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 ;;; 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 ;;; under the terms of the GNU Lesser General Public License as published by
@ -308,16 +308,24 @@ KIND/SUB-KIND."
(lambda (io port) (lambda (io port)
(match io (match io
(($ <inferior-object> kind sub-kind address) (($ <inferior-object> kind sub-kind address)
(format port "#<~a ~:[~*~;~a ~]~x>" (format port "#<~a~:[~*~; ~a~]~:[~*~; ~x~]>"
kind sub-kind sub-kind 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 "Return an object representing the SMOB at ADDRESS whose type is
TYPE-NUMBER." TYPE-NUMBER."
(inferior-object 'smob (inferior-object (let ((type-name (or (type-number->name backend 'smob
(or (type-number->name backend 'smob type-number) type-number)
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)) address))
(define (inferior-port-type backend address) (define (inferior-port-type backend address)
@ -438,8 +446,25 @@ using BACKEND."
(inferior-object 'dynamic-state address)) (inferior-object 'dynamic-state address))
((((flags << 8) || %tc7-port)) ((((flags << 8) || %tc7-port))
(inferior-port backend (logand flags #xff) address)) (inferior-port backend (logand flags #xff) address))
(((_ & #x7f = %tc7-program)) (((bits & #x7f = %tc7-program) code)
(inferior-object 'program address)) (let ((num-free-vars (ash bits -16))
(flags (filter-map (match-lambda
((mask . flag-name)
(and (logtest mask bits) flag-name)))
'((#x0100 . boot)
(#x0200 . prim)
(#x0400 . prim-generic)
(#x0800 . cont)
(#x1000 . partial-cont)
(#x2000 . 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)) (((_ & #xffff = %tc16-bignum))
(inferior-object 'bignum address)) (inferior-object 'bignum address))
(((_ & #xffff = %tc16-flonum) pad) (((_ & #xffff = %tc16-flonum) pad)
@ -458,11 +483,14 @@ using BACKEND."
(((_ & #x7f = %tc7-syntax) expression wrap module) (((_ & #x7f = %tc7-syntax) expression wrap module)
(cond-expand (cond-expand
(guile-2.2 (guile-2.2
(make-syntax (cell->object expression backend) (make-syntax (scm->object expression backend)
(cell->object wrap backend) (scm->object wrap backend)
(cell->object module backend))) (scm->object module backend)))
(else (else
(inferior-object 'syntax address)))) (vector 'syntax-object
(scm->object expression backend)
(scm->object wrap backend)
(scm->object module backend)))))
(((_ & #x7f = %tc7-vm-continuation)) (((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address)) (inferior-object 'vm-continuation address))
(((_ & #x7f = %tc7-weak-set)) (((_ & #x7f = %tc7-weak-set))
@ -473,31 +501,35 @@ using BACKEND."
(inferior-object 'array address)) (inferior-object 'array address))
(((_ & #x7f = %tc7-bitvector)) (((_ & #x7f = %tc7-bitvector))
(inferior-object 'bitvector address)) (inferior-object 'bitvector address))
((((smob-type << 8) || %tc7-smob) word1) (((bits & #x7f = %tc7-smob) word1)
(inferior-smob backend smob-type address)))))) (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)) (define* (scm->object bits #:optional (backend %ffi-memory-backend))
"Return the Scheme object corresponding to BITS, the bits of an 'SCM' "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
object." object."
(match-scm bits (match-scm bits
(((integer << 2) || %tc2-fixnum) (((integer << %fixnum-tag-size) || %fixnum-tag)
integer) integer)
((address & 7 = %tc3-heap-object) ((bits & %pair-tag-mask = %pair-tag)
(let* ((type (dereference-word backend address)) (or (and=> (vhash-assv bits (%visited-cells)) cdr)
(pair? (= (logand type #b1) %tc1-pair))) (let* ((carloc (- bits %pair-tag))
(if pair? (cdrloc (+ carloc %word-size))
(or (and=> (vhash-assv address (%visited-cells)) cdr) (pair (cons *unspecified* *unspecified*)))
(let ((car type) (visited (bits -> pair)
(cdrloc (+ address %word-size)) (set-car! pair
(pair (cons *unspecified* *unspecified*))) (scm->object (dereference-word backend carloc)
(visited (address -> pair) backend))
(set-car! pair (scm->object car backend)) (set-cdr! pair
(set-cdr! pair (scm->object (dereference-word backend cdrloc)
(scm->object (dereference-word backend cdrloc) backend))
backend)) pair))))
pair))) ((address & %thob-tag-mask = %thob-tag)
(cell->object address backend)))) (if (zero? address)
(inferior-object 'NULL #f) ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
(cell->object address backend)))
(((char << 8) || %tc8-char) (((char << 8) || %tc8-char)
(integer->char char)) (integer->char char))
((= %tc16-false) #f) ((= %tc16-false) #f)

87
module/system/base/types/internal.scm
View file

@ -1,5 +1,5 @@
;;; Details on internal value representation. ;;; 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 ;;; 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 ;;; under the terms of the GNU Lesser General Public License as published by
@ -16,8 +16,15 @@
(define-module (system base types internal) (define-module (system base types internal)
#:export (;; Immediate tags. #:export (;; Immediate tags.
%tc2-fixnum %fixnum-tag
%tc3-heap-object %fixnum-tag-mask
%fixnum-tag-size
%thob-tag
%thob-tag-mask
%thob-tag-size
%pair-tag
%pair-tag-mask
%pair-tag-size
%tc8-char %tc8-char
%tc16-false %tc16-false
%tc16-nil %tc16-nil
@ -29,7 +36,6 @@
visit-immediate-tags visit-immediate-tags
;; Heap object tags (cell types). ;; Heap object tags (cell types).
%tc1-pair
%tc3-struct %tc3-struct
%tc7-symbol %tc7-symbol
%tc7-variable %tc7-variable
@ -71,7 +77,7 @@
;;; ;;;
;;; Tags---keep in sync with libguile/tags.h! ;;; Tags---keep in sync with libguile/scm.h!
;;; ;;;
(define-syntax define-tags (define-syntax define-tags
@ -93,29 +99,32 @@
tag) 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 (define-tags immediate-tags
;; 321076543210 321076543210 ;; 321076543210 321076543210
(fixnum fixnum? #b11 #b10) (thob thob? #b111 #b000)
(heap-object heap-object? #b111 #b000) (pair pair? #b1111 #b0110)
(char char? #b11111111 #b00001100) (fixnum fixnum? #b1111 #b1111)
(false eq-false? #b111111111111 #b000000000100) (char char? #b11111111 #b00011110)
(nil eq-nil? #b111111111111 #b000100000100) (false eq-false? #b111111111111 #b000000001110)
(null eq-null? #b111111111111 #b001100000100) (nil eq-nil? #b111111111111 #b000100001110)
(true eq-true? #b111111111111 #b010000000100) (null eq-null? #b111111111111 #b001100001110)
(unspecified unspecified? #b111111111111 #b100000000100) (true eq-true? #b111111111111 #b010000001110)
(undefined undefined? #b111111111111 #b100100000100) (unspecified unspecified? #b111111111111 #b100000001110)
(eof eof-object? #b111111111111 #b101000000100) (undefined undefined? #b111111111111 #b100100001110)
(eof eof-object? #b111111111111 #b101000001110)
;;(nil eq-nil? #b111111111111 #b000100000100) ;;(false eq-false? #b111111111111 #b000000001110)
;;(eol eq-null? #b111111111111 #b001100000100) ;;(nil eq-nil? #b111111111111 #b000100001110)
;;(false eq-false? #b111111111111 #b000000000100) ;;(null eq-null? #b111111111111 #b001100001110)
(null+nil null? #b110111111111 #b000100000100) (null+nil null? #b110111111111 #b000100001110)
(false+nil false? #b111011111111 #b000000000100) (false+nil false? #b111011111111 #b000000001110)
(null+false+nil nil? #b110011111111 #b000000000100)) (null+false+nil nil? #b110011111111 #b000000001110))
(define-tags heap-tags (define-tags heap-tags
;; 321076543210 321076543210 ;; 321076543210 321076543210
(pair pair? #b1 #b0)
(struct struct? #b111 #b001) (struct struct? #b111 #b001)
;; For tc7 values, low bits 2 and 0 must be 1. ;; For tc7 values, low bits 2 and 0 must be 1.
(symbol symbol? #b1111111 #b0000101) (symbol symbol? #b1111111 #b0000101)
@ -159,15 +168,25 @@
(complex compnum? #b111111111111 #b001100010111) (complex compnum? #b111111111111 #b001100010111)
(fraction fracnum? #b111111111111 #b010000010111)) (fraction fracnum? #b111111111111 #b010000010111))
(eval-when (expand)
(define configurable-width-tag-names
'(fixnum thob pair)))
(define-syntax define-tag (define-syntax define-tag
(lambda (x) (lambda (x)
(define (id-append ctx a b) (define (id-append ctx . ids)
(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) (datum->syntax ctx (apply symbol-append (map syntax->datum ids))))
(define (def prefix name tag) (define (def prefix name tag)
#`(define #,(id-append name 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 () (syntax-case x ()
((_ name pred #b1 tag) (def #'%tc1- #'name #'tag)) ((_ name pred mask tag)
((_ name pred #b11 tag) (def #'%tc2- #'name #'tag)) (member (syntax->datum #'name) configurable-width-tag-names)
(def* #'name #'mask #'tag))
((_ name pred #b111 tag) (def #'%tc3- #'name #'tag)) ((_ name pred #b111 tag) (def #'%tc3- #'name #'tag))
((_ name pred #b1111111 tag) (def #'%tc7- #'name #'tag)) ((_ name pred #b1111111 tag) (def #'%tc7- #'name #'tag))
((_ name pred #b11111111 tag) (def #'%tc8- #'name #'tag)) ((_ name pred #b11111111 tag) (def #'%tc8- #'name #'tag))
@ -175,9 +194,7 @@
;; tc16 values. ;; tc16 values.
((_ name pred #b111111111111 tag) (def #'%tc16- #'name #'tag)) ((_ name pred #b111111111111 tag) (def #'%tc16- #'name #'tag))
((_ name pred mask tag) ((_ name pred mask tag)
#`(begin (def* #'name #'mask #'tag)))))
(define #,(id-append #'name #'name #'-mask) mask)
(define #,(id-append #'name #'name #'-tag) tag))))))
(visit-immediate-tags define-tag) (visit-immediate-tags define-tag)
(visit-heap-tags define-tag) (visit-heap-tags define-tag)
@ -205,13 +222,13 @@
(error "expected #f and '() to differ in exactly two bit positions")) (error "expected #f and '() to differ in exactly two bit positions"))
(call-with-values (lambda () (common-bits %tc16-null %tc16-nil)) (call-with-values (lambda () (common-bits %tc16-null %tc16-nil))
(lambda (mask tag) (lambda (mask tag)
(unless (= mask null+nil-mask) (error "unexpected mask for null?")) (unless (= mask %null+nil-tag-mask) (error "unexpected mask for null?"))
(unless (= tag null+nil-tag) (error "unexpected tag for null?")))) (unless (= tag %null+nil-tag) (error "unexpected tag for null?"))))
(call-with-values (lambda () (common-bits %tc16-false %tc16-nil)) (call-with-values (lambda () (common-bits %tc16-false %tc16-nil))
(lambda (mask tag) (lambda (mask tag)
(unless (= mask false+nil-mask) (error "unexpected mask for false?")) (unless (= mask %false+nil-tag-mask) (error "unexpected mask for false?"))
(unless (= tag false+nil-tag) (error "unexpected tag for false?")))) (unless (= tag %false+nil-tag) (error "unexpected tag for false?"))))
(call-with-values (lambda () (common-bits %tc16-false %tc16-null)) (call-with-values (lambda () (common-bits %tc16-false %tc16-null))
(lambda (mask tag) (lambda (mask tag)
(unless (= mask null+false+nil-mask) (error "unexpected mask 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?")))))) (unless (= tag %null+false+nil-tag) (error "unexpected tag for nil?"))))))

77
module/system/vm/assembler.scm
View file

@ -91,7 +91,8 @@
emit-jnge emit-jnge
emit-fixnum? emit-fixnum?
emit-heap-object? emit-thob?
emit-pair?
emit-char? emit-char?
emit-eq-null? emit-eq-null?
emit-eq-nil? emit-eq-nil?
@ -110,7 +111,6 @@
(emit-throw/value* . emit-throw/value) (emit-throw/value* . emit-throw/value)
(emit-throw/value+data* . emit-throw/value+data) (emit-throw/value+data* . emit-throw/value+data)
emit-pair?
emit-struct? emit-struct?
emit-symbol? emit-symbol?
emit-variable? emit-variable?
@ -144,6 +144,7 @@
emit-allocate-words emit-allocate-words
emit-allocate-words/immediate emit-allocate-words/immediate
emit-tagged-allocate-words/immediate
emit-scm-ref emit-scm-ref
emit-scm-set! emit-scm-set!
@ -152,6 +153,9 @@
emit-scm-ref/immediate emit-scm-ref/immediate
emit-scm-set!/immediate emit-scm-set!/immediate
emit-tagged-scm-ref/immediate
emit-tagged-scm-set!/immediate
emit-word-ref emit-word-ref
emit-word-set! emit-word-set!
emit-word-ref/immediate emit-word-ref/immediate
@ -643,6 +647,8 @@ later by the linker."
((X8_S8_S8_C8 a b c) ((X8_S8_S8_C8 a b c)
(emit asm (pack-u8-u8-u8-u8 opcode a b c))) (emit asm (pack-u8-u8-u8-u8 opcode a b c)))
((X8_S8_C8_S8 a b c) ((X8_S8_C8_S8 a b c)
(emit asm (pack-u8-u8-u8-u8 opcode a b c)))
((X8_S8_C8_C8 a b c)
(emit asm (pack-u8-u8-u8-u8 opcode a b c)))))) (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
(define (pack-tail-word asm type) (define (pack-tail-word asm type)
@ -884,6 +890,23 @@ later by the linker."
(emit-push asm a) (emit-push asm a)
(encode-X8_S8_C8_S8 asm 0 const 0 opcode) (encode-X8_S8_C8_S8 asm 0 const 0 opcode)
(emit-pop asm dst)))) (emit-pop asm dst))))
(define (encode-X8_S8_C8_C8!/shuffle asm a const1 const2 opcode)
(cond
((< a (ash 1 8))
(encode-X8_S8_C8_C8 asm a const1 const2 opcode))
(else
(emit-push asm a)
(encode-X8_S8_C8_C8 asm 0 const1 const2 opcode)
(emit-drop asm 1))))
(define (encode-X8_S8_C8_C8<-/shuffle asm dst const1 const2 opcode)
(cond
((< dst (ash 1 8))
(encode-X8_S8_C8_C8 asm dst const1 const2 opcode))
(else
;; Push garbage value to make space for dst.
(emit-push asm dst)
(encode-X8_S8_C8_C8 asm 0 const1 const2 opcode)
(emit-pop asm dst))))
(define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode) (define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode)
(cond (cond
((< (logior dst a b) (ash 1 8)) ((< (logior dst a b) (ash 1 8))
@ -954,6 +977,8 @@ later by the linker."
(('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle) (('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle)
(('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle) (('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle)
(('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle) (('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle)
(('! 'X8_S8_C8_C8) #'encode-X8_S8_C8_C8!/shuffle)
(('<- 'X8_S8_C8_C8) #'encode-X8_S8_C8_C8<-/shuffle)
(else (encoder-name operands)))) (else (encoder-name operands))))
(define-syntax assembler (define-syntax assembler
@ -996,6 +1021,7 @@ later by the linker."
('X8_S8_S8_S8 #'(a b c)) ('X8_S8_S8_S8 #'(a b c))
('X8_S8_S8_C8 #'(a b c)) ('X8_S8_S8_C8 #'(a b c))
('X8_S8_C8_S8 #'(a b c)) ('X8_S8_C8_S8 #'(a b c))
('X8_S8_C8_C8 #'(a b c))
('X32 #'()))) ('X32 #'())))
(syntax-case x () (syntax-case x ()
@ -1097,28 +1123,25 @@ lists. This procedure can be called many times before calling
(define (immediate-bits asm x) (define (immediate-bits asm x)
"Return the bit pattern to write into the buffer if @var{x} is "Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise." immediate, and @code{#f} otherwise."
(define tc2-int 2)
(if (exact-integer? x) (if (exact-integer? x)
;; Object is an immediate if it is a fixnum on the target. ;; Object is an immediate if it is a fixnum on the target.
(call-with-values (lambda () (and (target-fixnum? x)
(case (asm-word-size asm) (let* ((fixnum-max (target-most-positive-fixnum))
((4) (values (- #x20000000) (fixnum-bits (if (negative? x)
#x1fffffff)) (+ fixnum-max 1 (logand x fixnum-max))
((8) (values (- #x2000000000000000) x)))
#x1fffffffFFFFFFFF)) (logior (ash fixnum-bits (target-fixnum-tag-bits))
(else (error "unexpected word size")))) (target-fixnum-tag))))
(lambda (fixnum-min fixnum-max)
(and (<= fixnum-min x fixnum-max)
(let ((fixnum-bits (if (negative? x)
(+ fixnum-max 1 (logand x fixnum-max))
x)))
(logior (ash fixnum-bits 2) tc2-int)))))
;; Otherwise, the object will be immediate on the target if and ;; Otherwise, the object will be immediate on the target if and
;; only if it is immediate on the host. Except for integers, ;; only if it is immediate on the host. Except for integers,
;; which we handle specially above, any immediate value is an ;; which we handle specially above, any immediate value is an
;; immediate on both 32-bit and 64-bit targets. ;; immediate on both 32-bit and 64-bit targets.
(let ((bits (object-address x))) (let ((bits (object-address x)))
(and (not (zero? (logand bits 6))) ;; TAGS-SENSITIVE
(and (not (= (logand bits %thob-tag-mask)
%thob-tag))
(not (= (logand bits (target-pair-tag-mask))
(target-pair-tag)))
bits)))) bits))))
(define-record-type <stringbuf> (define-record-type <stringbuf>
@ -1169,10 +1192,13 @@ table, its existing label is used directly."
(define (field dst n obj) (define (field dst n obj)
(let ((src (recur obj))) (let ((src (recur obj)))
(if src (if src
(if (statically-allocatable? obj) (cond ((pair? obj)
`((static-patch! 0 ,dst ,n ,src)) `((static-patch! (target-pair-tag) ,dst ,n ,src)))
`((static-ref 1 ,src) ((statically-allocatable? obj)
(static-set! 1 ,dst ,n))) `((static-patch! 0 ,dst ,n ,src)))
(else
`((static-ref 1 ,src)
(static-set! 1 ,dst ,n))))
'()))) '())))
(define (intern obj label) (define (intern obj label)
(cond (cond
@ -1286,6 +1312,9 @@ returned instead."
(emit-make-long-immediate asm dst obj)) (emit-make-long-immediate asm dst obj))
(else (else
(emit-make-long-long-immediate asm dst obj))))) (emit-make-long-long-immediate asm dst obj)))))
((pair? obj)
(emit-make-tagged-non-immediate asm dst (target-pair-tag)
(intern-non-immediate asm obj)))
((statically-allocatable? obj) ((statically-allocatable? obj)
(emit-make-non-immediate asm dst (intern-non-immediate asm obj))) (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
(else (else
@ -1781,7 +1810,7 @@ should be .data or .rodata), and return the resulting linker object.
bitvector-immutable-flag) bitvector-immutable-flag)
(logior tc7-bytevector (logior tc7-bytevector
;; Bytevector immutable flag also shifted ;; Bytevector immutable flag also shifted
;; left. ;; left. TAGS-SENSITIVE
(ash (logior bytevector-immutable-flag (ash (logior bytevector-immutable-flag
(array-type-code obj)) (array-type-code obj))
7))))) 7)))))
@ -1858,7 +1887,7 @@ should be .data or .rodata), and return the resulting linker object.
((vlist-null? data) #f) ((vlist-null? data) #f)
(else (else
(let* ((byte-len (vhash-fold (lambda (k v len) (let* ((byte-len (vhash-fold (lambda (k v len)
(+ (byte-length k) (align len 8))) (+ (byte-length k) (align len 16))) ; temporary alignment hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
0 data)) 0 data))
(buf (make-bytevector byte-len 0))) (buf (make-bytevector byte-len 0)))
(let lp ((i 0) (pos 0) (relocs '()) (symbols '())) (let lp ((i 0) (pos 0) (relocs '()) (symbols '()))
@ -1867,7 +1896,7 @@ should be .data or .rodata), and return the resulting linker object.
((obj . obj-label) ((obj . obj-label)
(write buf pos obj) (write buf pos obj)
(lp (1+ i) (lp (1+ i)
(align (+ (byte-length obj) pos) 8) (align (+ (byte-length obj) pos) 16) ; temporary alignment hack XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
(add-relocs obj pos relocs) (add-relocs obj pos relocs)
(cons (make-linker-symbol obj-label pos) symbols)))) (cons (make-linker-symbol obj-label pos) symbols))))
(make-object asm name buf relocs symbols (make-object asm name buf relocs symbols

13
module/system/vm/disassembler.scm
View file

@ -107,7 +107,8 @@
(unpack-s12 (ash word -20)))) (unpack-s12 (ash word -20))))
((X8_S8_S8_S8 ((X8_S8_S8_S8
X8_S8_S8_C8 X8_S8_S8_C8
X8_S8_C8_S8) X8_S8_C8_S8
X8_S8_C8_C8)
#'((logand (ash word -8) #xff) #'((logand (ash word -8) #xff)
(logand (ash word -16) #xff) (logand (ash word -16) #xff)
(ash word -24))) (ash word -24)))
@ -208,6 +209,9 @@ address of that offset."
(define (reference-scm target) (define (reference-scm target)
(unpack-scm (u32-offset->addr (+ offset target) context))) (unpack-scm (u32-offset->addr (+ offset target) context)))
(define (reference-tagged-scm tag target)
(unpack-scm (+ tag (u32-offset->addr (+ offset target) context))))
(define (dereference-scm target) (define (dereference-scm target)
(let ((addr (u32-offset->addr (+ offset target) (let ((addr (u32-offset->addr (+ offset target)
context))) context)))
@ -270,6 +274,11 @@ address of that offset."
(when (program? val) (when (program? val)
(push-addr! (program-code val) val)) (push-addr! (program-code val) val))
(list "~@Y" val))) (list "~@Y" val)))
(('make-tagged-non-immediate dst tag target)
(let ((val (reference-tagged-scm tag target)))
(when (program? val)
(push-addr! (program-code val) val))
(list "~@Y" val)))
(((or 'throw/value 'throw/value+data) dst target) (((or 'throw/value 'throw/value+data) dst target)
(list "~@Y" (reference-scm target))) (list "~@Y" (reference-scm target)))
(('builtin-ref dst idx) (('builtin-ref dst idx)
@ -408,6 +417,8 @@ address of that offset."
`(load-label ,dst ,(u32-offset->addr (+ offset src) context))) `(load-label ,dst ,(u32-offset->addr (+ offset src) context)))
(('make-non-immediate dst target) (('make-non-immediate dst target)
`(make-non-immediate ,dst ,(reference-scm target))) `(make-non-immediate ,dst ,(reference-scm target)))
(('make-tagged-non-immediate dst tag target)
`(make-tagged-non-immediate ,dst ,tag ,(reference-tagged-scm tag target)))
(('builtin-ref dst idx) (('builtin-ref dst idx)
`(builtin-ref ,dst ,(builtin-index->name idx))) `(builtin-ref ,dst ,(builtin-index->name idx)))
(((or 'static-ref 'static-set!) dst target) (((or 'static-ref 'static-set!) dst target)