optimize and bugfix make-struct VM opcode

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump for make-struct
  change.

* libguile/struct.c (scm_i_alloc_struct): Use scm_words instead of
  scm_gc_malloc to simplify the code and inline the call to GC_MALLOC.

* module/language/tree-il/compile-glil.scm (*primcall-ops*): Compile
  make-struct/no-tail to make-struct.

* module/language/tree-il/primitives.scm (define-primitive-expander):
  Allow a conditional branch of #f to aboirt inlining.
  (make-struct): Expand into make-struct/no-tail in the case that
  tail-size is 0.

* libguile/vm-i-scheme.c (make-struct): Adapt to always assume tail-size
  is 0. Inline allocation if possible. Don't decrement the SP past live
  objects on the stack, which could cause GC to miss references. Use the
  NULLSTACK macro.

libguile/_scm.h

@@ -178,7 +178,7 @@
 
 /* Major and minor versions must be single characters. */
 #define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION P
+#define SCM_OBJCODE_MINOR_VERSION Q
 #define SCM_OBJCODE_MAJOR_VERSION_STRING        \
   SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
 #define SCM_OBJCODE_MINOR_VERSION_STRING        \

libguile/struct.c

@@ -391,11 +391,10 @@ struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
 SCM
 scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
 {
-  scm_t_bits ret;
-  ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct");
-  SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data | scm_tc3_struct);
-  SCM_SET_CELL_WORD_1 (SCM_PACK (ret),
-                       (scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2));
+  SCM ret;
+
+  ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2);
+  SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
 
   /* vtable_data can be null when making a vtable vtable */
   if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
@@ -403,14 +402,14 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
       /* Register a finalizer for the newly created instance.  */
       GC_finalization_proc prev_finalizer;
       GC_PTR prev_finalizer_data;
-      GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
+      GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
 				      struct_finalizer_trampoline,
 				      NULL,
 				      &prev_finalizer,
 				      &prev_finalizer_data);
     }
 
-  return SCM_PACK (ret);
+  return ret;
 }
 
 

libguile/vm-i-scheme.c

@@ -420,36 +420,34 @@ VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1)
 {
   unsigned h = FETCH ();
   unsigned l = FETCH ();
-  scm_t_bits n_args = ((h << 8U) + l);
-  SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
-  const SCM *inits = sp - n_args + 3;
-
-  sp -= n_args - 1;
+  scm_t_bits n = ((h << 8U) + l);
+  SCM vtable = sp[-(n - 1)];
+  const SCM *inits = sp - n + 2;
+  SCM ret;
 
   SYNC_REGISTER ();
 
   if (SCM_LIKELY (SCM_STRUCTP (vtable)
   		  && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
-		  && SCM_I_INUMP (n_tail)))
+                  && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
+                      == n)
+                  && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
     {
-      scm_t_bits n_inits, len;
-
-      n_inits = SCM_I_INUM (n_tail) + n_args - 2;
-      len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
-
-      if (SCM_LIKELY (n_inits == len))
-	{
-	  SCM obj;
-
-	  obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits);
-	  memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM));
-
-	  RETURN (obj);
-	}
+      /* Verily, we are making a simple struct with the right number of
+         initializers, and no finalizer. */
+      ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
+                       n + 1);
+      SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
+      memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
     }
+  else
+    ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
 
-  RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
-			      n_args - 2, (scm_t_bits *) inits));
+  sp -= n;
+  NULLSTACK (n);
+  PUSH (ret);
+
+  NEXT;
 }
 
 VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2)

module/language/tree-il/compile-glil.scm

@@ -120,7 +120,7 @@
    ((struct-vtable . 1) . struct-vtable)
    ((struct-ref . 2) . struct-ref)
    ((struct-set! . 3) . struct-set)
-   (make-struct . make-struct)
+   (make-struct/no-tail . make-struct)
 
    ;; hack for javascript
    ((return . 1) . return)

module/language/tree-il/primitives.scm

@@ -212,6 +212,9 @@
       exp)
      ((number? exp)
       `(make-const src ,exp))
+     ((not exp)
+      ;; failed match
+      #f)
      (else (error "bad consequent yall" exp))))
   `(hashq-set! *primitive-expand-table*
                ',sym
@@ -317,6 +320,13 @@
 (define-primitive-expander variable-set! (var val)
   (variable-set val var))
 
+(define-primitive-expander make-struct (vtable tail-size . args)
+  (if (and (const? tail-size)
+           (let ((n (const-exp tail-size)))
+             (and (number? n) (exact? n) (zero? n))))
+      (make-struct/no-tail vtable . args)
+      #f))
+
 (define-primitive-expander u8vector-ref (vec i)
   (bytevector-u8-ref vec i))
 (define-primitive-expander u8vector-set! (vec i x)