[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Skip incompatible .go files
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Skip incompatible .go files |
|
Date: |
Wed, 29 Jun 2016 16:11:35 +0000 (UTC) |
wingo pushed a commit to branch stable-2.0
in repository guile.
commit 04359b42b952ce1a09444e64d83dae9fb0a39da6
Author: Andy Wingo <address@hidden>
Date: Sat Jun 11 22:43:50 2016 +0200
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 <address@hidden>.
---
libguile/load.c | 404 ++++++++++++++++++++++++++++++++++-------------
module/ice-9/boot-9.scm | 60 ++++---
2 files changed, 332 insertions(+), 132 deletions(-)
diff --git a/libguile/load.c b/libguile/load.c
index 0a49066..f018181 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -28,26 +28,27 @@
#include <stdio.h>
#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/chars.h"
#include "libguile/dynwind.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
+#include "libguile/eval.h"
+#include "libguile/fluids.h"
+#include "libguile/fports.h"
+#include "libguile/libpath.h"
#include "libguile/modules.h"
-#include "libguile/chars.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/load.h"
-#include "libguile/fluids.h"
-
#include "libguile/vm.h" /* for load-compiled/vm */
+#include "libguile/load.h"
+
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
@@ -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));
-
- 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);
+ scm_call_1 (hook, full_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)));
-
- fallback_chars = scm_to_locale_string (fallback);
- stat_ret = stat (fallback_chars, &stat_compiled);
- free (fallback_chars);
+ SCM freshly_compiled = scm_try_auto_compile (full_filename);
- 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 81a826a..1ed2f9d 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)))))