From 87c1f272e1e99c037a20028be40b8baaa9322252 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 8 Jun 2019 21:12:43 -0400 Subject: WIP: New tagging v9 --- libguile/alist.c | 4 +- libguile/array-handle.c | 2 +- libguile/arrays.c | 2 +- libguile/arrays.h | 2 +- libguile/bitvectors.c | 2 +- libguile/bytevectors.h | 2 +- libguile/eq.c | 36 ++++++---- libguile/eval.h | 9 --- libguile/evalext.c | 15 ++-- libguile/gc-inline.h | 2 +- libguile/gc.c | 4 +- libguile/gc.h | 11 ++- libguile/generalized-arrays.c | 2 +- libguile/generalized-arrays.h | 2 +- libguile/goops.c | 26 +++---- libguile/hash.c | 97 +++++++++++++------------- libguile/instructions.c | 1 + libguile/jit.c | 108 +++++++++++++++++++++-------- libguile/list.c | 6 +- libguile/modules.h | 2 +- libguile/numbers.c | 2 +- libguile/numbers.h | 33 ++++----- libguile/pairs.h | 14 ++-- libguile/print.c | 30 +++----- libguile/procprop.c | 2 +- libguile/read.c | 4 +- libguile/scm.h | 78 +++++++++++---------- libguile/srcprop.c | 12 ++-- libguile/struct.c | 2 +- libguile/struct.h | 2 +- libguile/vectors.h | 2 +- libguile/vm-engine.c | 94 +++++++++++++++++++++++-- libguile/vm.c | 4 +- libguile/weak-set.c | 10 ++- libguile/weak-table.c | 8 ++- libguile/weak-vector.c | 5 +- module/language/bytecode.scm | 7 +- module/language/cps/closure-conversion.scm | 2 +- module/language/cps/compile-bytecode.scm | 30 ++++++-- module/language/cps/contification.scm | 7 +- module/language/cps/cse.scm | 1 + module/language/cps/dce.scm | 1 + module/language/cps/effects-analysis.scm | 16 ++++- module/language/cps/reify-primitives.scm | 12 +++- module/language/cps/type-fold.scm | 8 +-- module/language/cps/types.scm | 28 ++++++-- module/language/tree-il/compile-cps.scm | 47 ++++++------- module/language/tree-il/cps-primitives.scm | 2 +- module/system/base/target.scm | 74 ++++++++++++++++++-- module/system/base/types.scm | 94 ++++++++++++++++--------- module/system/base/types/internal.scm | 87 +++++++++++++---------- module/system/vm/assembler.scm | 77 +++++++++++++------- module/system/vm/disassembler.scm | 13 +++- 53 files changed, 757 insertions(+), 386 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index 7bc86be9f..8b423738e 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -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)) diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 4b69e67a1..27245ac71 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -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; diff --git a/libguile/arrays.c b/libguile/arrays.c index 0a919515b..dbe0efd6e 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -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)) { diff --git a/libguile/arrays.h b/libguile/arrays.h index 7221fdb63..d592099b6 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -66,7 +66,7 @@ SCM_API SCM scm_array_rank (SCM ra); #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) -#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a) +#define SCM_I_ARRAYP(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)) diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 0bb4c1f59..1c932e20b 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -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)) diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 980d6e267..f0ce2325b 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -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)) diff --git a/libguile/eq.c b/libguile/eq.c index 627d6f09b..3f1239f56 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -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); diff --git a/libguile/eval.h b/libguile/eval.h index b25e76f94..6987399ab 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -33,15 +33,6 @@ -/* {Ilocs} - * - * Ilocs are relative pointers into local environment structures. - * - */ -#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc) - - - /* {Evaluator} */ diff --git a/libguile/evalext.c b/libguile/evalext.c index 4ac434343..dd93959b8 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -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: diff --git a/libguile/gc-inline.h b/libguile/gc-inline.h index 62fdb9eec..3f0dec587 100644 --- a/libguile/gc-inline.h +++ b/libguile/gc-inline.h @@ -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))); } diff --git a/libguile/gc.c b/libguile/gc.c index 5bbe1d968..5dc566123 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -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)) diff --git a/libguile/gc.h b/libguile/gc.h index 387f78a7d..8c891d141 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -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)) diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c index 28ca6b3c7..d1a959edc 100644 --- a/libguile/generalized-arrays.c +++ b/libguile/generalized-arrays.c @@ -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)) diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h index 130807b29..ec88d651c 100644 --- a/libguile/generalized-arrays.h +++ b/libguile/generalized-arrays.h @@ -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) diff --git a/libguile/goops.c b/libguile/goops.c index fd312a8f1..99353b555 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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; } diff --git a/libguile/hash.c b/libguile/hash.c index d6e93dae0..c590dc56d 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -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_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_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)); } diff --git a/libguile/instructions.c b/libguile/instructions.c index ddd88b311..8295a5c4a 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -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. */ \ diff --git a/libguile/jit.c b/libguile/jit.c index 5350982d2..b850ca672 100644 --- a/libguile/jit.c +++ b/libguile/jit.c @@ -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) \ { \ diff --git a/libguile/list.c b/libguile/list.c index 82aab8a5d..70bfcb077 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -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 diff --git a/libguile/modules.h b/libguile/modules.h index 34edb328d..5b7b25c84 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -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") diff --git a/libguile/numbers.c b/libguile/numbers.c index d1b463358..4626ccee4 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -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))) */ diff --git a/libguile/numbers.h b/libguile/numbers.h index b472ab8cd..14cb851f8 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -1,7 +1,7 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2018 +/* Copyright 1995-1996,1998,2000-2006,2008-2011,2013-2014,2016-2019 Free Software Foundation, Inc. This file is part of Guile. @@ -38,7 +38,7 @@ * In the current implementation, Inums must also fit within a long * because that's what GMP's mpz_*_si functions accept. */ typedef long scm_t_inum; -#define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2) +#define SCM_I_FIXNUM_BIT (SCM_SIZEOF_UINTPTR_T * 8 - scm_fixnum_tag_size) #define SCM_MOST_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1)) #define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 1)) @@ -67,18 +67,18 @@ typedef long scm_t_inum; NOTE: X must not perform side effects. */ #ifdef __GNUC__ -# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), 2)) +# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), scm_fixnum_tag_size)) #else -# define SCM_I_INUM(x) \ - (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \ - ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2) \ - : (scm_t_inum) (SCM_UNPACK (x) >> 2)) +# define SCM_I_INUM(x) \ + (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \ + ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> scm_fixnum_tag_size) \ + : (scm_t_inum) (SCM_UNPACK (x) >> scm_fixnum_tag_size)) #endif -#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) +#define SCM_I_INUMP(x) ((SCM_UNPACK (x) & scm_fixnum_tag_mask) == scm_fixnum_tag) #define SCM_I_NINUMP(x) (!SCM_I_INUMP (x)) #define SCM_I_MAKINUM(x) \ - (SCM_PACK ((((scm_t_bits) (x)) << 2) + scm_tc2_int)) + (SCM_PACK ((((scm_t_bits) (x)) << scm_fixnum_tag_size) + scm_fixnum_tag)) /* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */ #define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) @@ -130,19 +130,20 @@ typedef long scm_t_inum; */ -/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only - * differ in one bit: This way, checking if an object is an inexact number can - * be done quickly (using the TYP16S macro). */ +/* Note that scm_tc16_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)) diff --git a/libguile/pairs.h b/libguile/pairs.h index 617b4c229..02e8919b3 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -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 */ diff --git a/libguile/print.c b/libguile/print.c index b10f0f8a8..f60444a82 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -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); } diff --git a/libguile/procprop.c b/libguile/procprop.c index 89cc6c2f7..942ce16e6 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -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); diff --git a/libguile/read.c b/libguile/read.c index f146f0ef0..bc8b30100 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -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)); diff --git a/libguile/scm.h b/libguile/scm.h index b4c605ec8..64984dfdf 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -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) -/* Definitions for tc3: */ +#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 -#define SCM_ITAG3(x) (7 & SCM_UNPACK (x)) -#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x)) -#define scm_tc3_cons 0 +/* Definitions for tc3: */ + #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) diff --git a/libguile/srcprop.c b/libguile/srcprop.c index b644a32a5..0667d9741 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -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); diff --git a/libguile/struct.c b/libguile/struct.c index 3dbcc71d4..716d30df9 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -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) { diff --git a/libguile/struct.h b/libguile/struct.h index c9533518b..46dfd2baf 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -109,7 +109,7 @@ typedef void (*scm_t_struct_finalize) (SCM obj); -#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct)) +#define SCM_STRUCTP(X) (SCM_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) diff --git a/libguile/vectors.h b/libguile/vectors.h index 41e2c8909..b0819b1ad 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -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)) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index e089d4faa..e581a2003 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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) diff --git a/libguile/vm.c b/libguile/vm.c index 82cdae91a..be59ad290 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -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, diff --git a/libguile/weak-set.c b/libguile/weak-set.c index 8cf1b8286..06fec2d6b 100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@ -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; } diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 1e4d8d302..f51a4717c 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -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 diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c index b087891f6..02fbc77c5 100644 --- a/libguile/weak-vector.c +++ b/libguile/weak-vector.c @@ -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 diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index ec0392ba4..4e67c411d 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -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) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 77c8faef3..a0e09df52 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -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) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ad43eebf5..70327ce93 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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)) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 43a58a1e6..73e69f7f3 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -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)) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 70b3ad3e0..6cbc17f75 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -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)) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 6fc885e7f..3d0d1e972 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -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) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 250aec78a..edba3669d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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 diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 6ec90299e..3f5eec445 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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 diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 405806626..9cde7e5fa 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -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) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 2e73705d3..425e80af8 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 6c8884add..ff52a5f49 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -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))))))) (($ 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))))))) (($ src 'vector args) ;; Expand to "allocate-vector" + "vector-init!". diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm index b9f2fe95b..710e651a3 100644 --- a/module/language/tree-il/cps-primitives.scm +++ b/module/language/tree-il/cps-primitives.scm @@ -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)) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 2088cd866..d6fb6e77c 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011-2014,2017-2018 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014,2017-2019 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -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")))) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 418c9fed4..f0151f359 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -1,5 +1,5 @@ ;;; 'SCM' type tag decoding. -;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017, 2018, 2019 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU Lesser General Public License as published by @@ -308,16 +308,24 @@ KIND/SUB-KIND." (lambda (io port) (match io (($ 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) diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm index 9e4e4cc9c..cef812e94 100644 --- a/module/system/base/types/internal.scm +++ b/module/system/base/types/internal.scm @@ -1,5 +1,5 @@ ;;; Details on internal value representation. -;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017-2019 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU Lesser General Public License as published by @@ -16,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?")))))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 241d285d3..b5adc39fb 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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 @@ -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 diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 83499333c..7519e2e0b 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -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) -- cgit v1.2.1