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.

1 files changed, 54 insertions, 0 deletions

diff --git a/libguile/jit.c b/libguile/jit.c
index 136b8bcaf..f1c7a4941 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);