[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Compiler allocates boxed flonums in unmarked spac
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Compiler allocates boxed flonums in unmarked space |
|
Date: |
Mon, 26 Aug 2019 04:35:56 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit b02d1b08d7d7f0eaafdd9dcfc3de3a139b25492e
Author: Andy Wingo <address@hidden>
Date: Mon Aug 26 10:19:24 2019 +0200
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 a1932d6..cb55aa8 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 bb7381f..a9b2d98 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -430,6 +430,21 @@ allocate_words_with_freelist (scm_thread *thread, size_t
freelist_idx)
}
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)
{
return scm_i_current_module (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 eed8712..d8c6926 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 136b8bc..f1c7a49 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -2089,6 +2089,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)
{
emit_sp_ref_scm (j, T0, obj);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 0c2c8e7..6b1e20d 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 ff59317..6e7dab8 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 f5d6bb5..03a8fea 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 547ea59..8165fb2 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 51c10a2..6410d80 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 cf2fe91..0a06eb0 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 cb43110..a09e5f6 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!