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

@@ -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)
 {

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",

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

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)
 {

libguile/vm-engine.c

@@ -3280,8 +3280,40 @@ VM_NAME (scm_thread *thread)
       NEXT (2);
     }
 
-  VM_DEFINE_OP (157, unused_157, NULL, NOP)
+  /* allocate-pointerless-words dst:12 count:12
-  VM_DEFINE_OP (158, unused_158, NULL, NOP)
+   *
+   * 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)

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))))

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

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 ())))))))))

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.

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))

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!