mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
further autocompilation tweaks
* module/system/base/compile.scm (compiled-file-name): * libguile/load.c (scm_init_load_path, scm_try_autocompile) (scm_primitive_load_path): Rework so that we search for .go files in the load-compiled path and in the fallback path, but we only autocompile to the fallback path. Should produce a more desirable experience.
This commit is contained in:
Andy Wingo
parent
b193d904bb
commit
5ea401bffe
2 changed files with 76 additions and 76 deletions
|
|
@ -185,6 +185,9 @@ static SCM *scm_loc_load_compiled_extensions;
|
|||
/* Whether we should try to auto-compile. */
|
||||
static SCM *scm_loc_load_should_autocompile;
|
||||
|
||||
/* The fallback path for autocompilation */
|
||||
static SCM *scm_loc_compile_fallback_path;
|
||||
|
||||
SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
|
||||
(SCM path, SCM tail),
|
||||
"Parse @var{path}, which is expected to be a colon-separated\n"
|
||||
|
|
@ -239,6 +242,10 @@ scm_init_load_path ()
|
|||
cpath = scm_parse_path (scm_from_locale_string (env), cpath);
|
||||
else
|
||||
{
|
||||
/* the idea: if GUILE_SYSTEM_COMPILED_PATH is set, then it seems we're working
|
||||
against an uninstalled Guile, in which case we shouldn't be autocompiling,
|
||||
otherwise offer up the user's home directory as penance for not having
|
||||
up-to-date .go files. */
|
||||
char *home;
|
||||
|
||||
home = getenv ("HOME");
|
||||
|
|
@ -255,9 +262,9 @@ scm_init_load_path ()
|
|||
{ char buf[1024];
|
||||
snprintf (buf, sizeof(buf),
|
||||
"%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
|
||||
cpath = scm_cons (scm_from_locale_string (buf), cpath);
|
||||
*scm_loc_compile_fallback_path = scm_from_locale_string (buf);
|
||||
}
|
||||
|
||||
|
||||
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
|
||||
}
|
||||
#endif /* SCM_LIBRARY_DIR */
|
||||
|
|
@ -624,10 +631,10 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
|
|||
}
|
||||
|
||||
static SCM
|
||||
scm_try_autocompile (SCM source, SCM stale_compiled)
|
||||
scm_try_autocompile (SCM source, SCM compiled)
|
||||
{
|
||||
static int message_shown = 0;
|
||||
SCM comp_mod, compiled_file_name, new_compiled, pair;
|
||||
SCM pair;
|
||||
|
||||
if (scm_is_false (*scm_loc_load_should_autocompile))
|
||||
return SCM_BOOL_F;
|
||||
|
|
@ -640,36 +647,7 @@ scm_try_autocompile (SCM source, SCM stale_compiled)
|
|||
message_shown = 1;
|
||||
}
|
||||
|
||||
comp_mod = scm_c_resolve_module ("system base compile");
|
||||
compiled_file_name =
|
||||
scm_module_variable (comp_mod,
|
||||
scm_from_locale_symbol ("compiled-file-name"));
|
||||
|
||||
if (scm_is_false (compiled_file_name))
|
||||
{
|
||||
scm_puts (";;; it seems ", scm_current_error_port ());
|
||||
scm_display (source, scm_current_error_port ());
|
||||
scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
|
||||
scm_current_error_port ());
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
new_compiled = scm_call_1 (scm_variable_ref (compiled_file_name), source);
|
||||
|
||||
if (scm_is_false (new_compiled))
|
||||
return SCM_BOOL_F;
|
||||
else if (!scm_is_true (scm_equal_p (new_compiled, stale_compiled))
|
||||
&& scm_is_true (scm_stat (new_compiled, SCM_BOOL_F))
|
||||
&& compiled_is_newer (source, new_compiled))
|
||||
{
|
||||
scm_puts (";;; found compiled file elsewhere: ",
|
||||
scm_current_error_port ());
|
||||
scm_display (new_compiled, scm_current_error_port ());
|
||||
scm_newline (scm_current_error_port ());
|
||||
return new_compiled;
|
||||
}
|
||||
|
||||
pair = scm_cons (source, new_compiled);
|
||||
pair = scm_cons (source, compiled);
|
||||
return scm_c_catch (SCM_BOOL_T,
|
||||
do_try_autocompile,
|
||||
SCM2PTR (pair),
|
||||
|
|
@ -699,6 +677,31 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
|
|||
*scm_loc_load_compiled_extensions,
|
||||
SCM_BOOL_T);
|
||||
|
||||
if (scm_is_false (compiled_filename)
|
||||
&& scm_is_true (full_filename)
|
||||
&& scm_is_true (*scm_loc_compile_fallback_path))
|
||||
{
|
||||
SCM comp_mod, compiled_file_name;
|
||||
|
||||
comp_mod = scm_c_resolve_module ("system base compile");
|
||||
compiled_file_name =
|
||||
scm_module_variable (comp_mod,
|
||||
scm_from_locale_symbol ("compiled-file-name"));
|
||||
|
||||
if (scm_is_false (compiled_file_name))
|
||||
{
|
||||
scm_puts (";;; it seems ", scm_current_error_port ());
|
||||
scm_display (full_filename, scm_current_error_port ());
|
||||
scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
|
||||
scm_current_error_port ());
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
/* very confusing var names ... */
|
||||
compiled_filename = scm_call_1 (scm_variable_ref (compiled_file_name),
|
||||
full_filename);
|
||||
}
|
||||
|
||||
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
|
||||
{
|
||||
if (scm_is_true (exception_on_not_found))
|
||||
|
|
@ -713,7 +716,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
|
|||
&& compiled_is_newer (full_filename, compiled_filename)))
|
||||
return scm_load_compiled_with_vm (compiled_filename);
|
||||
|
||||
compiled_filename = scm_try_autocompile (full_filename, compiled_filename);
|
||||
if (scm_is_true (compiled_filename))
|
||||
compiled_filename = scm_try_autocompile (full_filename, compiled_filename);
|
||||
|
||||
if (scm_is_true (compiled_filename))
|
||||
return scm_load_compiled_with_vm (compiled_filename);
|
||||
else
|
||||
|
|
@ -765,6 +770,9 @@ scm_init_load ()
|
|||
scm_list_1 (scm_from_locale_string (".go"))));
|
||||
scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
|
||||
|
||||
scm_loc_compile_fallback_path
|
||||
= SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
|
||||
|
||||
scm_loc_load_should_autocompile
|
||||
= SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));
|
||||
|
||||
|
|
|
|||
|
|
@ -108,48 +108,40 @@
|
|||
(stable-sort (map (lambda (x) (cons (key x) x)) list)
|
||||
(lambda (x y) (less (car x) (car y))))))
|
||||
|
||||
;;; This function is among the trickiest I've ever written. I tried many
|
||||
;;; variants. In the end, simple is best, of course.
|
||||
;;;
|
||||
;;; After turning this around a number of times, it seems that the the
|
||||
;;; desired behavior is that .go files should exist in a path, for
|
||||
;;; searching. That is orthogonal to this function. For writing .go
|
||||
;;; files, either you know where they should go, in which case you pass
|
||||
;;; the path directly, assuming they will end up in the path, as in the
|
||||
;;; srcdir != builddir case; or you don't know, in which case this
|
||||
;;; function is called, and we just put them in your own ccache dir in
|
||||
;;; ~/.guile-ccache.
|
||||
(define (compiled-file-name file)
|
||||
(let ((cext (cond ((or (null? %load-compiled-extensions)
|
||||
(string-null? (car %load-compiled-extensions)))
|
||||
(warn "invalid %load-compiled-extensions"
|
||||
%load-compiled-extensions)
|
||||
".go")
|
||||
(else (car %load-compiled-extensions)))))
|
||||
(define (strip-source-extension path)
|
||||
(let lp ((exts %load-extensions))
|
||||
(cond ((null? exts) file)
|
||||
((string-null? (car exts)) (lp (cdr exts)))
|
||||
((string-suffix? (car exts) path)
|
||||
(substring path 0
|
||||
(- (string-length path)
|
||||
(string-length (car exts)))))
|
||||
(else (lp (cdr exts))))))
|
||||
;; there is some trickery here. if no %load-compiled-path is a
|
||||
;; prefix of `file', the stability of the sort makes us end up
|
||||
;; trying to write first to last dir in the path, which is usually
|
||||
;; the $HOME ccache dir.
|
||||
(let lp ((paths (dsu-sort (reverse %load-compiled-path)
|
||||
(lambda (x)
|
||||
(if (string-prefix? x file)
|
||||
(string-length x)
|
||||
0))
|
||||
>)))
|
||||
(if (null? paths)
|
||||
(error "no writable path when compiling" file)
|
||||
(let ((rpath (in-vicinity
|
||||
(car paths)
|
||||
(string-append
|
||||
(strip-source-extension
|
||||
(if (string-prefix? (car paths) file)
|
||||
(substring file (1+ (string-length (car paths))))
|
||||
(substring file 1)))
|
||||
cext))))
|
||||
(if (and (false-if-exception
|
||||
(ensure-writable-dir (dirname rpath)))
|
||||
(or (not (file-exists? rpath))
|
||||
(access? rpath W_OK)))
|
||||
rpath
|
||||
(lp (cdr paths))))))))
|
||||
(define (strip-source-extension path)
|
||||
(let lp ((exts %load-extensions))
|
||||
(cond ((null? exts) file)
|
||||
((string-null? (car exts)) (lp (cdr exts)))
|
||||
((string-suffix? (car exts) path)
|
||||
(substring path 0
|
||||
(- (string-length path)
|
||||
(string-length (car exts)))))
|
||||
(else (lp (cdr exts))))))
|
||||
(define (compiled-extension)
|
||||
(cond ((or (null? %load-compiled-extensions)
|
||||
(string-null? (car %load-compiled-extensions)))
|
||||
(warn "invalid %load-compiled-extensions"
|
||||
%load-compiled-extensions)
|
||||
".go")
|
||||
(else (car %load-compiled-extensions))))
|
||||
(and %compile-fallback-path
|
||||
(let ((f (string-append %compile-fallback-path "/"
|
||||
(strip-source-extension file)
|
||||
(compiled-extension))))
|
||||
(and (false-if-exception (ensure-writable-dir (dirname f)))
|
||||
f))))
|
||||
|
||||
(define* (compile-file file #:key
|
||||
(output-file #f)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue