From b02d1b08d7d7f0eaafdd9dcfc3de3a139b25492e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 26 Aug 2019 10:19:24 +0200 Subject: [PATCH] Compiler allocates boxed flonums in unmarked space This fixes a bug whereby the compiler would sometimes allocate floats in marked space. * libguile/gc-inline.h (scm_inline_gc_malloc_pointerless_words): New internal helper. * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): * libguile/intrinsics.c (allocate_pointerless_words): (allocate_pointerless_words_with_freelist): New intrinsics. * libguile/jit.c (compile_allocate_pointerless_words): (compile_allocate_pointerless_words_immediate): New compilers. * libguile/vm-engine.c (allocate_pointerless_words) (allocate_pointerless_words_immediate): New opcodes. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm (param): * module/language/cps/reify-primitives.scm (reify-primitives): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/types.scm (allocate-words): (allocate-words/immediate): * module/system/vm/assembler.scm (system): Add support for the new opcodes. --- libguile/gc-inline.h | 6 +++ libguile/intrinsics.c | 18 +++++++ libguile/intrinsics.h | 2 + libguile/jit.c | 54 ++++++++++++++++++++ libguile/vm-engine.c | 36 ++++++++++++- module/language/cps/compile-bytecode.scm | 6 +++ module/language/cps/effects-analysis.scm | 7 +++ module/language/cps/reify-primitives.scm | 13 +++-- module/language/cps/specialize-primcalls.scm | 2 + module/language/cps/types.scm | 4 ++ module/system/vm/assembler.scm | 2 + 11 files changed, 145 insertions(+), 5 deletions(-) diff --git a/libguile/gc-inline.h b/libguile/gc-inline.h index a1932d65a..cb55aa86a 100644 --- a/libguile/gc-inline.h +++ b/libguile/gc-inline.h @@ -117,6 +117,12 @@ scm_inline_gc_malloc_words (scm_thread *thread, size_t words) return scm_inline_gc_malloc (thread, words * sizeof (void *)); } +static inline void * +scm_inline_gc_malloc_pointerless_words (scm_thread *thread, size_t words) +{ + return scm_inline_gc_malloc_pointerless (thread, words * sizeof (void *)); +} + static inline SCM scm_inline_cell (scm_thread *thread, scm_t_bits car, scm_t_bits cdr) { diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index bb7381f59..a9b2d983b 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -429,6 +429,21 @@ allocate_words_with_freelist (scm_thread *thread, size_t freelist_idx) SCM_INLINE_GC_KIND_NORMAL)); } +static SCM +allocate_pointerless_words (scm_thread *thread, size_t n) +{ + return SCM_PACK_POINTER (scm_inline_gc_malloc_pointerless_words (thread, n)); +} + +static SCM +allocate_pointerless_words_with_freelist (scm_thread *thread, size_t freelist_idx) +{ + return SCM_PACK_POINTER + (scm_inline_gc_alloc (&thread->pointerless_freelists[freelist_idx], + freelist_idx, + SCM_INLINE_GC_KIND_POINTERLESS)); +} + static SCM current_module (scm_thread *thread) { @@ -546,6 +561,9 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.facos = acos; scm_vm_intrinsics.fatan = atan; scm_vm_intrinsics.fatan2 = atan2; + scm_vm_intrinsics.allocate_pointerless_words = allocate_pointerless_words; + scm_vm_intrinsics.allocate_pointerless_words_with_freelist = + allocate_pointerless_words_with_freelist; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index eed871234..d8c69267e 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -186,6 +186,8 @@ typedef uint32_t* scm_t_vcode_intrinsic; M(f64_from_f64, facos, "facos", FACOS) \ M(f64_from_f64, fatan, "fatan", FATAN) \ M(f64_from_f64_f64, fatan2, "fatan2", FATAN2) \ + M(scm_from_thread_sz, allocate_pointerless_words, "allocate-pointerless-words", ALLOCATE_POINTERLESS_WORDS) \ + M(scm_from_thread_sz, allocate_pointerless_words_with_freelist, "allocate-pointerless-words/freelist", ALLOCATE_POINTERLESS_WORDS_WITH_FREELIST) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/jit.c b/libguile/jit.c index 136b8bcaf..f1c7a4941 100644 --- a/libguile/jit.c +++ b/libguile/jit.c @@ -2088,6 +2088,60 @@ compile_allocate_words_immediate (scm_jit_state *j, uint16_t dst, uint16_t nword } } +static void +compile_allocate_pointerless_words (scm_jit_state *j, uint16_t dst, uint16_t nwords) +{ + jit_gpr_t t = T0; + + emit_store_current_ip (j, t); + emit_call_2 (j, scm_vm_intrinsics.allocate_pointerless_words, thread_operand (), + sp_sz_operand (j, nwords)); + emit_retval (j, t); + record_gpr_clobber (j, t); + emit_reload_sp (j); + emit_sp_set_scm (j, dst, t); +} + +static void +compile_allocate_pointerless_words_immediate (scm_jit_state *j, uint16_t dst, uint16_t nwords) +{ + size_t bytes = nwords * sizeof(SCM); + size_t idx = scm_inline_gc_bytes_to_freelist_index (bytes); + + if (SCM_UNLIKELY (idx >= SCM_INLINE_GC_FREELIST_COUNT)) + { + jit_gpr_t t = T0; + emit_store_current_ip (j, t); + emit_call_1 (j, GC_malloc_atomic, jit_operand_imm (JIT_OPERAND_ABI_WORD, bytes)); + emit_retval (j, t); + emit_reload_sp (j); + emit_sp_set_scm (j, dst, t); + } + else + { + jit_gpr_t res = T0; + ptrdiff_t offset = offsetof(struct scm_thread, pointerless_freelists); + offset += idx * sizeof(void*); + emit_ldxi (j, res, THREAD, offset); + jit_reloc_t fast = jit_bnei (j->jit, res, 0); + emit_store_current_ip (j, res); + emit_call_2 (j, scm_vm_intrinsics.allocate_pointerless_words_with_freelist, + thread_operand (), + jit_operand_imm (JIT_OPERAND_ABI_WORD, idx)); + emit_retval (j, res); + emit_reload_sp (j); + jit_reloc_t done = jit_jmp (j->jit); + + jit_patch_here (j->jit, fast); + jit_gpr_t new_freelist = T1; + emit_ldr (j, new_freelist, res); + jit_stxi (j->jit, offset, THREAD, new_freelist); + + jit_patch_here (j->jit, done); + emit_sp_set_scm (j, dst, res); + } +} + static void compile_scm_ref (scm_jit_state *j, uint8_t dst, uint8_t obj, uint8_t idx) { diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 0c2c8e7bf..6b1e20d47 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3280,8 +3280,40 @@ VM_NAME (scm_thread *thread) NEXT (2); } - VM_DEFINE_OP (157, unused_157, NULL, NOP) - VM_DEFINE_OP (158, unused_158, NULL, NOP) + /* allocate-pointerless-words dst:12 count:12 + * + * Allocate a fresh object consisting of COUNT words and store it into + * DST. The result will not be traced by GC. COUNT is a u64 local. + */ + VM_DEFINE_OP (157, allocate_pointerless_words, "allocate-pointerless-words", DOP1 (X8_S12_S12)) + { + uint16_t dst, size; + + UNPACK_12_12 (op, dst, size); + + SYNC_IP (); + SP_SET (dst, CALL_INTRINSIC (allocate_pointerless_words, + (thread, SP_REF_U64 (size)))); + NEXT (1); + } + + /* allocate-words/immediate dst:12 count:12 + * + * Allocate a fresh object consisting of COUNT words and store it into + * DST. The result will not be traced by GC. COUNT is an immediate. + */ + VM_DEFINE_OP (158, allocate_pointerless_words_immediate, "allocate-pointerless-words/immediate", DOP1 (X8_S12_C12)) + { + uint16_t dst, size; + + UNPACK_12_12 (op, dst, size); + + SYNC_IP (); + SP_SET (dst, CALL_INTRINSIC (allocate_pointerless_words, (thread, size))); + + NEXT (1); + } + VM_DEFINE_OP (159, unused_159, NULL, NOP) VM_DEFINE_OP (160, unused_160, NULL, NOP) VM_DEFINE_OP (161, unused_161, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ff593171b..6e7dab8ef 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -162,6 +162,12 @@ (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 'allocate-pointerless-words annotation (nfields)) + (emit-allocate-pointerless-words asm (from-sp dst) + (from-sp (slot nfields)))) + (($ $primcall 'allocate-pointerless-words/immediate + (annotation . nfields)) + (emit-allocate-pointerless-words/immediate asm (from-sp dst) nfields)) (($ $primcall 'scm-ref annotation (obj idx)) (emit-scm-ref asm (from-sp dst) (from-sp (slot obj)) (from-sp (slot idx)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index f5d6bb534..03a8feac6 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -363,6 +363,13 @@ the LABELS that are clobbered by the effects of LABEL." ((ann . size) (&allocate (annotation->memory-kind ann))))) + ((allocate-pointerless-words size) + (&allocate (annotation->memory-kind param))) + ((allocate-pointerless-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 diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 547ea59ee..8165fb2f0 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -416,7 +416,7 @@ ($primcall 'load-u64 %tc16-flonum ())))) (setk label ($kargs names vars ($continue ktag0 src - ($primcall 'allocate-words/immediate + ($primcall 'allocate-pointerless-words/immediate `(flonum . ,(match (target-word-size) (4 4) (8 2))) @@ -507,7 +507,14 @@ ;; ((ulsh/immediate (u6? y) x) (ulsh x y)) (_ (match (cons name args) - (('allocate-words/immediate) + (((or 'allocate-words/immediate + 'allocate-pointerless-words/immediate)) + (define op + (match name + ('allocate-words/immediate + 'allocate-words) + ('allocate-pointerless-words/immediate + 'allocate-pointerless-words))) (match param ((ann . n) (if (u8? n) @@ -516,7 +523,7 @@ (letv n*) (letk kop ($kargs ('n) (n*) ($continue k src - ($primcall 'allocate-words ann (n*))))) + ($primcall op ann (n*))))) (setk label ($kargs names vars ($continue kop src ($primcall 'load-u64 n ()))))))))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 51c10a2ff..6410d80ec 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -122,6 +122,8 @@ (_ #f))) (specialize-case (('allocate-words (? uint? n)) (allocate-words/immediate n ())) + (('allocate-pointerless-words (? uint? n)) + (allocate-pointerless-words/immediate n ())) (('scm-ref o (? uint? i)) (scm-ref/immediate i (o))) (('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x))) ;; Assume (tail-)pointer-ref/immediate can always be emitted directly. diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index cf2fe912a..0a06eb0b9 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -742,6 +742,10 @@ minimum, and maximum." ((annotation . size) (define! result (annotation->type annotation) size size)))) +(define-type-inferrer-aliases allocate-words allocate-pointerless-words) +(define-type-inferrer-aliases allocate-words/immediate + allocate-pointerless-words/immediate) + (define-type-inferrer/param (scm-ref param obj idx result) (restrict! obj (annotation->type param) (1+ (&min/0 idx)) (target-max-size-t/scm)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index cb4311093..a09e5f600 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -144,6 +144,8 @@ emit-allocate-words emit-allocate-words/immediate + emit-allocate-pointerless-words + emit-allocate-pointerless-words/immediate emit-scm-ref emit-scm-set!