From 04359b42b952ce1a09444e64d83dae9fb0a39da6 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 | 408 +++++++++++++++++++++++++++++----------- module/ice-9/boot-9.scm | 60 +++--- 2 files changed, 334 insertions(+), 134 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 0a490664e..f01818114 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -28,26 +28,27 @@ #include #include "libguile/_scm.h" -#include "libguile/private-gc.h" /* scm_getenv_int */ -#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/srfi-13.h" - -#include "libguile/validate.h" -#include "libguile/load.h" +#include "libguile/dynwind.h" +#include "libguile/eval.h" #include "libguile/fluids.h" - +#include "libguile/fports.h" +#include "libguile/libpath.h" +#include "libguile/modules.h" +#include "libguile/objcodes.h" +#include "libguile/private-gc.h" /* scm_getenv_int */ +#include "libguile/programs.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/vm.h" /* for load-compiled/vm */ +#include "libguile/load.h" + #include #include #include @@ -542,13 +543,259 @@ is_absolute_file_name (SCM filename) return 0; } +/* Return true if COMPILED_FILENAME is newer than source file + FULL_FILENAME, false otherwise. */ +static int +compiled_is_fresh (SCM full_filename, SCM compiled_filename, + struct stat *stat_source, struct stat *stat_compiled) +{ + int compiled_is_newer; + struct timespec source_mtime, compiled_mtime; + + source_mtime = get_stat_mtime (stat_source); + compiled_mtime = get_stat_mtime (stat_compiled); + + if (source_mtime.tv_sec < compiled_mtime.tv_sec + || (source_mtime.tv_sec == compiled_mtime.tv_sec + && source_mtime.tv_nsec <= compiled_mtime.tv_nsec)) + compiled_is_newer = 1; + else + { + compiled_is_newer = 0; + scm_puts (";;; note: source file ", scm_current_warning_port ()); + scm_display (full_filename, scm_current_warning_port ()); + scm_puts ("\n;;; newer than compiled ", scm_current_warning_port ()); + scm_display (compiled_filename, scm_current_warning_port ()); + scm_puts ("\n", scm_current_warning_port ()); + } + + return compiled_is_newer; +} + +static SCM +load_thunk_from_file (SCM file) +{ + return scm_make_program (scm_load_objcode (file), SCM_BOOL_F, SCM_BOOL_F); +} + +static SCM +do_load_thunk_from_file (void *data) +{ + return load_thunk_from_file (PTR2SCM (data)); +} + +static SCM +load_thunk_from_file_catch_handler (void *data, SCM tag, SCM throw_args) +{ + SCM filename = PTR2SCM (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, + PTR2SCM (filename), + load_thunk_from_file_catch_handler, + PTR2SCM (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 = 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. If FILENAME is absolute, return it unchanged. 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. */ + in PATH, we search for FILENAME concatenated with each EXTENSION. + */ static SCM search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, struct stat *stat_buf) @@ -755,35 +1002,6 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, #undef FUNC_NAME -/* Return true if COMPILED_FILENAME is newer than source file - FULL_FILENAME, false otherwise. */ -static int -compiled_is_fresh (SCM full_filename, SCM compiled_filename, - struct stat *stat_source, struct stat *stat_compiled) -{ - int compiled_is_newer; - struct timespec source_mtime, compiled_mtime; - - source_mtime = get_stat_mtime (stat_source); - compiled_mtime = get_stat_mtime (stat_compiled); - - if (source_mtime.tv_sec < compiled_mtime.tv_sec - || (source_mtime.tv_sec == compiled_mtime.tv_sec - && source_mtime.tv_nsec <= compiled_mtime.tv_nsec)) - compiled_is_newer = 1; - else - { - compiled_is_newer = 0; - scm_puts (";;; note: source file ", scm_current_error_port ()); - scm_display (full_filename, scm_current_error_port ()); - scm_puts ("\n;;; newer than compiled ", scm_current_error_port ()); - scm_display (compiled_filename, scm_current_error_port ()); - scm_puts ("\n", scm_current_error_port ()); - } - - return compiled_is_newer; -} - SCM_KEYWORD (kw_env, "env"); SCM_KEYWORD (kw_opts, "opts"); @@ -946,10 +1164,10 @@ 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; - int compiled_is_fallback = 0; + SCM full_filename, compiled_thunk; SCM hook = *scm_loc_load_hook; struct stat stat_source, stat_compiled; + int found_stale_compiled_file = 0; if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", @@ -985,12 +1203,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, *scm_loc_load_extensions, SCM_BOOL_F, &stat_source); - compiled_filename = - search_path (*scm_loc_load_compiled_path, filename, - *scm_loc_load_compiled_extensions, SCM_BOOL_T, - &stat_compiled); + 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) @@ -1006,15 +1222,23 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, scm_car (*scm_loc_load_compiled_extensions))); fallback_chars = scm_to_locale_string (fallback); - if (stat (fallback_chars, &stat_compiled) == 0) + if (stat (fallback_chars, &stat_compiled) == 0 + && compiled_is_fresh (full_filename, fallback, + &stat_source, &stat_compiled)) { - compiled_filename = fallback; - compiled_is_fallback = 1; + if (found_stale_compiled_file) + { + scm_puts (";;; found fresh local cache at ", + scm_current_warning_port ()); + scm_display (fallback, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + 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); @@ -1026,56 +1250,19 @@ 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_false (full_filename) - || (scm_is_true (compiled_filename) - && compiled_is_fresh (full_filename, compiled_filename, - &stat_source, &stat_compiled))) - return scm_load_compiled_with_vm (compiled_filename); - - /* Perhaps there was the installed .go that was stale, but our fallback is - fresh. Let's try that. Duplicating code, but perhaps that's OK. */ - - if (!compiled_is_fallback - && scm_is_true (*scm_loc_compile_fallback_path) - && scm_is_false (*scm_loc_fresh_auto_compile) - && scm_is_pair (*scm_loc_load_compiled_extensions) - && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) + if (scm_is_true (compiled_thunk)) + return scm_call_0 (compiled_thunk); + else { - SCM fallback; - char *fallback_chars; - int stat_ret; - - fallback = scm_string_append - (scm_list_3 (*scm_loc_compile_fallback_path, - canonical_suffix (full_filename), - scm_car (*scm_loc_load_compiled_extensions))); + SCM freshly_compiled = scm_try_auto_compile (full_filename); - fallback_chars = scm_to_locale_string (fallback); - stat_ret = stat (fallback_chars, &stat_compiled); - free (fallback_chars); - - if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback, - &stat_source, &stat_compiled)) - { - scm_puts (";;; found fresh local cache at ", scm_current_warning_port ()); - scm_display (fallback, scm_current_warning_port ()); - scm_newline (scm_current_warning_port ()); - return scm_load_compiled_with_vm (fallback); - } + if (scm_is_true (freshly_compiled)) + return scm_load_compiled_with_vm (freshly_compiled); + else + return scm_primitive_load (full_filename); } - - /* Otherwise, we bottom out here. */ - { - SCM freshly_compiled = scm_try_auto_compile (full_filename); - - if (scm_is_true (freshly_compiled)) - return scm_load_compiled_with_vm (freshly_compiled); - else - return scm_primitive_load (full_filename); - } } #undef FUNC_NAME @@ -1088,20 +1275,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); - 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_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_scm) && scm_is_true (eval_go) - && compiled_is_fresh (eval_scm, eval_go, - &stat_source, &stat_compiled)) - 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 */ *scm_loc_load_compiled_path = SCM_EOL; diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 81a826aba..1ed2f9de7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3970,19 +3970,25 @@ 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 ((objcode (resolve-interface '(system vm objcode))) + (program (resolve-interface '(system vm program)))) + ((module-ref program 'make-program) + ((module-ref objcode 'load-objcode) 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. @@ -3990,19 +3996,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)) @@ -4021,28 +4027,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)))))