handle compiled library code in boot files once base boot is loaded

original commit: 23788415327a5396d14e452fca410ba68431098b

LOG

@@ -919,3 +919,5 @@
     8.ms
 - Added -Wno-implicit-fallthrough flag to macOS C makefiles.
     c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx
+- handle compiled library code in boot files once base boot is loaded
+    globals.h, scheme.c, 7.ss, 7.ms, primdata.ss

c/globals.h

@@ -73,6 +73,9 @@ EXTERN struct {
     ptr heap_reserve_ratio_id;
     IBOOL retain_static_relocation;
     IBOOL enable_object_counts;
+    ptr scheme_version_id;
+    ptr make_load_binary_id;
+    ptr load_binary;
 
   /* foreign.c */
     ptr foreign_static;

c/scheme.c

@@ -126,6 +126,13 @@ static void main_init() {
     S_protect(&S_G.heap_reserve_ratio_id);
     S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio");
     SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio));
+
+    S_protect(&S_G.scheme_version_id);
+    S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version");
+    S_protect(&S_G.make_load_binary_id);
+    S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary");
+    S_protect(&S_G.load_binary);
+    S_G.load_binary = Sfalse;
 }
 
 static ptr fixtest = FIX(-1);
@@ -817,6 +824,16 @@ static void handle_visit_revisit(tc, p) ptr tc; ptr p; {
   }
 }
 
+static int set_load_binary(iptr n) {
+  if (SYMVAL(S_G.scheme_version_id) == sunbound) return 0; // set by back.ss
+  ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
+  if (Sprocedurep(make_load_binary)) {
+    S_G.load_binary = Scall3(make_load_binary, Sstring(bd[n].path), Sstring_to_symbol("load"), Sfalse);
+    return 1;
+  }
+  return 0;
+}
+
 static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
   ptr x; iptr i;
 
@@ -849,6 +866,10 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
     if (Sprocedurep(x)) {
       S_initframe(tc, 0);
       x = boot_call(tc, x, 0);
+    } else if (Sprocedurep(S_G.load_binary) || set_load_binary(n)) {
+      S_initframe(tc, 1);
+      S_put_arg(tc, 1, x);
+      x = boot_call(tc, S_G.load_binary, 1);
     } else if (Svectorp(x)) {
       iptr j, n;
       n = Svector_length(x);
@@ -872,6 +893,7 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
     i += 1;
   }
 
+  S_G.load_binary = Sfalse;
   gzclose(bd[n].file);
 }
 

mats/7.ms

@@ -931,6 +931,31 @@
           (unless (eof-object? err) (error 'bootfile-test1 err))
           out)))
     "hello 1\nhello 2\nhello 3\nhello 4\nhello 5\n")
+  (equal?
+    (begin
+      (parameterize ([optimize-level 2])
+        (compile-to-file
+         '((library (A) (export a) (import (scheme)) (define a 'aye))
+           (library (B) (export b) (import (A) (scheme)) (define b (list a 'captain))))
+         "testfile-libs.so")
+        (make-boot-file "testfile.boot" '("petite") "testfile-libs.so"))
+      (let-values ([(to-stdin from-stdout from-stderr pid)
+                    (open-process-ports
+                      (format "~a -b testfile.boot -q"
+                        (if (windows?)
+                            (list->string (subst #\\ #\/ (string->list *scheme*)))
+                            *scheme*))
+                      (buffer-mode block)
+                      (native-transcoder))])
+        (pretty-print '(let () (import (B)) (printf "~s\n" b)) to-stdin)
+        (close-output-port to-stdin)
+        (let ([out (get-string-all from-stdout)]
+              [err (get-string-all from-stderr)])
+          (close-input-port from-stdout)
+          (close-input-port from-stderr)
+          (unless (eof-object? err) (error 'bootfile-test1 err))
+          out)))
+    "(aye captain)\n")
   (equal?
     (begin
       (unless (or (embedded?) (equal? *scheme* (format "../bin/~a/scheme~a" (machine-type) (if (windows?) ".exe" ""))))

release_notes/release_notes.stex

@@ -1566,6 +1566,12 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Boot files containing compiled library code fail to load}
+
+Compiled library code may now appear within fasl objects loaded during
+the boot process, provided that they are appended to the end of the base boot
+file or appear within a later boot file.
+
 \subsection{Misleading cyclic dependency error (9.5)}
 
 The library system no longer reports a cyclic dependency error

s/7.ss

@@ -185,36 +185,42 @@
 (let ()
   (define do-load-binary
     (lambda (who fn ip situation for-import?)
-      (module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
-               recompile-info? library/ct-info? library/rt-info? program-info?)
-        (import (nanopass))
-        (include "base-lang.ss")
-        (include "expand-lang.ss"))
-      (define unexpected-value!
-        (lambda (x)
-          ($oops who "unexpected value ~s read from ~a" x fn)))
-      (let loop ()
-        (let ([x (fasl-read ip)])
-          (define run-inner
-            (lambda (x)
-              (cond
-                [(procedure? x) (x)]
-                [(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]
-                [(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]
-                [(program-info? x) ($install-program-desc x)]
-                [else (unexpected-value! x)])))
-          (define run-outer
-            (lambda (x)
-              (cond
-                [(recompile-info? x) (void)]
-                [(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
-                [(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
-                [else (run-inner x)])))
-          (cond
-            [(eof-object? x) (close-port ip)]
-            [(vector? x) (vector-for-each run-outer x) (loop)]
-            [(Lexpand? x) ($interpret-backend x situation for-import? fn) (loop)]
-            [else (run-outer x) (loop)])))))
+      (let ([load-binary (make-load-binary who fn situation for-import?)])
+        (let loop ()
+          (let ([x (fasl-read ip)])
+            (cond
+             [(eof-object? x) (close-port ip)]
+             [else (load-binary x) (loop)]))))))
+
+  (define (make-load-binary who fn situation for-import?)
+    (module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
+              recompile-info? library/ct-info? library/rt-info? program-info?)
+      (import (nanopass))
+      (include "base-lang.ss")
+      (include "expand-lang.ss"))
+    (define unexpected-value!
+      (lambda (x)
+        ($oops who "unexpected value ~s read from ~a" x fn)))
+    (define run-inner
+      (lambda (x)
+        (cond
+         [(procedure? x) (x)]
+         [(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]
+         [(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]
+         [(program-info? x) ($install-program-desc x)]
+         [else (unexpected-value! x)])))
+    (define run-outer
+      (lambda (x)
+        (cond
+         [(recompile-info? x) (void)]
+         [(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
+         [(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
+         [else (run-inner x)])))
+    (lambda (x)
+      (cond
+       [(vector? x) (vector-for-each run-outer x)]
+       [(Lexpand? x) ($interpret-backend x situation for-import? fn)]
+       [else (run-outer x)])))
 
   (define (do-load who fn situation for-import? ksrc)
     (let ([ip ($open-file-input-port who fn)])
@@ -246,6 +252,10 @@
                   (set! ip (transcoded-port ip (current-transcoder)))
                   (ksrc ip sfd ($make-read ip sfd fp)))))))))
 
+  (set! $make-load-binary
+    (lambda (fn situation for-import?)
+      (make-load-binary '$make-load-binary fn situation for-import?)))
+
   (set-who! load-program
     (rec load-program
       (case-lambda

s/primdata.ss

@@ -2072,6 +2072,7 @@
   ($make-fptr [flags pure mifoldable discard true])
   ($make-graph-env [flags])
   ($make-library-requirements-options [flags pure discard true])
+  ($make-load-binary [flags])
   ($make-object-finder [flags])
   ($make-promise [flags alloc])
   ($make-read [flags])