From 067555c25148ce26fdb8ba3d183c5e0808355132 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Jan 2018 19:39:20 -0700 Subject: [PATCH] add load-compiled-from-port and Sregister_boot_file_fd original commit: a0adfa18af879f90d746b0b3541b036016957324 --- LOG | 4 ++++ c/scheme.c | 46 ++++++++++++++++++++++++++++++---------------- csug/foreign.stex | 9 ++++++--- csug/system.stex | 18 ++++++++++++++++++ mats/7.ms | 8 ++++++++ s/7.ss | 28 ++++++++++++++++++++++------ s/mkheader.ss | 1 + s/primdata.ss | 1 + 8 files changed, 90 insertions(+), 25 deletions(-) diff --git a/LOG b/LOG index e15a70a3a3..e4732990cb 100644 --- a/LOG +++ b/LOG @@ -971,3 +971,7 @@ bootstrap failures after small changes like the recent change to procedure names, so we don't have to rebuild the boot files as often. Mf-base +- add load-compiled-from-port and Sregister_boot_file_fd for loading modes + based on open files instead of paths + 7.ss, primdata.ss, mkheader.ss, scheme.c + 7.ms, foreign.stex, system.stex diff --git a/c/scheme.c b/c/scheme.c index 15a10dfca4..0397f9b6da 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -558,10 +558,11 @@ static boot_desc bd[MAX_BOOT_FILES]; /* locally defined functions */ static uptr zget_uptr PROTO((gzFile file, uptr *pn)); static INT zgetstr PROTO((gzFile file, char *s, iptr max)); -static IBOOL find_boot PROTO((const char *name, const char *ext, IBOOL errorp)); +static IBOOL find_boot PROTO((const char *name, const char *ext, int fd, IBOOL errorp)); static void load PROTO((ptr tc, iptr n, IBOOL base)); +static void check_boot_file_state PROTO((const char *who)); -static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp; { +static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IBOOL errorp; { char pathbuf[PATH_MAX], buf[PATH_MAX]; uptr n; INT c; const char *path; @@ -572,7 +573,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp; #endif gzFile file; - if (S_fixedpathp(name)) { + if ((fd != -1) || S_fixedpathp(name)) { if (strlen(name) >= PATH_MAX) { fprintf(stderr, "boot-file path is too long %s\n", name); S_abnormal_exit(); @@ -580,16 +581,21 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp; path = name; + if (fd != -1) { + file = gzdopen(fd, "rb"); + } else { #ifdef WIN32 - expandedpath = S_malloc_wide_pathname(path); - file = gzopen_w(expandedpath, "rb"); + expandedpath = S_malloc_wide_pathname(path); + file = gzopen_w(expandedpath, "rb"); #else - expandedpath = S_malloc_pathname(path); - file = gzopen(expandedpath, "rb"); + expandedpath = S_malloc_pathname(path); + file = gzopen(expandedpath, "rb"); #endif - /* assumption (seemingly true based on a glance at the source code): - gzopen doesn't squirrel away a pointer to expandedpath. */ - free(expandedpath); + /* assumption (seemingly true based on a glance at the source code): + gzopen doesn't squirrel away a pointer to expandedpath. */ + free(expandedpath); + } + if (!file) { if (errorp) { fprintf(stderr, "cannot open boot file %s\n", path); @@ -752,7 +758,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp; gzclose(file); S_abnormal_exit(); } - if (find_boot(buf, ".boot", 0)) break; + if (find_boot(buf, ".boot", -1, 0)) break; if ((c = gzgetc(file)) == ')') { char *sep; char *wastebuf[8]; fprintf(stderr, "cannot find subordinate boot file "); @@ -1025,20 +1031,28 @@ extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); { #endif } -extern void Sregister_boot_file(name) const char *name; { +static void check_boot_file_state(const char *who) { switch (current_state) { case UNINITIALIZED: case DEINITIALIZED: - fprintf(stderr, "error (Sregister_boot_file): uninitialized; call Sscheme_init first\n"); + fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who); if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit(); case RUNNING: - fprintf(stderr, "error (Sregister_boot_file): already running\n"); + fprintf(stderr, "error (%s): already running\n", who); S_abnormal_exit(); case BOOTING: break; } +} - find_boot(name, "", 1); +extern void Sregister_boot_file(name) const char *name; { + check_boot_file_state("Sregister_boot_file"); + find_boot(name, "", -1, 1); +} + +extern void Sregister_boot_file_fd(name, fd) const char *name; int fd; { + check_boot_file_state("Sregister_boot_file_fd"); + find_boot(name, "", fd, 1); } extern void Sregister_heap_file(UNUSED const char *path) { @@ -1093,7 +1107,7 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i } #endif - if (!find_boot(name, ".boot", 0)) { + if (!find_boot(name, ".boot", -1, 0)) { fprintf(stderr, "cannot find compatible %s.boot in search path\n \"%s%s\"\n", name, Sschemeheapdirs, Sdefaultheapdirs); diff --git a/csug/foreign.stex b/csug/foreign.stex index 42fe062775..5807378658 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -2804,6 +2804,7 @@ program. \cfunction{void}{Sscheme_init}{void (*\var{abnormal}_\var{exit})(void)} \cfunction{void}{Sset_verbose}{int \var{v}} \cfunction{void}{Sregister_boot_file}{const char *\var{name}} +\cfunction{void}{Sregister_boot_file_fd}{const char *\var{name}, int \var{fd}} \cfunction{void}{Sbuild_heap}{const char *\var{exec}, void (*\var{custom}_\var{init})(void)} \cfunction{void}{Senable_expeditor}{const char *\var{history}_\var{file}} \cfunction{void}{Sretain_static_relocation}{void} @@ -2836,9 +2837,11 @@ for subsequently registered boot files. \scheme{Sregister_boot_file} searches for the named boot file and -register it for loading. -The file is opened but not loaded until the heap is built via -\scheme{Sbuild_heap}. +register it for loading, while \scheme{Sregister_boot_file_fd} +provides a specific boot file as a file descriptor. +When only a boot file name is provided, the file is opened but not loaded until the heap is built via +\scheme{Sbuild_heap}. When a file descriptor is provided, the given file name +is used only for error reporting. For the first boot file registered only, the system also searches for the boot files upon which the named file depends, either directly or indirectly. diff --git a/csug/system.stex b/csug/system.stex index 84df092d9e..5696121b88 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -980,6 +980,24 @@ determines the set of directories searched for source files not identified by absolute path names. +%---------------------------------------------------------------------------- +\entryheader +\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port})} +\returns result of the last compiled expression +\listlibraries +\endentryheader + +\noindent +\scheme{load-compiled-from-port} reads and evaluates the object-code contents +of \var{input-port} as previously created by functions like \scheme{compile-file}, +\scheme{compile-script}, \scheme{compile-library}, and +\scheme{compile-to-port}. + +The return value is the value of the last expression whose compiled +form is in \var{input-port}. If \var{input-port} is empty, then the +result value is unspecified. + + %---------------------------------------------------------------------------- \entryheader \formdef{visit}{\categoryprocedure}{(visit \var{path})} diff --git a/mats/7.ms b/mats/7.ms index 1b8cae5751..343fc1e1c3 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -112,6 +112,14 @@ "6\n") ) +(mat load-compiled-from-port + (begin + (define-values (o get) (open-bytevector-output-port)) + (compile-to-port '((define lcfp1 'worked) 'loaded) o) + (equal? 'loaded (load-compiled-from-port (open-bytevector-input-port (get))))) + (equal? 'worked lcfp1) +) + (mat compile-to-file (begin (delete-file (format "testfile.~s" (machine-type))) diff --git a/s/7.ss b/s/7.ss index 7510b21313..c012aed2a6 100644 --- a/s/7.ss +++ b/s/7.ss @@ -184,13 +184,15 @@ (let () (define do-load-binary - (lambda (who fn ip situation for-import?) + (lambda (who fn ip situation for-import? results?) (let ([load-binary (make-load-binary who fn situation for-import?)]) - (let loop () - (let ([x (fasl-read ip)]) + (let loop ([lookahead-x #f]) + (let* ([x (or lookahead-x (fasl-read ip))] + [next-x (and results? (not (eof-object? x)) (fasl-read ip))]) (cond [(eof-object? x) (close-port ip)] - [else (load-binary x) (loop)])))))) + [(and results? (eof-object? next-x)) (load-binary x)] + [else (load-binary x) (loop next-x)])))))) (define (make-load-binary who fn situation for-import?) (module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner @@ -216,9 +218,17 @@ [(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)]))) + (define run-vector + (lambda (x i) + (cond + [(fx= (fx+ i 1) (vector-length x)) + (run-outer (vector-ref x i))] + [else + (run-outer (vector-ref x i)) + (run-vector x (fx+ i 1))]))) (lambda (x) (cond - [(vector? x) (vector-for-each run-outer x)] + [(vector? x) (run-vector x 0)] [(Lexpand? x) ($interpret-backend x situation for-import? fn)] [else (run-outer x)]))) @@ -240,7 +250,7 @@ (begin (set-port-position! ip start-pos) 0)))]) (port-file-compressed! ip) (if ($compiled-file-header? ip) - (do-load-binary who fn ip situation for-import?) + (do-load-binary who fn ip situation for-import? #f) (begin (when ($port-flags-set? ip (constant port-flag-compressed)) ($oops who "missing header for compiled file ~s" fn)) @@ -256,6 +266,12 @@ (lambda (fn situation for-import?) (make-load-binary '$make-load-binary fn situation for-import?))) + (set-who! load-compiled-from-port + (lambda (ip) + (unless (and (input-port? ip) (binary-port? ip)) + ($oops who "~s is not a binary input port" ip)) + (do-load-binary who (port-name ip) ip 'load #f #t))) + (set-who! load-program (rec load-program (case-lambda diff --git a/s/mkheader.ss b/s/mkheader.ss index 7da1e17211..e10453e9bc 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -372,6 +372,7 @@ (export "void" "Sset_verbose" "(int)") (export "void" "Sscheme_init" "(void (*)(void))") (export "void" "Sregister_boot_file" "(const char *)") + (export "void" "Sregister_boot_file_fd" "(const char *, int fd)") (export "void" "Sregister_heap_file" "(const char *)") (export "void" "Scompact_heap" "(void)") (export "void" "Ssave_heap" "(const char *, int)") diff --git a/s/primdata.ss b/s/primdata.ss index d454e90bdf..f2ed2c0f14 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1396,6 +1396,7 @@ (list-head [sig [(sub-ptr sub-index) -> (ptr)]] [flags alloc]) (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03]) (load [sig [(pathname) (pathname procedure) -> (void)]] [flags true ieee r5rs]) + (load-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags]) (load-library [sig [(pathname) (pathname procedure) -> (void)]] [flags true]) (profile-load-data [sig [(pathname) -> (void)]] [flags true]) (load-program [sig [(pathname) (pathname procedure) -> (void)]] [flags true])