mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 12:10:26 +02:00
Code Activity

simplify autocompilation some more

Browse source 
* 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 2009-06-05 10:06:39 +02:00
parent 5ea401bffe
commit 3c997c4ba9
2 changed files with 71 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

90
libguile/load.c
View file

@ -241,11 +241,11 @@ scm_init_load_path ()
else if (env) else if (env)
cpath = scm_parse_path (scm_from_locale_string (env), cpath); cpath = scm_parse_path (scm_from_locale_string (env), cpath);
else else
cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
#endif /* SCM_LIBRARY_DIR */
{ {
/* 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; char *home;
home = getenv ("HOME"); home = getenv ("HOME");
@ -264,10 +264,7 @@ scm_init_load_path ()
"%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home); "%s/.guile-ccache/" SCM_EFFECTIVE_VERSION, home);
*scm_loc_compile_fallback_path = scm_from_locale_string (buf); *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 */
env = getenv ("GUILE_LOAD_PATH"); env = getenv ("GUILE_LOAD_PATH");
if (env) if (env)
@ -582,45 +579,50 @@ compiled_is_newer (SCM full_filename, SCM compiled_filename)
scm_puts (compiled, scm_current_error_port ()); scm_puts (compiled, scm_current_error_port ());
scm_puts ("\n", scm_current_error_port ()); scm_puts ("\n", scm_current_error_port ());
res = 0; res = 0;
} }
free (source); free (source);
free (compiled); free (compiled);
return res; return res;
} }
SCM_KEYWORD (k_output_file, "output-file");
static SCM static SCM
do_try_autocompile (void *data) do_try_autocompile (void *data)
{ {
SCM pair = PTR2SCM (data); SCM source = PTR2SCM (data);
SCM comp_mod, compile_file, res; SCM comp_mod, compile_file;
scm_puts (";;; compiling ", scm_current_error_port ()); 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 ()); scm_newline (scm_current_error_port ());
comp_mod = scm_c_resolve_module ("system base compile"); comp_mod = scm_c_resolve_module ("system base compile");
compile_file = scm_c_module_lookup (comp_mod, "compile-file"); 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));
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_puts (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ()); scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ()); scm_newline (scm_current_error_port ());
return res; 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 static SCM
autocompile_catch_handler (void *data, SCM tag, SCM throw_args) 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_puts (";;; WARNING: compilation of ", scm_current_error_port ());
scm_display (scm_car (pair), scm_current_error_port ()); scm_display (source, scm_current_error_port ());
scm_puts ("\n;;; to ", scm_current_error_port ());
scm_display (scm_cdr (pair), scm_current_error_port ());
scm_puts (" failed:\n", scm_current_error_port ()); scm_puts (" failed:\n", scm_current_error_port ());
scm_puts (";;; key ", scm_current_error_port ()); scm_puts (";;; key ", scm_current_error_port ());
scm_write (tag, 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 static SCM
scm_try_autocompile (SCM source, SCM compiled) scm_try_autocompile (SCM source)
{ {
static int message_shown = 0; static int message_shown = 0;
SCM pair;
if (scm_is_false (*scm_loc_load_should_autocompile)) if (scm_is_false (*scm_loc_load_should_autocompile))
return SCM_BOOL_F; return SCM_BOOL_F;
@ -647,12 +648,11 @@ scm_try_autocompile (SCM source, SCM compiled)
message_shown = 1; message_shown = 1;
} }
pair = scm_cons (source, compiled);
return scm_c_catch (SCM_BOOL_T, return scm_c_catch (SCM_BOOL_T,
do_try_autocompile, do_try_autocompile,
SCM2PTR (pair), SCM2PTR (source),
autocompile_catch_handler, autocompile_catch_handler,
SCM2PTR (pair), SCM2PTR (source),
NULL, NULL); NULL, NULL);
} }
@ -679,27 +679,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
if (scm_is_false (compiled_filename) if (scm_is_false (compiled_filename)
&& scm_is_true (full_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; SCM fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
comp_mod = scm_c_resolve_module ("system base compile"); full_filename,
compiled_file_name = scm_car (*scm_loc_load_compiled_extensions)));
scm_module_variable (comp_mod, if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
scm_from_locale_symbol ("compiled-file-name")); compiled_filename = fallback;
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_false (full_filename) && scm_is_false (compiled_filename))
@ -715,15 +704,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
|| (scm_is_true (compiled_filename) || (scm_is_true (compiled_filename)
&& compiled_is_newer (full_filename, compiled_filename))) && compiled_is_newer (full_filename, compiled_filename)))
return scm_load_compiled_with_vm (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)) if (scm_is_true (freshly_compiled))
compiled_filename = scm_try_autocompile (full_filename, compiled_filename); return scm_load_compiled_with_vm (freshly_compiled);
if (scm_is_true (compiled_filename))
return scm_load_compiled_with_vm (compiled_filename);
else else
return scm_primitive_load (full_filename); return scm_primitive_load (full_filename);
} }
}
#undef FUNC_NAME #undef FUNC_NAME
SCM SCM

23
module/system/base/compile.scm
View file

@ -114,21 +114,11 @@
;;; After turning this around a number of times, it seems that the the ;;; 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 ;;; desired behavior is that .go files should exist in a path, for
;;; searching. That is orthogonal to this function. For writing .go ;;; searching. That is orthogonal to this function. For writing .go
;;; files, either you know where they should go, in which case you pass ;;; files, either you know where they should go, in which case you tell
;;; the path directly, assuming they will end up in the path, as in the ;;; compile-file explicitly, as in the srcdir != builddir case; or you
;;; srcdir != builddir case; or you don't know, in which case this ;;; don't know, in which case this function is called, and we just put
;;; function is called, and we just put them in your own ccache dir in ;;; them in your own ccache dir in ~/.guile-ccache.
;;; ~/.guile-ccache.
(define (compiled-file-name file) (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) (define (compiled-extension)
(cond ((or (null? %load-compiled-extensions) (cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions))) (string-null? (car %load-compiled-extensions)))
@ -137,9 +127,8 @@
".go") ".go")
(else (car %load-compiled-extensions)))) (else (car %load-compiled-extensions))))
(and %compile-fallback-path (and %compile-fallback-path
(let ((f (string-append %compile-fallback-path "/" (let ((f (string-append
(strip-source-extension file) %compile-fallback-path "/" file (compiled-extension))))
(compiled-extension))))
(and (false-if-exception (ensure-writable-dir (dirname f))) (and (false-if-exception (ensure-writable-dir (dirname f)))
f)))) f))))