combine multiple fasl to one vfasl when possible

original commit: d8d4400b42196088defac994b7f97a26446d8ed2

c/externs.h

@@ -108,6 +108,7 @@ extern int S_fasl_intern_rtd(ptr *x);
 extern ptr S_to_vfasl PROTO((ptr v));
 extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr len));
 extern ptr S_vfasl_to PROTO((ptr v));
+extern IBOOL S_vfasl_can_combinep(ptr v);
 
 /* flushcache.c */
 extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes));

c/prim5.c

@@ -1548,6 +1548,7 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read);
     Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl);
     Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to);
+    Sforeign_symbol("(cs)vfasl_can_combinep", (void *)S_vfasl_can_combinep);
     Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float);
 
     Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd);

c/scheme.c

@@ -884,7 +884,11 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
   i = 0;
   while (i++ < LOADSKIP && S_boot_read(bd[n].file, bd[n].path) != Seof_object);
 
+  ptr pre = S_cputime();
+  uptr reading = 0;
+
   while ((x = S_boot_read(bd[n].file, bd[n].path)) != Seof_object) {
+    reading += UNFIX(S_cputime()) - UNFIX(pre);
     if (loadecho) {
       printf("%ld: ", (long)i);
       fflush(stdout);
@@ -917,8 +921,11 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
       fflush(stdout);
     }
     i += 1;
+    pre = S_cputime();
   }
 
+  printf("done %ld\n", reading);
+
   S_G.load_binary = Sfalse;
   gzclose(bd[n].file);
 }
@@ -1142,8 +1149,12 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
     while (i < boot_count) load(tc, i++, 0);
   }
 
+  ptr pre = S_cputime();
+
   if (boot_count != 0) Scompact_heap();
 
+  printf("compact %ld\n", UNFIX(S_cputime()) - UNFIX(pre));
+
  /* complete the initialization on the Scheme side */
   p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init"));
   if (!Sprocedurep(p)) {

c/vfasl.c

@@ -75,7 +75,7 @@ struct vfasl_count_and_chunk {
 };
 
 enum {
-  /* The order of these spaces matters: */
+  /* The order of these spaces needs to match vfasl_header: */
   vspace_symbol,
   vspace_rtd,
   vspace_closure,
@@ -109,6 +109,8 @@ typedef struct vfasl_info {
   octet *ptr_bitmap;
 
   struct vfasl_hash_table *graph;
+
+  IBOOL installs_library_entry; /* to determine whether vfasls can be combined */
 } vfasl_info;
 
 #define ptr_add(p, n) ((ptr)((uptr)(p) + (n)))
@@ -138,6 +140,7 @@ static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p);
 static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p);
 
 static void fasl_init_entry_tables();
+static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name);
 
 static int detect_singleton(ptr p);
 static ptr lookup_singleton(int which);
@@ -365,7 +368,6 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
 
   /* Fix code via relocations */
   {    
-    
     ptr sym_base = data;
     ptr code = TYPE(ptr_add(data, header.code_offset), type_typed_object);
     ptr code_end = TYPE(ptr_add(data, header.code_end_offset), type_typed_object);
@@ -394,6 +396,50 @@ ptr S_vfasl_to(ptr bv)
   return S_vfasl(bv, (ptr)0, Sbytevector_length(bv));
 }
 
+static void vfasl_init(vfasl_info *vfi) {
+  int s;
+  
+  vfi->base_addr = (ptr)0;
+  vfi->sym_count = 0;
+  vfi->symref_count = 0;
+  vfi->symrefs = (ptr)0;
+  vfi->base_rtd = S_G.base_rtd;
+  vfi->rtdref_count = 0;
+  vfi->rtdrefs = (ptr)0;
+  vfi->singletonref_count = 0;
+  vfi->singletonrefs = (ptr)0;
+  vfi->graph = make_vfasl_hash_table();
+  vfi->ptr_bitmap = (ptr)0;
+  vfi->installs_library_entry = 0;
+
+  for (s = 0; s < vspaces_count; s++) {
+    vfasl_chunk *c;
+
+    c = malloc(sizeof(vfasl_chunk));
+    c->bytes = (ptr)0;
+    c->length = 0;
+    c->used = 0;
+    c->swept = 0;
+    c->next = (ptr)0;
+
+    vfi->spaces[s].first = c;
+    vfi->spaces[s].total_bytes = 0;
+  }
+}
+
+static void vfasl_free_chunks(vfasl_info *vfi) {
+  int s;
+  for (s = 0; s < vspaces_count; s++) {
+    vfasl_chunk *c, *next;
+    for (c = vfi->spaces[s].first; c; c = next) {
+      next = c->next;
+      if (c->bytes)
+        free(c->bytes);
+      free(c);
+    }
+  }
+}
+
 ptr S_to_vfasl(ptr v)
 {
   vfasl_info *vfi;
@@ -420,44 +466,13 @@ ptr S_to_vfasl(ptr v)
 
   vfi = malloc(sizeof(vfasl_info));
 
-  vfi->base_addr = (ptr)0;
+  vfasl_init(vfi);
-  vfi->sym_count = 0;
-  vfi->symref_count = 0;
-  vfi->symrefs = (ptr)0;
-  vfi->base_rtd = S_G.base_rtd;
-  vfi->rtdref_count = 0;
-  vfi->rtdrefs = (ptr)0;
-  vfi->singletonref_count = 0;
-  vfi->singletonrefs = (ptr)0;
-  vfi->graph = make_vfasl_hash_table();
-  vfi->ptr_bitmap = (ptr)0;
 
   /* First pass: determine sizes */
 
-  for (s = 0; s < vspaces_count; s++) {
-    vfasl_chunk *c;
-
-    c = malloc(sizeof(vfasl_chunk));
-    c->bytes = (ptr)0;
-    c->length = 0;
-    c->used = 0;
-    c->swept = 0;
-    c->next = (ptr)0;
-
-    vfi->spaces[s].first = c;
-    vfi->spaces[s].total_bytes = 0;
-  }
-
   (void)vfasl_copy_all(vfi, v);
 
-  for (s = 0; s < vspaces_count; s++) {
+  vfasl_free_chunks(vfi);
-    vfasl_chunk *c, *next;
-    for (c = vfi->spaces[s].first; c; c = next) {
-      next = c->next;
-      free(c->bytes);
-      free(c);
-    }
-  }
 
   free_vfasl_hash_table(vfi->graph);
 
@@ -587,8 +602,9 @@ ptr S_to_vfasl(ptr v)
   sort_offsets(vfi->singletonrefs, vfi->singletonref_count);
 
   for (s = 0; s < vspaces_count; s++) {
-    free(vfi->spaces[s].first);
+    free(vfi->spaces[s].first->bytes = (ptr)0);
   }
+  vfasl_free_chunks(vfi);
 
   free_vfasl_hash_table(vfi->graph);
 
@@ -597,6 +613,40 @@ ptr S_to_vfasl(ptr v)
   return bv;
 }
 
+/* If compiled code uses `$install-library-entry`, then it can't be
+   combined into a single vfasled object, because the installation
+   needs to be evaluated for laster vfasls. Recognize a non-combinable
+   value as anything that references the C entry or even mentions the
+   symbol `$install-library-entry` (as defined in "library.ss"). If
+   non-boot code mentions the symbol `$install-library-entry`, it just
+   isn't as optimal.
+
+   This is an expensive test, since we perform half of a vfasl
+   encoding to look for `$install-library-entry`. */
+IBOOL S_vfasl_can_combinep(ptr v)
+{
+  IBOOL installs;
+  vfasl_info *vfi;
+
+  fasl_init_entry_tables();
+
+  /* Run a "first pass" */
+  
+  vfi = malloc(sizeof(vfasl_info));
+  vfasl_init(vfi);
+  (void)vfasl_copy_all(vfi, v);
+  vfasl_free_chunks(vfi);
+  free_vfasl_hash_table(vfi->graph);
+
+  installs = vfi->installs_library_entry;
+    
+  free(vfi);
+
+  return !installs;
+}
+
+/*************************************************************/
+
 static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) {
   seginfo *si;
   int s;
@@ -825,17 +875,8 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
           n = size_code(CODELEN(pp));
           FIND_ROOM(vfi, vspace_code, type_typed_object, n, p);
           copy_ptrs(type_typed_object, p, pp, n);
-          if (CODERELOC(pp) == (ptr)0) {
+          if (CODERELOC(pp) == (ptr)0)
-            /* We only get here if we're vfasling code that belongs in
+            vfasl_fail(vfi, "code without relocation");
-               the static generation. */
-            ptr l; iptr ln;
-            ln = size_reloc_table(0);
-            FIND_ROOM(vfi, vspace_reloc, typemod, ln, l);
-            RELOCSIZE(l) = 0;
-            RELOCCODE(l) = p;
-            CODERELOC(p) = l;
-            vfasl_register_pointer(vfi, &CODERELOC(p));
-          }
       } else if ((iptr)tf == type_rtd_counts) {
         /* prune counts, since GC will recreate as needed */
           return Sfalse;
@@ -864,6 +905,9 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
         if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) {
           vfasl_fail(vfi, "continuation");
           return (ptr)0;
+        } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
+          vfasl_fail(vfi, "mutable closure");
+          return (ptr)0;
         } else {
             iptr len, n;
             len = CLOSLEN(pp);
@@ -880,6 +924,8 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
         INITSYMSPLIST(p) = Snil;
         INITSYMNAME(p) = SYMNAME(pp);
         INITSYMHASH(p) = SYMHASH(pp);
+        if (Sstringp(SYMNAME(pp)))
+          vfasl_check_install_library_entry(vfi, SYMNAME(pp));
     } else if (t == type_flonum) {
         FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p);
         FLODAT(p) = FLODAT(pp);
@@ -1116,6 +1162,8 @@ static uptr sweep_code_object(vfasl_info *vfi, ptr co) {
         if ((which_singleton = detect_singleton(obj))) {
           obj = FIX(VFASL_RELOC_SINGLETON(which_singleton));
         } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) {
+          if ((uptr)pos == CENTRY_install_library_entry)
+            vfi->installs_library_entry = 1;
           obj = FIX(VFASL_RELOC_C_ENTRY(pos));
         } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) {
           obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos));
@@ -1239,6 +1287,20 @@ static void fasl_init_entry_tables()
   tc_mutex_release()
 }
 
+static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name)
+{
+  const char *ile = "$install-library-entry";
+  iptr len = Sstring_length(name), i;
+
+  for (i = 0; i < len; i++) {
+    if (Sstring_ref(name, i) != (unsigned)ile[i])
+      return;
+  }
+
+  if (!ile[i])
+    vfi->installs_library_entry = 1;
+}
+
 /*************************************************************/
 
 static int detect_singleton(ptr p) {

s/compile.ss

@@ -1614,7 +1614,8 @@
       (do-make-boot-header who out machine bootfiles)))
   
   (set-who! vfasl-convert-file
-    (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)])
+    (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]
+          [vfasl-can-combine? (foreign-procedure "(cs)vfasl_can_combinep" (scheme-object) boolean)])
       (lambda (in-file out-file bootfile*)
         (let ([op ($open-file-output-port who out-file
                     (if (compile-compressed)
@@ -1626,15 +1627,28 @@
                 (emit-boot-header op (constant machine-type) bootfile*))
               (let ([ip ($open-file-input-port who in-file (file-options compressed))])
                 (on-reset (close-port ip)
-                  (let loop ()
+                  (let* ([write-out (lambda (x)
-                    (let ([x (fasl-read ip)])
-                      (unless (eof-object? x)
                                       (emit-header op (constant machine-type))
                                       (let ([bv (->vfasl x)])
                                         (put-u8 op (constant fasl-type-vfasl-size))
                                         (put-uptr op (bytevector-length bv))
-                          (put-bytevector op bv))
+                                        (put-bytevector op bv)))]
-                        (loop))))
+                         [write-out-accum (lambda (accum)
+                                            (unless (null? accum)
+                                              (write-out (list->vector (reverse accum)))))])
+                    (let loop ([accum '()])
+                      (let ([x (fasl-read ip)])
+                        (cond
+                         [(eof-object? x)
+                          (write-out-accum accum)]
+                         [(not (vfasl-can-combine? x))
+                          (write-out-accum accum)
+                          (write-out x)
+                          (loop '())]
+                         [(vector? x)
+                          (loop (append (reverse (vector->list x)) accum))]
+                         [else
+                          (loop (cons x accum))]))))
                   (close-port ip)))
               (close-port op))))))))
 

s/library.ss

@@ -74,6 +74,7 @@
     ($hand-coded 'nonprocedure-code)))
 
 (define $foreign-entry ($hand-coded '$foreign-entry-procedure))
+;; The name `$install-library-entry` is special to `vfasl-can-combine?`
 (define $install-library-entry
   ($hand-coded '$install-library-entry-procedure))