From 7142005a055432f0d261c294c8cef012651a1899 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 22:43:50 +0200 Subject: [PATCH] Skip incompatible .go files * libguile/load.c (load_thunk_from_path, try_load_thunk_from_file): New functions. (search_path): Simplify. (scm_primitive_load_path, scm_init_eval_in_scheme): Use the new functions to load compiled files. * module/ice-9/boot-9.scm (load-in-vicinity): Skip invalid .go files. Inspired by a patch from Jan Nieuwenhuizen . --- libguile/load.c | 308 +++++++++++++++++++++++++++++++--------- module/ice-9/boot-9.scm | 58 +++++--- 2 files changed, 278 insertions(+), 88 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 897541490..7ad9a754d 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -28,18 +28,19 @@ #include #include "libguile/_scm.h" -#include "libguile/libpath.h" -#include "libguile/fports.h" -#include "libguile/read.h" -#include "libguile/eval.h" -#include "libguile/throw.h" #include "libguile/alist.h" -#include "libguile/dynwind.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/modules.h" #include "libguile/chars.h" +#include "libguile/dynwind.h" +#include "libguile/eval.h" +#include "libguile/fports.h" +#include "libguile/libpath.h" +#include "libguile/loader.h" +#include "libguile/modules.h" +#include "libguile/read.h" +#include "libguile/root.h" #include "libguile/srfi-13.h" +#include "libguile/strings.h" +#include "libguile/throw.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -570,6 +571,216 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename, return compiled_is_newer; } +static SCM +do_load_thunk_from_file (void *data) +{ + return scm_load_thunk_from_file (SCM_PACK_POINTER (data)); +} + +static SCM +load_thunk_from_file_catch_handler (void *data, SCM tag, SCM throw_args) +{ + SCM filename = SCM_PACK_POINTER (data); + SCM oport, lines; + + oport = scm_open_output_string (); + scm_print_exception (oport, SCM_BOOL_F, tag, throw_args); + + scm_puts (";;; WARNING: loading compiled file ", + scm_current_warning_port ()); + scm_display (filename, scm_current_warning_port ()); + scm_puts (" failed:\n", scm_current_warning_port ()); + + lines = scm_string_split (scm_get_output_string (oport), + SCM_MAKE_CHAR ('\n')); + for (; scm_is_pair (lines); lines = scm_cdr (lines)) + if (scm_c_string_length (scm_car (lines))) + { + scm_puts (";;; ", scm_current_warning_port ()); + scm_display (scm_car (lines), scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + + scm_close_port (oport); + + return SCM_BOOL_F; +} + +static SCM +try_load_thunk_from_file (SCM filename) +{ + return scm_c_catch (SCM_BOOL_T, + do_load_thunk_from_file, + SCM_UNPACK_POINTER (filename), + load_thunk_from_file_catch_handler, + SCM_UNPACK_POINTER (filename), + NULL, NULL); +} + +/* Search the %load-compiled-path for a directory containing a file + named FILENAME. The file must be readable, and not a directory. If + we don't find one, return #f. If we do fine one, treat it as a + compiled file and try to load it as a thunk. If that fails, continue + looking in the path. + + If given, EXTENSIONS is a list of strings; for each directory in + PATH, we search for FILENAME concatenated with each EXTENSION. + + If SOURCE_FILE_NAME is true, then only try to load compiled files + that are newer than SOURCE_STAT_BUF. If they are older, otherwise issuing a warning if + we see a stale file earlier in the path, setting *FOUND_STALE_FILE to + 1. + */ +static SCM +load_thunk_from_path (SCM filename, SCM source_file_name, + struct stat *source_stat_buf, + int *found_stale_file) +{ + struct stringbuf buf; + struct stat stat_buf; + char *filename_chars; + size_t filename_len; + SCM path, extensions; + SCM result = SCM_BOOL_F; + char initial_buffer[256]; + + path = *scm_loc_load_compiled_path; + if (scm_ilength (path) < 0) + scm_misc_error ("%search-path", "path is not a proper list: ~a", + scm_list_1 (path)); + + extensions = *scm_loc_load_compiled_extensions; + if (scm_ilength (extensions) < 0) + scm_misc_error ("%search-path", "bad extensions list: ~a", + scm_list_1 (extensions)); + + scm_dynwind_begin (0); + + filename_chars = scm_to_locale_string (filename); + filename_len = strlen (filename_chars); + scm_dynwind_free (filename_chars); + + /* If FILENAME is absolute and is still valid, return it unchanged. */ + if (is_absolute_file_name (filename)) + { + if (string_has_an_ext (filename, extensions) + && stat (filename_chars, &stat_buf) == 0 + && !(stat_buf.st_mode & S_IFDIR)) + result = scm_load_thunk_from_file (filename); + goto end; + } + + /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ + { + char *endp; + + for (endp = filename_chars + filename_len - 1; + endp >= filename_chars; + endp--) + { + if (*endp == '.') + { + if (!string_has_an_ext (filename, extensions)) + { + /* This filename has an extension, but not one of the right + ones... */ + goto end; + } + /* This filename already has an extension, so cancel the + list of extensions. */ + extensions = SCM_EOL; + break; + } + else if (is_file_name_separator (SCM_MAKE_CHAR (*endp))) + /* This filename has no extension, so keep the current list + of extensions. */ + break; + } + } + + /* This simplifies the loop below a bit. + */ + if (scm_is_null (extensions)) + extensions = scm_listofnullstr; + + buf.buf_len = sizeof initial_buffer; + buf.buf = initial_buffer; + + /* Try every path element. + */ + for (; scm_is_pair (path); path = SCM_CDR (path)) + { + SCM dir = SCM_CAR (path); + SCM exts; + size_t sans_ext_len; + + buf.ptr = buf.buf; + stringbuf_cat_locale_string (&buf, dir); + + /* Concatenate the path name and the filename. */ + + if (buf.ptr > buf.buf + && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1]))) + stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING); + + stringbuf_cat (&buf, filename_chars); + sans_ext_len = buf.ptr - buf.buf; + + /* Try every extension. */ + for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts)) + { + SCM ext = SCM_CAR (exts); + + buf.ptr = buf.buf + sans_ext_len; + stringbuf_cat_locale_string (&buf, ext); + + /* If the file exists at all, we should return it. If the + file is inaccessible, then that's an error. */ + + if (stat (buf.buf, &stat_buf) == 0 + && ! (stat_buf.st_mode & S_IFDIR)) + { + SCM found = + scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); + + if (scm_is_true (source_file_name) && + !compiled_is_fresh (source_file_name, found, + source_stat_buf, &stat_buf)) + { + if (found_stale_file) + *found_stale_file = 1; + continue; + } + + result = try_load_thunk_from_file (found); + if (scm_is_false (result)) + /* Already warned. */ + continue; + + if (found_stale_file && *found_stale_file) + { + scm_puts (";;; found fresh compiled file at ", + scm_current_warning_port ()); + scm_display (found, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + + goto end; + } + } + + if (!SCM_NULL_OR_NIL_P (exts)) + scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list"); + } + + if (!SCM_NULL_OR_NIL_P (path)) + scm_wrong_type_arg_msg (NULL, 0, path, "proper list"); + + end: + scm_dynwind_end (); + return result; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full pathname; otherwise, return #f. @@ -577,17 +788,10 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename, We also fill *stat_buf corresponding to the returned pathname. If given, EXTENSIONS is a list of strings; for each directory in PATH, we search for FILENAME concatenated with each EXTENSION. - - If SOURCE_FILE_NAME is SCM_BOOL_F, then return the first matching - file name that we find in the path. Otherwise only return a file if - it is newer than SOURCE_STAT_BUF, otherwise issuing a warning if we - see a stale file earlier in the path, setting *FOUND_STALE_FILE to 1. */ static SCM search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, - struct stat *stat_buf, - SCM source_file_name, struct stat *source_stat_buf, - int *found_stale_file) + struct stat *stat_buf) { struct stringbuf buf; char *filename_chars; @@ -690,27 +894,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, if (stat (buf.buf, stat_buf) == 0 && ! (stat_buf->st_mode & S_IFDIR)) { - SCM found = + result = scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); - - if (scm_is_true (source_file_name) && - !compiled_is_fresh (source_file_name, found, - source_stat_buf, stat_buf)) - { - if (found_stale_file) - *found_stale_file = 1; - continue; - } - - if (found_stale_file && *found_stale_file) - { - scm_puts (";;; found fresh compiled file at ", - scm_current_warning_port ()); - scm_display (found, scm_current_warning_port ()); - scm_newline (scm_current_warning_port ()); - } - - result = found; goto end; } } @@ -780,8 +965,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1, if (SCM_UNBNDP (require_exts)) require_exts = SCM_BOOL_F; - return search_path (path, filename, extensions, require_exts, &stat_buf, - SCM_BOOL_F, NULL, NULL); + return search_path (path, filename, extensions, require_exts, &stat_buf); } #undef FUNC_NAME @@ -806,7 +990,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_VALIDATE_STRING (1, filename); return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, - SCM_BOOL_F, &stat_buf, SCM_BOOL_F, NULL, NULL); + SCM_BOOL_F, &stat_buf); } #undef FUNC_NAME @@ -973,7 +1157,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, #define FUNC_NAME s_scm_primitive_load_path { SCM filename, exception_on_not_found; - SCM full_filename, compiled_filename; + SCM full_filename, compiled_thunk; SCM hook = *scm_loc_load_hook; struct stat stat_source, stat_compiled; int found_stale_compiled_file = 0; @@ -1010,15 +1194,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, full_filename = search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, SCM_BOOL_F, - &stat_source, SCM_BOOL_F, NULL, NULL); + &stat_source); - compiled_filename = - search_path (*scm_loc_load_compiled_path, filename, - *scm_loc_load_compiled_extensions, SCM_BOOL_T, - &stat_compiled, full_filename, &stat_source, - &found_stale_compiled_file); + compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source, + &found_stale_compiled_file); - if (scm_is_false (compiled_filename) + if (scm_is_false (compiled_thunk) && scm_is_true (full_filename) && scm_is_true (*scm_loc_compile_fallback_path) && scm_is_false (*scm_loc_fresh_auto_compile) @@ -1045,12 +1226,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, scm_display (fallback, scm_current_warning_port ()); scm_newline (scm_current_warning_port ()); } - compiled_filename = fallback; + compiled_thunk = try_load_thunk_from_file (fallback); } free (fallback_chars); } - if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) + if (scm_is_false (full_filename) && scm_is_false (compiled_thunk)) { if (scm_is_true (scm_procedure_p (exception_on_not_found))) return scm_call_0 (exception_on_not_found); @@ -1062,17 +1243,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, } if (!scm_is_false (hook)) - scm_call_1 (hook, (scm_is_true (full_filename) - ? full_filename : compiled_filename)); + scm_call_1 (hook, full_filename); - if (scm_is_true (compiled_filename)) - return scm_load_compiled_with_vm (compiled_filename); + if (scm_is_true (compiled_thunk)) + return scm_call_0 (compiled_thunk); else { SCM freshly_compiled = scm_try_auto_compile (full_filename); if (scm_is_true (freshly_compiled)) - return scm_load_compiled_with_vm (freshly_compiled); + return scm_call_0 (scm_load_thunk_from_file (freshly_compiled)); else return scm_primitive_load (full_filename); } @@ -1088,21 +1268,19 @@ scm_c_primitive_load_path (const char *filename) void scm_init_eval_in_scheme (void) { - SCM eval_scm, eval_go; - struct stat stat_source, stat_compiled; + SCM eval_scm, eval_thunk; + struct stat stat_source; int found_stale_eval_go = 0; eval_scm = search_path (*scm_loc_load_path, scm_from_locale_string ("ice-9/eval.scm"), - SCM_EOL, SCM_BOOL_F, &stat_source, - SCM_BOOL_F, NULL, NULL); - eval_go = search_path (*scm_loc_load_compiled_path, - scm_from_locale_string ("ice-9/eval.go"), - SCM_EOL, SCM_BOOL_F, &stat_compiled, - eval_scm, &stat_source, &found_stale_eval_go); + SCM_EOL, SCM_BOOL_F, &stat_source); + eval_thunk = + load_thunk_from_path (scm_from_locale_string ("ice-9/eval.go"), + eval_scm, &stat_source, &found_stale_eval_go); - if (scm_is_true (eval_go)) - scm_load_compiled_with_vm (eval_go); + if (scm_is_true (eval_thunk)) + scm_call_0 (eval_thunk); else /* If we have no eval.go, we shouldn't load any compiled code at all because we can't guarantee that tail calls will work. */ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ee3648027..6eae844fe 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3728,19 +3728,23 @@ when none is available, reading FILE-NAME with READER." #:opts %auto-compilation-options #:env (current-module))) - ;; Returns the .go file corresponding to `name'. Does not search load - ;; paths, only the fallback path. If the .go file is missing or out - ;; of date, and auto-compilation is enabled, will try - ;; auto-compilation, just as primitive-load-path does internally. - ;; primitive-load is unaffected. Returns #f if auto-compilation - ;; failed or was disabled. + (define (load-thunk-from-file file) + (let ((loader (resolve-interface '(system vm loader)))) + ((module-ref loader 'load-thunk-from-file) file))) + + ;; Returns a thunk loaded from the .go file corresponding to `name'. + ;; Does not search load paths, only the fallback path. If the .go + ;; file is missing or out of date, and auto-compilation is enabled, + ;; will try auto-compilation, just as primitive-load-path does + ;; internally. primitive-load is unaffected. Returns #f if + ;; auto-compilation failed or was disabled. ;; ;; NB: Unless we need to compile the file, this function should not ;; cause (system base compile) to be loaded up. For that reason ;; compiled-file-name partially duplicates functionality from (system ;; base compile). - (define (fresh-compiled-file-name name scmstat go-file-name) + (define (fresh-compiled-thunk name scmstat go-file-name) ;; Return GO-FILE-NAME after making sure that it contains a freshly ;; compiled version of source file NAME with stat SCMSTAT; return #f ;; on failure. @@ -3748,19 +3752,19 @@ when none is available, reading FILE-NAME with READER." (let ((gostat (and (not %fresh-auto-compile) (stat go-file-name #f)))) (if (and gostat (more-recent? gostat scmstat)) - go-file-name + (load-thunk-from-file go-file-name) (begin - (if gostat - (format (current-warning-port) - ";;; note: source file ~a\n;;; newer than compiled ~a\n" - name go-file-name)) + (when gostat + (format (current-warning-port) + ";;; note: source file ~a\n;;; newer than compiled ~a\n" + name go-file-name)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) (format (current-warning-port) ";;; compiling ~a\n" name) (let ((cfn (compile name))) (format (current-warning-port) ";;; compiled ~a\n" cfn) - cfn)) + (load-thunk-from-file cfn))) (else #f))))) #:warning "WARNING: compilation of ~a failed:\n" name)) @@ -3779,28 +3783,36 @@ when none is available, reading FILE-NAME with READER." #:warning "Stat of ~a failed:\n" abs-file-name)) (define (pre-compiled) - (and=> (search-path %load-compiled-path (sans-extension file-name) - %load-compiled-extensions #t) - (lambda (go-file-name) - (let ((gostat (stat go-file-name #f))) - (and gostat (more-recent? gostat scmstat) - go-file-name))))) + (or-map + (lambda (dir) + (or-map + (lambda (ext) + (let ((candidate (string-append (in-vicinity dir file-name) ext))) + (let ((gostat (stat candidate #f))) + (and gostat + (more-recent? gostat scmstat) + (false-if-exception + (load-thunk-from-file candidate) + #:warning "WARNING: failed to load compiled file ~a:\n" + candidate))))) + %load-compiled-extensions)) + %load-compiled-path)) (define (fallback) (and=> (false-if-exception (canonicalize-path abs-file-name)) (lambda (canon) (and=> (fallback-file-name canon) (lambda (go-file-name) - (fresh-compiled-file-name abs-file-name - scmstat - go-file-name)))))) + (fresh-compiled-thunk abs-file-name + scmstat + go-file-name)))))) (let ((compiled (and scmstat (or (pre-compiled) (fallback))))) (if compiled (begin (if %load-hook (%load-hook abs-file-name)) - (load-compiled compiled)) + (compiled)) (start-stack 'load-stack (primitive-load abs-file-name)))))