diff --git a/LOG b/LOG index 987cbf19df..d957496023 100644 --- a/LOG +++ b/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 diff --git a/c/globals.h b/c/globals.h index 9006d1a7a3..e1c29ff3cc 100644 --- a/c/globals.h +++ b/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; diff --git a/c/scheme.c b/c/scheme.c index 2dbef6eb57..12c9bf94a8 100644 --- a/c/scheme.c +++ b/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); } diff --git a/mats/7.ms b/mats/7.ms index 36d062c723..f7009ce87e 100644 --- a/mats/7.ms +++ b/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" "")))) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 2bc6ef1d4b..15247e0c38 100644 --- a/release_notes/release_notes.stex +++ b/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 diff --git a/s/7.ss b/s/7.ss index e177bc71ca..7510b21313 100644 --- a/s/7.ss +++ b/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 diff --git a/s/primdata.ss b/s/primdata.ss index 6f719e2eda..d454e90bdf 100644 --- a/s/primdata.ss +++ b/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])