mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +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
{
/* Immediate values can be checked using `eq?'. */
if (SCM_IMP (key))
if (!SCM_HEAP_OBJECT_P (key))
return scm_sloppy_assq (key, 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;
/* Immediate values can be checked using `eq?'. */
if (SCM_IMP (key))
if (!SCM_HEAP_OBJECT_P (key))
return scm_assq (key, alist);
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
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");
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;
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))
{

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) \
(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_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_MUTABLE_BITVECTOR(x) \
(SCM_NIMP (x) && \
(SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \
== scm_tc7_bitvector))
#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_MUTABLE_BYTEVECTOR_P(x) \
(SCM_NIMP (x) && \
(SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \
== scm_tc7_bytevector))

36
libguile/eq.c
View file

@ -159,7 +159,7 @@ scm_i_fraction_equalp (SCM x, SCM y)
int
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))
{
case scm_tc16_big:
@ -216,9 +216,9 @@ SCM scm_eqv_p (SCM x, SCM y)
{
if (scm_is_eq (x, y))
return SCM_BOOL_T;
if (SCM_IMP (x))
if (!SCM_THOB_P (x))
return SCM_BOOL_F;
if (SCM_IMP (y))
if (!SCM_THOB_P (y))
return SCM_BOOL_F;
/* this ensures that types and scm_length are the same. */
@ -299,18 +299,28 @@ scm_equal_p (SCM x, SCM y)
SCM_TICK;
if (scm_is_eq (x, y))
return SCM_BOOL_T;
if (SCM_IMP (x))
return SCM_BOOL_F;
if (SCM_IMP (y))
return SCM_BOOL_F;
if (scm_is_pair (x) && scm_is_pair (y))
if (scm_is_pair (x))
{
if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
return SCM_BOOL_F;
x = SCM_CDR(x);
y = SCM_CDR(y);
goto tailrecurse;
if (scm_is_pair (y))
{
if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
return SCM_BOOL_F;
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))
{
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}

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")
#define FUNC_NAME s_scm_self_evaluating_p
{
switch (SCM_ITAG3 (obj))
switch (SCM_ITAG (obj))
{
case scm_tc3_int_1:
case scm_tc3_int_2:
/* inum */
case scm_itags_fixnum:
/* immediate numbers */
return SCM_BOOL_T;
case scm_tc3_imm24:
/* characters, booleans, other immediates */
case scm_itags_imm24:
/* characters, booleans, other immediates */
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))
{
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
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
higher bits of the type tag are used to store a pointer (that is, a
pointer to an 8-octet aligned region). */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
GC_REGISTER_DISPLACEMENT (scm_thob_tag);
GC_REGISTER_DISPLACEMENT (scm_pair_tag);
GC_REGISTER_DISPLACEMENT (scm_tc3_struct);
/* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */
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_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_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
scm_is_array (SCM obj)
{
if (!SCM_HEAP_OBJECT_P (obj))
if (!SCM_THOB_P (obj))
return 0;
switch (SCM_TYP7 (obj))

2
libguile/generalized-arrays.h
View file

@ -34,7 +34,7 @@
#define SCM_VALIDATE_ARRAY(pos, v) \
do { \
SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \
SCM_ASSERT (SCM_THOB_P (v) \
&& scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
v, pos, FUNC_NAME); \
} 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}.")
#define FUNC_NAME s_scm_class_of
{
switch (SCM_ITAG3 (x))
switch (SCM_ITAG (x))
{
case scm_tc3_int_1:
case scm_tc3_int_2:
case scm_itags_fixnum:
return class_integer;
case scm_tc3_imm24:
case scm_itags_imm24:
if (SCM_CHARP (x))
return class_char;
else if (scm_is_bool (x))
@ -219,11 +218,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
return class_unknown;
case scm_tc3_cons:
case scm_itags_pair:
return class_pair;
case scm_itags_thob:
switch (SCM_TYP7 (x))
{
case scm_tcs_cons_nimcar:
return class_pair;
case scm_tc7_symbol:
return class_symbol;
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);
}
default:
if (scm_is_pair (x))
return class_pair;
else
return class_unknown;
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;
}

97
libguile/hash.c
View file

@ -284,62 +284,63 @@ scm_raw_ihashq (scm_t_bits key)
static unsigned long
scm_raw_ihash (SCM obj, size_t depth)
{
if (SCM_IMP (obj))
return scm_raw_ihashq (SCM_UNPACK (obj));
switch (SCM_TYP7(obj))
{
/* FIXME: do better for structs, variables, ... Also the hashes
are currently associative, which ain't the right thing. */
case scm_tc7_smob:
return scm_raw_ihashq (SCM_TYP16 (obj));
case scm_tc7_number:
if (scm_is_integer (obj))
if (SCM_THOB_P (obj))
switch (SCM_TYP7(obj))
{
/* FIXME: do better for structs, variables, ... Also the hashes
are currently associative, which ain't the right thing. */
case scm_tc7_smob:
return scm_raw_ihashq (SCM_TYP16 (obj));
case scm_tc7_number:
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);
if (scm_is_inexact (obj))
obj = scm_inexact_to_exact (obj);
return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
size_t len = SCM_SIMPLE_VECTOR_LENGTH (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;
}
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:
{
size_t len = SCM_SIMPLE_VECTOR_LENGTH (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:
{
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_struct:
return scm_i_struct_hash (obj, depth);
default:
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}
case scm_tc7_syntax:
{
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:
else if (scm_is_pair (obj))
{
if (depth)
return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
else
return scm_raw_ihashq (scm_tc3_cons);
case scm_tcs_struct:
return scm_i_struct_hash (obj, depth);
default:
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
return scm_raw_ihashq (0);
}
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_C8_S8) \
M(X8_S8_S8_C8) \
M(X8_S8_C8_C8) \
M(C8_C24) \
M(C8_S24) \
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
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
@ -1637,7 +1637,7 @@ compile_subr_call (scm_jit_state *j, uint32_t idx)
clear_scratch_register_state (j);
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);
emit_call_2 (j, scm_vm_intrinsics.unpack_values_object, thread_operand (),
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);
}
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
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);
}
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
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);
}
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
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);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
jit_subi (j->jit, T0, T0, scm_tc2_int);
jit_subi (j->jit, T0, T0, scm_fixnum_tag);
jit_subi (j->jit, T2, T1, scm_fixnum_tag);
jit_orr (j->jit, T2, T2, T0); /* TAGS-SENSITIVE */
jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
fast = jit_bxaddr (j->jit, T0, T1);
has_fast = 1;
/* Restore previous value before slow path. */
jit_subr (j->jit, T0, T0, T1);
jit_addi (j->jit, T0, T0, scm_tc2_int);
jit_patch_here (j->jit, a_not_inum);
jit_patch_here (j->jit, b_not_inum);
jit_patch_here (j->jit, not_inum);
jit_addi (j->jit, T0, T0, scm_fixnum_tag);
break;
}
case SCM_VM_INTRINSIC_SUB:
@ -2212,16 +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);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
op_b = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T1);
jit_reloc_t a_not_inum = jit_bmci (j->jit, T0, scm_tc2_int);
jit_reloc_t b_not_inum = jit_bmci (j->jit, T1, scm_tc2_int);
jit_subi (j->jit, T1, T1, scm_tc2_int);
jit_subi (j->jit, T1, T1, scm_fixnum_tag);
jit_subi (j->jit, T2, T0, scm_fixnum_tag);
jit_orr (j->jit, T2, T2, T1); /* TAGS-SENSITIVE */
jit_reloc_t not_inum = jit_bmsi (j->jit, T2, scm_fixnum_tag_mask);
fast = jit_bxsubr (j->jit, T0, T1);
has_fast = 1;
/* Restore previous values before slow path. */
jit_addr (j->jit, T0, T0, T1);
jit_addi (j->jit, T1, T1, scm_tc2_int);
jit_patch_here (j->jit, a_not_inum);
jit_patch_here (j->jit, b_not_inum);
jit_patch_here (j->jit, not_inum);
jit_addi (j->jit, T1, T1, scm_fixnum_tag);
break;
}
default:
@ -2254,8 +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);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
scm_t_bits addend = b << 2;
jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
scm_t_bits addend = b << scm_fixnum_tag_size;
jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
fast = jit_bxaddi (j->jit, T0, addend);
has_fast = 1;
/* Restore previous value before slow path. */
@ -2267,8 +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);
op_a = jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0);
scm_t_bits subtrahend = b << 2;
jit_reloc_t not_inum = jit_bmci (j->jit, T0, 2);
scm_t_bits subtrahend = b << scm_fixnum_tag_size;
jit_comr (j->jit, T1, T0); /* TAGS-SENSITIVE */
jit_reloc_t not_inum = jit_bmsi (j->jit, T1, scm_fixnum_tag_mask);
fast = jit_bxsubi (j->jit, T0, subtrahend);
has_fast = 1;
/* Restore previous value before slow path. */
@ -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);
}
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
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
emit_sp_ref_u64_lower_half (j, T0, src);
#endif
emit_lshi (j, T0, T0, 8);
emit_lshi (j, T0, T0, 8); /* TAGS-SENSITIVE */
emit_addi (j, T0, T0, scm_tc8_char);
emit_sp_set_scm (j, dst, T0);
}
@ -2474,7 +2516,7 @@ static void
compile_untag_char (scm_jit_state *j, uint16_t dst, uint16_t src)
{
emit_sp_ref_scm (j, T0, src);
emit_rshi (j, T0, T0, 8);
emit_rshi (j, T0, T0, 8); /* TAGS-SENSITIVE */
#if SIZEOF_UINTPTR_T >= 8
emit_sp_set_u64 (j, dst, T0);
#else
@ -3298,7 +3340,8 @@ compile_less (scm_jit_state *j, uint16_t a, uint16_t b)
emit_sp_ref_scm (j, T1, b);
emit_andr (j, T2, T0, T1);
fast = jit_bmsi (j->jit, T2, scm_tc2_int);
emit_comr (j, T2, T2);
fast = jit_bmci (j->jit, T2, scm_fixnum_tag_mask);
emit_call_2 (j, scm_vm_intrinsics.less_p,
jit_operand_gpr (JIT_OPERAND_ABI_POINTER, T0),
@ -3409,7 +3452,7 @@ compile_check_positional_arguments (scm_jit_state *j, uint32_t nreq, uint32_t ex
emit_ldr (j, obj, walk);
jit_patch_there
(j->jit,
emit_branch_if_immediate (j, obj),
emit_branch_if_not_thob (j, obj),
head);
jit_patch_there
(j->jit,
@ -3559,11 +3602,11 @@ static void
compile_untag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
{
emit_sp_ref_scm (j, T0, a);
emit_rshi (j, T0, T0, 2);
emit_rshi (j, T0, T0, scm_fixnum_tag_size);
#if SIZEOF_UINTPTR_T >= 8
emit_sp_set_s64 (j, dst, T0);
#else
/* FIXME: Untested! */
/* FIXME: Untested!, and also not updated for new tagging XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
emit_rshi (j, T1, T0, 31);
emit_sp_set_s64 (j, dst, T0, T1);
#endif
@ -3577,8 +3620,8 @@ compile_tag_fixnum (scm_jit_state *j, uint16_t dst, uint16_t a)
#else
emit_sp_ref_s32 (j, T0, a);
#endif
emit_lshi (j, T0, T0, 2);
emit_addi (j, T0, T0, scm_tc2_int);
emit_lshi (j, T0, T0, scm_fixnum_tag_size);
emit_addi (j, T0, T0, scm_fixnum_tag);
emit_sp_set_scm (j, dst, T0);
}
@ -4260,6 +4303,15 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
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) \
{ \
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)
#define COMPILE_X8_S8_S8_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) \
{ \

6
libguile/list.c
View file

@ -40,9 +40,9 @@
/* creating lists */
#define SCM_I_CONS(cell, x, y) \
do { \
cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
#define SCM_I_CONS(cell, x, y) \
do { \
cell = SCM_ADD_PAIR_TAG (scm_cell (SCM_UNPACK (x), SCM_UNPACK (y))); \
} while (0)
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;
#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")

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(x) \
(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) \
: SCM_I_NUMTAG_NOTNUM)))
*/

33
libguile/numbers.h
View file

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

14
libguile/pairs.h
View file

@ -67,11 +67,11 @@
/* #nil is null. */
#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_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (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 (SCM_REMOVE_PAIR_TAG (x))))
#define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
#define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((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 (SCM_REMOVE_PAIR_TAG (x), (v))))
#define SCM_CAAR(OBJ) SCM_CAR (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_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
@ -163,7 +163,7 @@ scm_is_pair (SCM x)
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
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
deep in the bowels of ceval(). In both cases segvs resulted from
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
pair in the read-only section would cause a segmentation fault, so
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 */

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
iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
switch (SCM_ITAG3 (exp))
switch (SCM_ITAG (exp))
{
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
/* These tc3 tags should never occur in an immediate value. They are
* only used in cell types of non-immediates, i. e. the value returned
* by SCM_CELL_TYPE (exp) can use these tags.
*/
scm_ipruk ("immediate", exp, port);
break;
case scm_tc3_int_1:
case scm_tc3_int_2:
case scm_itags_fixnum:
scm_intprint (SCM_I_INUM (exp), 10, port);
break;
case scm_tc3_imm24:
case scm_itags_imm24:
if (SCM_CHARP (exp))
{
if (SCM_WRITINGP (pstate))
@ -624,7 +615,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_ipruk ("immediate", exp, port);
}
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))
{
case scm_tcs_struct:
@ -647,12 +643,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
}
break;
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist ("(", exp, ')', port, pstate);
EXIT_NESTED_DATA (pstate);
break;
circref:
print_circref (port, pstate, exp);
break;
@ -787,7 +777,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
break;
default:
/* case scm_tcs_closures: */
/* fall through */
punk:
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;
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;
}
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);
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);
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);
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_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
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 a tagged heap object (thob). */
/* Checking if a SCM variable holds an immediate integer: See numbers.h
for the definition of the following macros: SCM_I_FIXNUM_BIT,
SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */
#define scm_thob_tag 0
#define scm_thob_tag_mask 7
#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
Guile also known as a cons-cell): This is done by first checking that
the SCM variable holds a heap object, and second, by checking that
tc1==0 holds for the SCM_CELL_TYPE of the SCM variable. */
#define SCM_I_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
Guile also known as a cons-cell). */
#define SCM_I_CONSP(x) \
((SCM_UNPACK (x) & scm_pair_tag_mask) == scm_pair_tag)
#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: */
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
#define scm_tc3_cons 0
#define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0)
#define scm_tc3_unused 3
#define scm_tc3_imm24 4
#define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4)
#define scm_tc3_tc7_2 7
/* Definitions for tc4: */
#define scm_tc4_imm24 14
/* Definitions for tc7: */
@ -464,15 +473,14 @@ typedef uintptr_t scm_t_bits;
#define SCM_ITAG7(x) (0x7f & SCM_UNPACK (x))
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
#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))
/* These type codes form part of the ABI and cannot be changed in a
stable series. The low bits of each must have the tc3 of a heap
object type code (see above). If you do change them in a development
series, change them also in (system vm assembler) and (system base
types). Bonus points if you change the build to define these tag
values in only one place! */
stable series. If you do change them in a development series,
change them also in (system vm assembler) and (system base types).
Bonus points if you change the build to define these tag values
in only one place! */
#define scm_tc7_symbol 0x05
#define scm_tc7_variable 0x07
@ -520,10 +528,10 @@ typedef uintptr_t scm_t_bits;
enum scm_tc8_tags
{
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
scm_tc8_flag = scm_tc4_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc4_imm24 + 0x10, /* characters */
scm_tc8_unused_0 = scm_tc4_imm24 + 0x20,
scm_tc8_unused_1 = scm_tc4_imm24 + 0x30
};
#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
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}.")
#define FUNC_NAME s_scm_source_properties
{
if (SCM_IMP (obj))
if (!SCM_HEAP_OBJECT_P (obj))
return SCM_EOL;
else
{
@ -204,7 +206,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
#undef FUNC_NAME
#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
and try to make a srcprops-object...? */
@ -226,7 +228,7 @@ int
scm_i_has_source_properties (SCM obj)
#define FUNC_NAME "%set-source-properties"
{
if (SCM_IMP (obj))
if (!SCM_HEAP_OBJECT_P (obj))
return 0;
else
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;
if (SCM_IMP (obj))
if (!SCM_HEAP_OBJECT_P (obj))
return SCM_BOOL_F;
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
vtable. The vtable reference is tagged with the struct tc3. */
vtable. The vtable reference is tagged with the struct tag. */
static SCM
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);
#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_SLOT_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
#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. */
#define SCM_F_VECTOR_IMMUTABLE 0x80UL
#define SCM_I_IS_MUTABLE_VECTOR(x) \
(SCM_NIMP (x) && \
(SCM_THOB_P (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \
== scm_tc7_vector))
#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))

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))
PTR_SET (double, F64);
VM_DEFINE_OP (154, unused_154, NULL, NOP)
VM_DEFINE_OP (155, unused_155, NULL, NOP)
VM_DEFINE_OP (156, unused_156, NULL, NOP)
VM_DEFINE_OP (157, unused_157, NULL, NOP)
/* make-tagged-non-immediate dst:12 tag:12 offset:32
*
* Load a pointer to statically allocated memory into DST, with TAG
* 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 (159, unused_159, 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;
case SLOT_DESC_UNUSED:
case SLOT_DESC_LIVE_GC:
if (SCM_NIMP (sp->as_scm) &&
sp->as_ptr >= lower && sp->as_ptr <= upper)
if (SCM_HEAP_OBJECT_P (sp->as_scm)
&& sp->as_ptr >= lower && sp->as_ptr <= upper)
mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
mark_stack_ptr,
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].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,
(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].key = SCM_UNPACK (obj);
if (SCM_HEAP_OBJECT_P (obj))
if (SCM_THOB_P (obj))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
(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;
}

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_BOTH))
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)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
SCM2PTR (v));
(scm_is_pair (v)
? SCM2PTR (SCM_REMOVE_PAIR_TAG (v))
: SCM2PTR (v)));
}
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;
if (SCM_HEAP_OBJECT_P (x))
if (SCM_THOB_P (x))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
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

7
module/language/bytecode.scm
View file

@ -51,7 +51,9 @@
((X8_F12_F12) 2)
((X8_S8_S8_S8) 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)
(case word
((C32) 1)
@ -74,7 +76,8 @@
((X8_S24) 1)
((X8_F24) 1)
((X8_C24) 1)
((X8_L24) 1)))
((X8_L24) 1)
(else (error "unknown tail word type" word))))
(match args
((arg0 . args)
(fold (lambda (arg arity)

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

@ -555,7 +555,7 @@ term."
(with-cps cps
(build-term
($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
;; is a vector.
(#(#t nfree)

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

@ -38,6 +38,7 @@
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
#:use-module (system base target)
#:use-module (system base types internal)
#:export (compile-bytecode))
@ -161,16 +162,29 @@
(emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
(($ $primcall 'allocate-words/immediate (annotation . 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))
(emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
(from-sp (slot idx))))
(($ $primcall 'scm-ref/tag annotation (obj))
(let ((tag (match annotation
('pair %tc1-pair)
('pair 0) ; TAGS-SENSITIVE
('struct %tc3-struct))))
(emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
(($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
(emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
(($ $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))
(emit-word-ref asm (from-sp dst) (from-sp (slot obj))
(from-sp (slot idx))))
@ -298,13 +312,21 @@
(from-sp (slot val))))
(($ $primcall 'scm-set!/tag annotation (obj val))
(let ((tag (match annotation
('pair %tc1-pair)
('pair 0) ; TAGS-SENSITIVE
('struct %tc3-struct))))
(emit-scm-set!/tag asm (from-sp (slot obj)) tag
(from-sp (slot val)))))
(($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
(emit-scm-set!/immediate asm (from-sp (slot obj)) idx
(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))
(emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
(from-sp (slot val))))
@ -451,7 +473,8 @@
(match (vector op param args)
;; Immediate type tag predicates.
(#('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))
(#('eq-false? #f (a)) (unary emit-eq-false? a))
(#('eq-nil? #f (a)) (unary emit-eq-nil? a))
@ -464,7 +487,6 @@
(#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates.
(#('pair? #f (a)) (unary emit-pair? a))
(#('struct? #f (a)) (unary emit-struct? a))
(#('symbol? #f (a)) (unary emit-symbol? 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 (srfi srfi-11)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system base target)
#:use-module (language cps)
#:use-module (language cps renumber)
#:use-module (language cps utils)
@ -387,15 +388,15 @@ function set."
(letk ktail
($kargs () ()
($continue kdone src
($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
(letk khead
($kargs ('pair) (pair)
($continue ktail src
($primcall 'scm-set!/immediate '(pair . 0) (pair v)))))
($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair v)))))
(letk ktail
($kargs ('tail) (tail)
($continue khead src
($primcall 'allocate-words/immediate '(pair . 2) ()))))
($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))
($ (build-list ktail src vals))))))
(cond
((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!/tag p s x) (x <- scm-ref/tag 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!/immediate p s x) (x <- word-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
(($ $primcall
(or 'scm-set! 'scm-set!/tag 'scm-set!/immediate
'tagged-scm-set!/immediate
'word-set! 'word-set!/immediate) _
(obj . _))
(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))
((false? arg))
((nil? arg))
((heap-object? arg))
((thob? arg))
((pair? arg))
((symbol? arg))
((variable? arg))
@ -363,6 +363,11 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . size)
(&allocate
(annotation->memory-kind ann)))))
((tagged-allocate-words/immediate)
(match param
((ann . size)
(&allocate
(annotation->memory-kind ann)))))
((scm-ref obj idx) (&read-object
(annotation->memory-kind param)))
((scm-ref/tag obj) (&read-field
@ -371,6 +376,10 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . idx)
(&read-field
(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
(annotation->memory-kind param)))
((scm-set/tag! obj val) (&write-field
@ -379,6 +388,11 @@ the LABELS that are clobbered by the effects of LABEL."
((ann . idx)
(&write-field
(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
(annotation->memory-kind param)))
((word-ref/immediate obj) (match param

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

@ -216,7 +216,7 @@
(with-cps cps
(letk kres
($kargs ('var) (var)
($branch kbad k src 'heap-object? #f (var))))
($branch kbad k src 'thob? #f (var))))
(build-term
($continue kres src
($primcall 'lookup #f (mod-var name-var)))))))
@ -262,7 +262,7 @@
(letk kok ($kargs () () ($continue k src ($values (cached)))))
(letk ktest
($kargs ('cached) (cached)
($branch kinit kok src 'heap-object? #f (cached))))
($branch kinit kok src 'thob? #f (cached))))
(build-term
($continue ktest src
($primcall 'cache-ref cache-key ()))))))))
@ -296,7 +296,7 @@
(letk kok ($kargs () () ($continue k src ($values (cached)))))
(letk ktest
($kargs ('cached) (cached)
($branch kinit kok src 'heap-object? #f (cached))))
($branch kinit kok src 'thob? #f (cached))))
(build-term
($continue ktest src
($primcall 'cache-ref cache-key ()))))))))
@ -531,6 +531,12 @@
(setk label ($kargs names vars
($continue kop src
($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))))))))
(param (error "unexpected param to reified primcall" name))
(else

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

@ -94,11 +94,11 @@
((eqv? type type*) (values #t #t))
(else (values #f #f))))))
(define-unary-branch-folder (heap-object? type min max)
(define &immediate-types (logior &fixnum &char &special-immediate))
(define-unary-branch-folder (thob? type min max)
(define &non-thob-types (logior &pair &fixnum &char &special-immediate))
(cond
((zero? (logand type &immediate-types)) (values #t #t))
((type<=? type &immediate-types) (values #t #f))
((zero? (logand type &non-thob-types)) (values #t #t))
((type<=? type &non-thob-types) (values #t #f))
(else (values #f #f))))
(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)
(restrict! val &special-immediate (1+ &false) +inf.0)))))
(define-predicate-inferrer (heap-object? val true?)
(define &immediate-types
(logior &fixnum &char &special-immediate))
(define &heap-object-types
(logand &all-types (lognot &immediate-types)))
(restrict! val (if true? &heap-object-types &immediate-types) -inf.0 +inf.0))
(define-predicate-inferrer (thob? val true?)
(define &non-thob-types
(logior &pair &fixnum &char &special-immediate))
(define &thob-types
(logand &all-types (lognot &non-thob-types)))
(restrict! val (if true? &thob-types &non-thob-types) -inf.0 +inf.0))
(define-predicate-inferrer (heap-number? val true?)
(define &heap-number-types
@ -742,6 +742,11 @@ minimum, and maximum."
((annotation . 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)
(restrict! obj (annotation->type param)
(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)
(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)
(restrict! obj (annotation->type param) -inf.0 +inf.0)
(define! result &all-types -inf.0 +inf.0))
@ -767,6 +778,11 @@ minimum, and maximum."
((annotation . idx)
(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)
(restrict! obj (annotation->type param)
(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
($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen)))))
(letk krsh
($kargs ('w0) (w0)
($kargs ('w0) (w0) ;TAGS-SENSITIVE
($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
(letk kv
($kargs () ()
@ -114,7 +114,7 @@
($kargs () ()
($branch knot-vector kv src pred #f (v))))
(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)
;; Precondition: SLEN is a non-negative S64 that is representable as a
@ -342,7 +342,7 @@
(letk ktag0
($kargs ('v) (v)
($continue ktag1 src
($primcall 'ulsh/immediate 8 (usize)))))
($primcall 'ulsh/immediate 8 (usize))))) ;TAGS-SENSITIVE
(letk kalloc
($kargs ('nwords) (nwords)
($continue ktag0 src
@ -420,8 +420,7 @@
(letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x))))
(let$ body (is-pair))
(letk k ($kargs () () ,body))
(letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x))))
(build-term ($branch knot-pair kheap-object src 'heap-object? #f (x)))))
(build-term ($branch knot-pair k src 'pair? #f (x)))))
(define-primcall-converter cons
(lambda (cps k src op param head tail)
@ -433,14 +432,14 @@
(letk ktail
($kargs () ()
($continue kdone src
($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair tail)))))
(letk khead
($kargs ('pair) (pair)
($continue ktail src
($primcall 'scm-set!/immediate '(pair . 0) (pair head)))))
($primcall 'tagged-scm-set!/immediate '(pair . 0) (pair head)))))
(build-term
($continue khead src
($primcall 'allocate-words/immediate '(pair . 2) ()))))))
($primcall 'tagged-allocate-words/immediate '(pair . 2) ()))))))
(define-primcall-converter car
(lambda (cps k src op param pair)
@ -450,7 +449,7 @@
(with-cps cps
(build-term
($continue k src
($primcall 'scm-ref/immediate '(pair . 0) (pair)))))))))
($primcall 'tagged-scm-ref/immediate '(pair . 0) (pair)))))))))
(define-primcall-converter cdr
(lambda (cps k src op param pair)
@ -460,7 +459,7 @@
(with-cps cps
(build-term
($continue k src
($primcall 'scm-ref/immediate '(pair . 1) (pair)))))))))
($primcall 'tagged-scm-ref/immediate '(pair . 1) (pair)))))))))
(define-primcall-converter set-car!
(lambda (cps k src op param pair val)
@ -471,7 +470,7 @@
(with-cps cps
(build-term
($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!
(lambda (cps k src op param pair val)
@ -482,7 +481,7 @@
(with-cps cps
(build-term
($continue k src
($primcall 'scm-set!/immediate '(pair . 1) (pair val)))))))))
($primcall 'tagged-scm-set!/immediate '(pair . 1) (pair val)))))))))
(define-primcall-converter box
(lambda (cps k src op param val)
@ -517,7 +516,7 @@
(let$ body (is-box))
(letk k ($kargs () () ,body))
(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
(lambda (cps k src op param box)
@ -562,7 +561,7 @@
($continue k src ($primcall 'scm-ref/tag 'struct (x)))))
(letk kheap-object
($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
(lambda (cps k src op param struct)
@ -859,7 +858,7 @@
(with-cps cps
(letk kf ($kargs () () ($throw src 'throw/value+data bad-type (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
have-ptr-and-uidx)
@ -1104,7 +1103,7 @@
($kargs () ()
($branch knot-string ks src 'string? #f (x))))
(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 msg "Wrong type argument (expecting char): ~S")
@ -1133,7 +1132,7 @@
(lambda (cps k src op param s idx)
(define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S"))
(define stringbuf-f-wide #x400)
(define stringbuf-f-wide #x400) ;TAGS-SENSITIVE
(ensure-string
cps src op s
(lambda (cps ulen)
@ -1203,7 +1202,7 @@
(lambda (cps k src op param s idx ch)
(define out-of-range
#(out-of-range string-ref "Argument 2 out of range: ~S"))
(define stringbuf-f-wide #x400)
(define stringbuf-f-wide #x400) ;TAGS-SENSITIVE
(ensure-string
cps src op s
(lambda (cps ulen)
@ -1327,7 +1326,7 @@
(let$ body (is-atomic-box))
(letk k ($kargs () () ,body))
(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
(lambda (cps k src op param x)
@ -1421,7 +1420,7 @@
($ (have-var box)))))))
(letk ktest ($kargs () () ,body))
(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)
($continue kbox src
($primcall 'lookup #f (mod name-var)))))
@ -2136,7 +2135,7 @@
(letk kt* ($kargs () ()
($branch kf kt src name #f args)))
(build-term
($branch kf kt* src 'heap-object? #f args)))
($branch kf kt* src 'thob? #f args)))
(with-cps cps
(build-term ($branch kf kt src name #f args)))))))
(($ <conditional> src test consequent alternate)
@ -2459,10 +2458,8 @@ integer."
(heap-number? b)
(bool (primcall heap-numbers-equal? a b))))
('equal?
;; Partially inline.
(primcall-chain (heap-object? a)
(heap-object? b)
(primcall equal? a b))))))))
;; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
(primcall equal? a b)))))))
(($ <primcall> src 'vector args)
;; 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))
(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?"
(hashq-ref *heap-type-predicates* name))

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

@ -1,6 +1,6 @@
;;; Compilation targets
;; Copyright (C) 2011-2014,2017-2018 Free Software Foundation, Inc.
;; Copyright (C) 2011-2014,2017-2019 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@ -34,7 +34,15 @@
target-most-negative-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.
(/ (target-max-size-t) (target-word-size)))
;; TAGS-SENSITIVE
(define (target-max-vector-length)
"Return the maximum vector length of the target platform, in units of
SCM words."
@ -179,18 +188,75 @@ SCM words."
;; type tag. Additionally, restrict to 48-bit address space.
(1- (ash 1 (min (- (* (target-word-size) 8) 8) 48))))
;; TAGS-SENSITIVE
(define (target-most-negative-fixnum)
"Return the most negative integer representable as a fixnum on the
target platform."
(- (ash 1 (- (* (target-word-size) 8) 3))))
(case (target-word-size)
((4) #x-40000000)
((8) #x-800000000000000)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-most-positive-fixnum)
"Return the most positive integer representable as a fixnum on the
target platform."
(1- (ash 1 (- (* (target-word-size) 8) 3))))
(case (target-word-size)
((4) #x3fffffff)
((8) #x7ffffffFFFFFFFF)
(else (error "unexpected word size"))))
;; TAGS-SENSITIVE
(define (target-fixnum? n)
(and (exact-integer? n)
(<= (target-most-negative-fixnum)
n
(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.
;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;; Copyright (C) 2014, 2015, 2017, 2018, 2019 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
@ -308,16 +308,24 @@ KIND/SUB-KIND."
(lambda (io port)
(match io
(($ <inferior-object> kind sub-kind address)
(format port "#<~a ~:[~*~;~a ~]~x>"
(format port "#<~a~:[~*~; ~a~]~:[~*~; ~x~]>"
kind sub-kind sub-kind
address)))))
address address)))))
(define (inferior-smob backend type-number address)
(define (inferior-smob backend type-number flags word1 address)
"Return an object representing the SMOB at ADDRESS whose type is
TYPE-NUMBER."
(inferior-object 'smob
(or (type-number->name backend 'smob type-number)
type-number)
(inferior-object (let ((type-name (or (type-number->name backend 'smob
type-number)
(string->symbol
(string-append "smob-" (number->string type-number))))))
(if (zero? flags)
type-name
(string->symbol (string-append
(symbol->string type-name)
"/"
(number->string flags 16)))))
(number->string word1 16)
address))
(define (inferior-port-type backend address)
@ -438,8 +446,25 @@ using BACKEND."
(inferior-object 'dynamic-state address))
((((flags << 8) || %tc7-port))
(inferior-port backend (logand flags #xff) address))
(((_ & #x7f = %tc7-program))
(inferior-object 'program address))
(((bits & #x7f = %tc7-program) code)
(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))
(inferior-object 'bignum address))
(((_ & #xffff = %tc16-flonum) pad)
@ -458,11 +483,14 @@ using BACKEND."
(((_ & #x7f = %tc7-syntax) expression wrap module)
(cond-expand
(guile-2.2
(make-syntax (cell->object expression backend)
(cell->object wrap backend)
(cell->object module backend)))
(make-syntax (scm->object expression backend)
(scm->object wrap backend)
(scm->object module backend)))
(else
(inferior-object 'syntax address))))
(vector 'syntax-object
(scm->object expression backend)
(scm->object wrap backend)
(scm->object module backend)))))
(((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address))
(((_ & #x7f = %tc7-weak-set))
@ -473,31 +501,35 @@ using BACKEND."
(inferior-object 'array address))
(((_ & #x7f = %tc7-bitvector))
(inferior-object 'bitvector address))
((((smob-type << 8) || %tc7-smob) word1)
(inferior-smob backend smob-type address))))))
(((bits & #x7f = %tc7-smob) word1)
(let ((smob-type (bit-extract bits 8 16))
(flags (ash bits -16)))
(inferior-smob backend smob-type flags word1 address)))))))
(define* (scm->object bits #:optional (backend %ffi-memory-backend))
"Return the Scheme object corresponding to BITS, the bits of an 'SCM'
object."
(match-scm bits
(((integer << 2) || %tc2-fixnum)
(((integer << %fixnum-tag-size) || %fixnum-tag)
integer)
((address & 7 = %tc3-heap-object)
(let* ((type (dereference-word backend address))
(pair? (= (logand type #b1) %tc1-pair)))
(if pair?
(or (and=> (vhash-assv address (%visited-cells)) cdr)
(let ((car type)
(cdrloc (+ address %word-size))
(pair (cons *unspecified* *unspecified*)))
(visited (address -> pair)
(set-car! pair (scm->object car backend))
(set-cdr! pair
(scm->object (dereference-word backend cdrloc)
backend))
pair)))
(cell->object address backend))))
((bits & %pair-tag-mask = %pair-tag)
(or (and=> (vhash-assv bits (%visited-cells)) cdr)
(let* ((carloc (- bits %pair-tag))
(cdrloc (+ carloc %word-size))
(pair (cons *unspecified* *unspecified*)))
(visited (bits -> pair)
(set-car! pair
(scm->object (dereference-word backend carloc)
backend))
(set-cdr! pair
(scm->object (dereference-word backend cdrloc)
backend))
pair))))
((address & %thob-tag-mask = %thob-tag)
(if (zero? address)
(inferior-object 'NULL #f) ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
(cell->object address backend)))
(((char << 8) || %tc8-char)
(integer->char char))
((= %tc16-false) #f)

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

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

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

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