mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
simplify autocompilation some more
* libguile/load.c (scm_init_load_path): Set the fallback path even if GUILE_SYSTEM_COMPILED_PATH is set. Now that we store full paths in the autocompiled files, and the path contains the effective Guile version, there's no danger of accidental collisions. (do_try_autocompile, autocompile_catch_handler, scm_try_autocompile): Simplify again -- since there's only one place we put autocompiled files, and compile-file finds it itself, there's no need to pass along the compiled file path. (scm_primitive_load_path): Don't call out to compiled-file-name to get the fallback path, as we might not be autocompiling, and besides that we need to check if the file exists at all. * module/system/base/compile.scm (compiled-file-name): Simplify again. The auto-compiled path is just fallback path + full source path + .go.
This commit is contained in:
Andy Wingo
parent
5ea401bffe
commit
3c997c4ba9
2 changed files with 71 additions and 92 deletions
140
libguile/load.c
140
libguile/load.c
|
|
@ -241,34 +241,31 @@ scm_init_load_path ()
|
|||
else if (env)
|
||||
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;
|
||||
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
|
||||
|
||||
home = getenv ("HOME");
|
||||
#ifdef HAVE_GETPWENT
|
||||
if (!home)
|
||||
{
|
||||
struct passwd *pwd;
|
||||
pwd = getpwuid (getuid ());
|
||||
if (pwd)
|
||||
home = pwd->pw_dir;
|
||||
}
|
||||
#endif /* HAVE_GETPWENT */
|
||||
if (home)
|
||||
{ char buf[1024];
|
||||
snprintf (buf, sizeof(buf),
|
||||
"%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
|
||||
*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 */
|
||||
|
||||
{
|
||||
char *home;
|
||||
|
||||
home = getenv ("HOME");
|
||||
#ifdef HAVE_GETPWENT
|
||||
if (!home)
|
||||
{
|
||||
struct passwd *pwd;
|
||||
pwd = getpwuid (getuid ());
|
||||
if (pwd)
|
||||
home = pwd->pw_dir;
|
||||
}
|
||||
#endif /* HAVE_GETPWENT */
|
||||
if (home)
|
||||
{ char buf[1024];
|
||||
snprintf (buf, sizeof(buf),
|
||||
"%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
|
||||
*scm_loc_compile_fallback_path = scm_from_locale_string (buf);
|
||||
}
|
||||
}
|
||||
|
||||
env = getenv ("GUILE_LOAD_PATH");
|
||||
if (env)
|
||||
path = scm_parse_path (scm_from_locale_string (env), path);
|
||||
|
|
@ -582,45 +579,50 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename)
|
|||
scm_puts (compiled, scm_current_error_port ());
|
||||
scm_puts ("\n", scm_current_error_port ());
|
||||
res = 0;
|
||||
|
||||
}
|
||||
|
||||
free (source);
|
||||
free (compiled);
|
||||
return res;
|
||||
}
|
||||
|
||||
SCM_KEYWORD (k_output_file, "output-file");
|
||||
|
||||
static SCM
|
||||
do_try_autocompile (void *data)
|
||||
{
|
||||
SCM pair = PTR2SCM (data);
|
||||
SCM comp_mod, compile_file, res;
|
||||
SCM source = PTR2SCM (data);
|
||||
SCM comp_mod, compile_file;
|
||||
|
||||
scm_puts (";;; compiling ", scm_current_error_port ());
|
||||
scm_display (scm_car (pair), scm_current_error_port ());
|
||||
scm_display (source, scm_current_error_port ());
|
||||
scm_newline (scm_current_error_port ());
|
||||
|
||||
comp_mod = scm_c_resolve_module ("system base compile");
|
||||
compile_file = scm_c_module_lookup (comp_mod, "compile-file");
|
||||
res = scm_call_3 (scm_variable_ref (compile_file), scm_car (pair),
|
||||
k_output_file, scm_cdr (pair));
|
||||
|
||||
scm_puts (";;; compiled ", scm_current_error_port ());
|
||||
scm_display (res, scm_current_error_port ());
|
||||
scm_newline (scm_current_error_port ());
|
||||
|
||||
return res;
|
||||
if (scm_is_true (compile_file))
|
||||
{
|
||||
SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
|
||||
scm_puts (";;; compiled ", scm_current_error_port ());
|
||||
scm_display (res, scm_current_error_port ());
|
||||
scm_newline (scm_current_error_port ());
|
||||
return res;
|
||||
}
|
||||
else
|
||||
{
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
static SCM
|
||||
autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
|
||||
{
|
||||
SCM pair = PTR2SCM (data);
|
||||
SCM source = PTR2SCM (data);
|
||||
scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
|
||||
scm_display (scm_car (pair), scm_current_error_port ());
|
||||
scm_puts ("\n;;; to ", scm_current_error_port ());
|
||||
scm_display (scm_cdr (pair), scm_current_error_port ());
|
||||
scm_display (source, scm_current_error_port ());
|
||||
scm_puts (" failed:\n", scm_current_error_port ());
|
||||
scm_puts (";;; key ", scm_current_error_port ());
|
||||
scm_write (tag, scm_current_error_port ());
|
||||
|
|
@ -631,10 +633,9 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
|
|||
}
|
||||
|
||||
static SCM
|
||||
scm_try_autocompile (SCM source, SCM compiled)
|
||||
scm_try_autocompile (SCM source)
|
||||
{
|
||||
static int message_shown = 0;
|
||||
SCM pair;
|
||||
|
||||
if (scm_is_false (*scm_loc_load_should_autocompile))
|
||||
return SCM_BOOL_F;
|
||||
|
|
@ -647,12 +648,11 @@ scm_try_autocompile (SCM source, SCM compiled)
|
|||
message_shown = 1;
|
||||
}
|
||||
|
||||
pair = scm_cons (source, compiled);
|
||||
return scm_c_catch (SCM_BOOL_T,
|
||||
do_try_autocompile,
|
||||
SCM2PTR (pair),
|
||||
SCM2PTR (source),
|
||||
autocompile_catch_handler,
|
||||
SCM2PTR (pair),
|
||||
SCM2PTR (source),
|
||||
NULL, NULL);
|
||||
}
|
||||
|
||||
|
|
@ -676,30 +676,19 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
|
|||
filename,
|
||||
*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_is_true (*scm_loc_compile_fallback_path)
|
||||
&& scm_is_pair (*scm_loc_load_compiled_extensions)
|
||||
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
|
||||
{
|
||||
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);
|
||||
SCM fallback = scm_string_append
|
||||
(scm_list_3 (*scm_loc_compile_fallback_path,
|
||||
full_filename,
|
||||
scm_car (*scm_loc_load_compiled_extensions)));
|
||||
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
|
||||
compiled_filename = fallback;
|
||||
}
|
||||
|
||||
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
|
||||
|
|
@ -715,14 +704,15 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
|
|||
|| (scm_is_true (compiled_filename)
|
||||
&& compiled_is_newer (full_filename, compiled_filename)))
|
||||
return scm_load_compiled_with_vm (compiled_filename);
|
||||
else
|
||||
{
|
||||
SCM freshly_compiled = scm_try_autocompile (full_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
|
||||
return scm_primitive_load (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
|
||||
|
||||
|
|
|
|||
|
|
@ -114,21 +114,11 @@
|
|||
;;; 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.
|
||||
;;; files, either you know where they should go, in which case you tell
|
||||
;;; compile-file explicitly, 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)
|
||||
(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)))
|
||||
|
|
@ -137,9 +127,8 @@
|
|||
".go")
|
||||
(else (car %load-compiled-extensions))))
|
||||
(and %compile-fallback-path
|
||||
(let ((f (string-append %compile-fallback-path "/"
|
||||
(strip-source-extension file)
|
||||
(compiled-extension))))
|
||||
(let ((f (string-append
|
||||
%compile-fallback-path "/" file (compiled-extension))))
|
||||
(and (false-if-exception (ensure-writable-dir (dirname f)))
|
||||
f))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue