experiment with a different fasl format

Use `vfasl-convert-file` to convert to the vfasl format, something
like this:

 (vfasl-convert-file "orig/petite.boot" "new/petite.boot" '())
 (vfasl-convert-file "orig/scheme.boot" "new/scheme.boot" '("petite"))
 (vfasl-convert-file "orig/racket.boot" "new/racket.boot" '("petite" "scheme"))

original commit: a40886e2fba741ca8cfc5ebd16b902d6414da0ae

c/Mf-base

@@ -23,7 +23,7 @@ Main=../boot/$m/main.$o
 Scheme=../bin/$m/scheme
 
 kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-ocd.c gc-oce.c\
- number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\
+ number.c schsig.c io.c new-io.c print.c fasl.c vfasl.c stats.c foreign.c prim.c prim5.c flushcache.c\
  schlib.c thread.c expeditor.c scheme.c
 
 kernelobj=${kernelsrc:%.c=%.$o} ${mdobj}

c/externs.h

@@ -93,7 +93,7 @@ extern ptr S_relocation_table PROTO((iptr n));
 /* fasl.c */
 extern void S_fasl_init PROTO((void));
 ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, ptr path));
-ptr S_bv_fasl_read PROTO((ptr bv, ptr path));
+ptr S_bv_fasl_read PROTO((ptr bv, int ty, ptr path));
 /* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */
 ptr S_boot_read PROTO((gzFile file, const char *path));
 char *S_format_scheme_version PROTO((uptr n));
@@ -101,6 +101,14 @@ char *S_lookup_machine_type PROTO((uptr n));
 extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n,
              ptr x, iptr o));
 extern ptr S_get_code_obj PROTO((IFASLCODE typ, ptr p, iptr n, iptr o));
+extern int S_fasl_stream_read PROTO((void *stream, octet *dest, iptr n));
+extern int S_fasl_intern_rtd(ptr *x);
+
+/* vfasl.c */
+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));
@@ -152,6 +160,7 @@ extern void S_resize_oblist PROTO((void));
 extern ptr S_intern PROTO((const unsigned char *s));
 extern ptr S_intern_sc PROTO((const string_char *s, iptr n, ptr name_str));
 extern ptr S_intern3 PROTO((const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str));
+extern ptr S_intern4 PROTO((ptr sym));
 extern void S_intern_gensym PROTO((ptr g));
 extern void S_retrofit_nonprocedure_code PROTO((void));
 

c/fasl.c

@@ -211,7 +211,7 @@ static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
 static octet uf_bytein PROTO((unbufFaslFile uf));
 static uptr uf_uptrin PROTO((unbufFaslFile uf));
 static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf));
-static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, unbufFaslFile uf));
+static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, unbufFaslFile uf));
 static void fillFaslFile PROTO((faslFile f));
 static void bytesin PROTO((octet *s, iptr n, faslFile f));
 static void toolarge PROTO((ptr path));
@@ -304,7 +304,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
   return x;
 }
 
-ptr S_bv_fasl_read(ptr bv, ptr path) {
+ptr S_bv_fasl_read(ptr bv, int ty, ptr path) {
   ptr tc = get_thread_context();
   ptr x; struct unbufFaslFileObj uffo;
 
@@ -312,7 +312,7 @@ ptr S_bv_fasl_read(ptr bv, ptr path) {
   tc_mutex_acquire()
   uffo.path = path;
   uffo.type = UFFO_TYPE_BV;
-  x = bv_fasl_entry(tc, bv, &uffo);
+  x = bv_fasl_entry(tc, bv, ty, &uffo);
   tc_mutex_release()
   return x;
 }
@@ -374,6 +374,11 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
   return 0;
 }
 
+int S_fasl_stream_read(void *stream, octet *dest, iptr n)
+{
+  return uf_read((unbufFaslFile)stream, dest, n);
+}
+
 static octet uf_bytein(unbufFaslFile uf) {
   octet buf[1];
   if (uf_read(uf, buf, 1) < 0)
@@ -451,31 +456,47 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
     ty = uf_bytein(uf);
   }
 
-  if (ty != fasl_type_fasl_size)
+  if ((ty != fasl_type_fasl_size)
+      && (ty != fasl_type_vfasl_size))
     S_error1("", "malformed fasl-object header found in ~a", uf->path);
 
   ffo.size = uf_uptrin(uf);
 
-  ffo.buf = buf;
+  if (ty == fasl_type_vfasl_size) {
-  ffo.next = ffo.end = ffo.buf;
+    if (S_vfasl_boot_mode == -1) {
-  ffo.uf = uf;
+      ptr pre = S_cputime();
-
+      Scompact_heap();
-  faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+      S_vfasl_boot_mode = 1;
+      printf("pre compact %ld\n", UNFIX(S_cputime()) - UNFIX(pre));
+    }
+    x = S_vfasl((ptr)0, uf, ffo.size);
+  } else {
+    ffo.buf = buf;
+    ffo.next = ffo.end = ffo.buf;
+    ffo.uf = uf;
+    
+    faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+  }
 
   S_flush_instruction_cache(tc);
   return x;
 }
 
-static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) {
+static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, unbufFaslFile uf) {
   ptr x; ptr strbuf = S_G.null_string;
   struct faslFileObj ffo;
 
   ffo.size = Sbytevector_length(bv);
-  ffo.next = ffo.buf = &BVIT(bv, 0);
-  ffo.end = &BVIT(bv, ffo.size);
-  ffo.uf = uf;
 
-  faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+  if (ty == fasl_type_vfasl_size) {
+    x = S_vfasl(bv, (ptr)0, ffo.size);
+  } else {
+    ffo.next = ffo.buf = &BVIT(bv, 0);
+    ffo.end = &BVIT(bv, ffo.size);
+    ffo.uf = uf;
+    
+    faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
+  }
 
   S_flush_instruction_cache(tc);
   return x;
@@ -694,27 +715,10 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             *x = rtd;
             return;
         } case fasl_type_rtd: {
-            ptr rtd, rtd_uid, plist, ls;
-
             fasl_record(tc, x, t, pstrbuf, f);
-            rtd = *x;
+            if (S_fasl_intern_rtd(x) < 0) {
-            rtd_uid = RECORDDESCUID(rtd);
+              S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(*x), f->uf->path);
-
-           /* see if uid's property list already registers an rtd */
-            plist = SYMSPLIST(rtd_uid);
-            for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) {
-              if (Scar(ls) == S_G.rtd_key) {
-                ptr old_rtd = Scar(Scdr(ls));
-               /* if so, check new rtd against old rtd and return old rtd */
-                if (!rtd_equiv(rtd, old_rtd))
-                  S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(rtd), f->uf->path);
-                *x = old_rtd;
-                return;
-              }
             }
-
-           /* if not, register it */
-            SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist)));
             return;
         }
         case fasl_type_record: {
@@ -1106,6 +1110,33 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
   }
 }
 
+/* Result: 0 => interned; 1 => replaced; -1 => inconsistent */
+int S_fasl_intern_rtd(ptr *x)
+{
+  ptr rtd, rtd_uid, plist, ls;
+
+  rtd = *x;
+  rtd_uid = RECORDDESCUID(rtd);
+
+  /* see if uid's property list already registers an rtd */
+  plist = SYMSPLIST(rtd_uid);
+  for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) {
+    if (Scar(ls) == S_G.rtd_key) {
+      ptr old_rtd = Scar(Scdr(ls));
+      /* if so, check new rtd against old rtd and return old rtd */
+      if (!rtd_equiv(rtd, old_rtd))
+        return -1;
+      else
+        *x = old_rtd;
+      return 1;
+    }
+  }
+  
+  /* if not, register it */
+  SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist)));
+  return 0;
+}
+
 /* limited version for checking rtd fields */
 static IBOOL equalp(x, y) ptr x, y; {
   if (x == y) return 1;
@@ -1121,7 +1152,10 @@ static IBOOL equalp(x, y) ptr x, y; {
 }
 
 static IBOOL rtd_equiv(x, y) ptr x, y; {
-  return RECORDINSTTYPE(x) == RECORDINSTTYPE(y) &&
+  return ((RECORDINSTTYPE(x) == RECORDINSTTYPE(y))
+          /* recognize `base-rtd` shape: */
+          || ((RECORDINSTTYPE(x) == x)
+              && (RECORDINSTTYPE(y) == y))) &&
          RECORDDESCPARENT(x) == RECORDDESCPARENT(y) &&
          equalp(RECORDDESCPM(x), RECORDDESCPM(y)) &&
          equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) &&

c/globals.h

@@ -26,6 +26,7 @@ EXTERN ptr S_child_processes[static_generation+1];
 
 /* scheme.c */
 EXTERN IBOOL S_boot_time;
+EXTERN int S_vfasl_boot_mode;
 EXTERN IBOOL S_errors_to_console;
 EXTERN ptr S_threads;
 EXTERN uptr S_nthreads;
@@ -151,4 +152,9 @@ EXTERN struct {
     ptr eqvp;
     ptr equalp;
     ptr symboleqp;
+
+  /* vfasl.c */
+   struct vfasl_hash_table *c_entries;
+   struct vfasl_hash_table *library_entries;
+   struct vfasl_hash_table *library_entry_codes;
 } S_G;

c/intern.c

@@ -361,7 +361,7 @@ void S_intern_gensym(sym) ptr sym; {
                tc_mutex_release()
                S_error1("intern-gensym", "unique name ~s already interned", uname_str);
             }
-            if (Sstring_ref(str, i) != uname[i]) break;
+            if (STRIT(str, i) != uname[i]) break;
           }
        }
     }
@@ -374,12 +374,58 @@ void S_intern_gensym(sym) ptr sym; {
   tc_mutex_release()
 }
 
+/* must hold mutex */
+ptr S_intern4(sym) ptr sym; {
+  ptr name = SYMNAME(sym);
+
+  if (name == Sfalse) {
+    /* gensym whose name wasn't generated, so far */
+    return sym;
+  } else {
+    ptr uname_str = (Sstringp(name) ? name : Scar(name));
+    if (uname_str == Sfalse) {
+      /* gensym that wasn't interned, so far */
+      return sym;
+    } else {
+      const string_char *uname = &STRIT(uname_str, 0);
+      iptr ulen = Sstring_length(uname_str);
+      iptr hc = UNFIX(SYMHASH(sym));
+      iptr idx = hc % S_G.oblist_length;
+      bucket *b;
+
+      b = S_G.oblist[idx];
+      while (b != NULL) {
+        ptr x = b->sym;
+        ptr x_name = SYMNAME(x);
+        if (Sstringp(name) == Sstringp(x_name)) {
+          ptr str = (Sstringp(x_name) ? x_name : Scar(x_name));
+          if (Sstring_length(str) == ulen) {
+            iptr i;
+            for (i = 0; ; i += 1) {
+              if (i == ulen) {
+                return x;
+              }
+              if (STRIT(str, i) != uname[i]) break;
+            }
+          }
+        }
+        b = b->next;
+      }
+
+      oblist_insert(sym, idx, GENERATION(sym));
+
+      return sym;
+    }
+  }
+}
+
 /* retrofit existing symbols once nonprocedure_code is available */
 void S_retrofit_nonprocedure_code() {
   ptr npc, sym, val; bucket_list *bl;
 
   npc = S_G.nonprocedure_code;
 
+  /* FIXME */
   /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */
   for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) {
     sym = bl->car->sym;

c/prim5.c

@@ -1546,6 +1546,9 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)getpid", (void *)s_getpid);
     Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read);
     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("load %ld\n", reading);
+
   S_G.load_binary = Sfalse;
   gzclose(bd[n].file);
 }
@@ -1116,6 +1123,8 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
     }
   }
 
+  S_vfasl_boot_mode = -1; /* to static generation after compacting initial */
+
   if (boot_count != 0) {
     INT i = 0;
 
@@ -1142,8 +1151,14 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
     while (i < boot_count) load(tc, i++, 0);
   }
 
+  S_vfasl_boot_mode = 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)) {

s/7.ss

@@ -121,7 +121,7 @@
 (set! fasl-read
   (let ()
     (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr))
-    (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr))
+    (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int ptr) ptr))
     (define (get-uptr p)
       (let ([k (get-u8 p)])
         (let f ([k k] [n (fxsrl k 1)])
@@ -168,8 +168,9 @@
                 [(eqv? ty (constant fasl-type-header))
                  (check-header p)
                  (fasl-entry)]
-                [(eqv? ty (constant fasl-type-fasl-size))
+                [(or (eqv? ty (constant fasl-type-fasl-size))
-                 ($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))]
+                     (eqv? ty (constant fasl-type-vfasl-size)))
+                 ($bv-fasl-read (get-bytevector-n p (get-uptr p)) ty (port-name p))]
                 [else (malformed p)])))))))
 
 (define ($compiled-file-header? ip)

s/back.ss

@@ -126,6 +126,11 @@
     (lambda (x)
       (and x #t))))
 
+(define generate-vfasl
+  ($make-thread-parameter #f
+    (lambda (x)
+      (and x #t))))
+
 (define $enable-check-prelex-flags
   ($make-thread-parameter #f
     (lambda (x)

s/cmacros.ss

@@ -433,7 +433,7 @@
 (define-constant fasl-type-graph-ref 18)
 (define-constant fasl-type-gensym 19)
 (define-constant fasl-type-exactnum 20)
-; 21
+(define-constant fasl-type-vfasl-size 21)
 (define-constant fasl-type-fasl-size 22)
 (define-constant fasl-type-record 23)
 (define-constant fasl-type-rtd 24)

s/compile.ss

@@ -22,6 +22,7 @@
 (define $c-make-code)
 (define make-boot-header)
 (define make-boot-file)
+(define vfasl-convert-file)
 
 (let ()
 (import (nanopass))
@@ -440,10 +441,32 @@
       [else (c-assembler-output-error x)])))
 
 (define (c-print-fasl x p)
-  (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))])
+  (cond
-     (c-build-fasl x t a?)
+   [(generate-vfasl) (c-print-vfasl x p)]
-     ($fasl-start p t
+   [else
-       (lambda (p) (c-faslobj x t p a?)))))
+    (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))])
+       (c-build-fasl x t a?)
+       ($fasl-start p t
+         (lambda (p) (c-faslobj x t p a?))))]))
+
+(define (c-vfaslobj x)
+  (let f ([x x])
+    (record-case x
+      [(group) elt*
+       (apply vector (map c-vfaslobj elt*))]
+      [(visit-stuff) elt
+       (cons (constant visit-tag) (c-vfaslobj elt))]
+      [(revisit-stuff) elt
+       (cons (constant revisit-tag) (c-vfaslobj elt))]
+      [else (c-mkcode x)])))
+
+(define c-print-vfasl
+  (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)])
+    (lambda (x p)
+      (let ([bv (->vfasl (c-vfaslobj x))])
+        (put-u8 p (constant fasl-type-vfasl-size))
+        (put-uptr p (bytevector-length bv))
+        (put-bytevector p bv)))))
 
 (define-record-type visit-chunk
   (nongenerative)
@@ -1588,7 +1611,46 @@
   (set-who! $make-boot-header
     ; create boot loader (invoke) for entry into Scheme from C
     (lambda (out machine . bootfiles)
-      (do-make-boot-header who out machine bootfiles))))
+      (do-make-boot-header who out machine bootfiles)))
+  
+  (set-who! vfasl-convert-file
+    (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)
+                        (file-options replace compressed)
+                        (file-options replace)))])
+          (on-reset (delete-file out-file #f)
+            (on-reset (close-port op)
+              (when bootfile*
+                (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* ([write-out (lambda (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)))]
+                         [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))))))))
 
 (set-who! compile-port
   (rec compile-port

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

s/primdata.ss

@@ -960,6 +960,7 @@
   (generate-interrupt-trap [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-procedure-source-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-profile-forms [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  (generate-vfasl [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (generate-wpo-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (gensym-count [sig [() -> (uint)] [(uint) -> (void)]] [flags])
   (gensym-prefix [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted])
@@ -1278,6 +1279,7 @@
   (fasl-file [sig [(pathname pathname) -> (void)]] [flags true])
   (fasl-read [sig [(binary-input-port) -> (ptr)]] [flags true])
   (fasl-write [sig [(sub-ptr binary-output-port) -> (void)]] [flags true])
+  (vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags])
   (file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
   (file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
   (file-directory? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])