diff options
author | Andy Wingo <wingo@pobox.com> | 2009-06-05 10:06:39 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-06-05 10:06:39 +0200 |
commit | 3c997c4ba9862b9f9bd19aac3d6ac866b2b42a77 (patch) | |
tree | 20fb69a62b7774e0213a7e7aed0af2a7f6ad66f2 | |
parent | 5ea401bffe2ea60545338a48767f4c75d48642c7 (diff) | |
download | guile-3c997c4ba9862b9f9bd19aac3d6ac866b2b42a77.tar.gz |
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.
-rw-r--r-- | libguile/load.c | 138 | ||||
-rw-r--r-- | module/system/base/compile.scm | 23 |
2 files changed, 70 insertions, 91 deletions
diff --git a/libguile/load.c b/libguile/load.c index f54015bc5..9746c14a1 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -241,33 +241,30 @@ 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); + +#endif /* SCM_LIBRARY_DIR */ + + { + char *home; - home = getenv ("HOME"); + home = getenv ("HOME"); #ifdef HAVE_GETPWENT - if (!home) - { - struct passwd *pwd; - pwd = getpwuid (getuid ()); - if (pwd) - home = pwd->pw_dir; - } + 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 */ + 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) @@ -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 diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 77a3fe1b5..b0c20cfff 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -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)))) |