avoid 8 words of allocation per lambda, whoooo

* libguile/objcodes.c (scm_bytecode_to_objcode): Check that the length of
  the vector matches the length embedded in the bytecode.

* libguile/programs.c (scm_program_meta): Call through to
  scm_objcode_meta, instead of looking in the object table. Avoids
  consing up a program+objcode slice for the meta until the meta is
  actually called.

* libguile/vm-i-loader.c (load-program): Step past the metadata too.

* module/language/glil/compile-assembly.scm (make-meta): Just return the
  load-program form, or #f.
  (assoc-ref-or-acons, object-index-and-alist, make-object-table): Don't
  write the meta into the object table.
  (glil->assembly): Instead write the meta into the load-program form.

libguile/objcodes.c

@@ -190,14 +190,17 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
   data = (struct scm_objcode*)c_bytecode;
   SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
   scm_array_handle_release (&handle);
+
+  SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
+  if (data->len + data->metalen != (size - sizeof (*data)))
+    scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+		    SCM_LIST2 (scm_from_size_t (size),
+                               scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
   assert (increment == 1);
-  SCM_ASSERT_RANGE (0, bytecode, size < 1<<31);
-  SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(*data));
   SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
   
   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
      will be of the same length; perhaps a bad assumption? */
-  /* FIXME: check length of bytecode */
 
   return objcode;
 }

libguile/programs.c

@@ -178,10 +178,15 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_program_meta
 {
-  SCM objs;
+  SCM metaobj;
+  
   SCM_VALIDATE_PROGRAM (1, program);
-  objs = SCM_PROGRAM_OBJTABLE (program);
+
-  return scm_is_true (objs) ? scm_c_vector_ref (objs, 1) : SCM_BOOL_F;
+  metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
+  if (scm_is_true (metaobj))
+    return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
+  else
+    return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 

libguile/vm-i-loader.c

@@ -92,7 +92,7 @@ VM_DEFINE_LOADER (65, load_program, "load-program")
     scm_c_vector_set_x (objs, 0, scm_current_module ());
 
   objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
-  len = sizeof (struct scm_objcode) + SCM_OBJCODE_LEN (objcode);
+  len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 
   PUSH (scm_make_program (objcode, objs, SCM_EOL));
 

module/language/glil/compile-assembly.scm

@@ -44,21 +44,14 @@
 (define-record <subprogram> code)
 
 
-;; A metadata thunk has no object table, so it is very quick to load.
 (define (make-meta bindings sources tail)
   (if (and (null? bindings) (null? sources) (null? tail))
       #f
-      (make-subprogram
+      (compile-assembly
-       ;; we need to prepend #f for the object table. This would have
+       (make-glil-program 0 0 0 0 '()
-       ;; even less overhead if we just appended the metadata-generating
+                          (list
-       ;; instructions after the body of the program's code. A FIXME for
+                           (make-glil-const `(,bindings ,sources ,@tail))
-       ;; the future, eh.
+                           (make-glil-call 'return 0))))))
-       `((make-false)
-         ,(compile-assembly
-           (make-glil-program 0 0 0 0 '()
-                              (list
-                               (make-glil-const `(,bindings ,sources ,@tail))
-                               (make-glil-call 'return 0))))))))
 
 ;; A functional stack of names of live variables.
 (define (make-open-binding name ext? index)
@@ -98,7 +91,7 @@
       (close-all-bindings (close-binding bindings end) end)))
 
 ;; A functional object table.
-(define *module-and-meta* 2)
+(define *module* 1)
 (define (assoc-ref-or-acons alist x make-y)
   (cond ((assoc-ref alist x)
          => (lambda (y) (values y alist)))
@@ -108,15 +101,15 @@
 (define (object-index-and-alist x alist)
   (assoc-ref-or-acons alist x
                       (lambda (x alist)
-                        (+ (length alist) *module-and-meta*))))
+                        (+ (length alist) *module*))))
 
 (define (compile-assembly glil)
   (receive (code . _)
       (glil->assembly glil 0 '() '(()) '() '() #f 0)
     (car code)))
-(define (make-object-table objects meta)
+(define (make-object-table objects)
-  (and (or meta (not (null? objects)))
+  (and (not (null? objects))
-       (list->vector (cons* #f meta objects))))
+       (list->vector (cons #f objects))))
 
 (define (glil->assembly glil nargs nexts-stack bindings
                         source-alist label-alist object-alist addr)
@@ -151,7 +144,9 @@
        (receive (code bindings sources labels objects len)
            (process-body)
          (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
-                                    ,len #f . ,code)))
+                                    ,len
+                                    ,(make-meta bindings sources meta)
+                                    . ,code)))
            (cond
             (toplevel?
              ;; toplevel bytecode isn't loaded by the vm, no way to do
@@ -159,10 +154,7 @@
              ;; anyway)
              (emit-code `(,prog)))
             (else
-             (let ((table (dump-object (make-object-table
+             (let ((table (dump-object (make-object-table objects) addr))
-                                        objects
-                                        (make-meta bindings sources meta))
-                                       addr))
                    (closure (if (> closure-level 0) '((make-closure)) '())))
                (cond
                 (object-alist