diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f097a696b..edae9b8bc 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3569,6 +3569,10 @@ module '(ice-9 q) '(make-q q-length))}." duplicate-case-datum bad-case-datum))) (define* (load-in-vicinity dir path #:optional reader) + "Load source file PATH in vicinity of directory DIR. Use a pre-compiled +version of PATH when available, and auto-compile one when none is available, +reading PATH with READER." + (define (canonical->suffix canon) (cond ((string-prefix? "/" canon) canon) @@ -3578,6 +3582,49 @@ module '(ice-9 q) '(make-q q-length))}." (string-append "/" (substring canon 0 1) (substring canon 2))) (else canon))) + (define compiled-extension + ;; File name extension of compiled files. + (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 (more-recent? stat1 stat2) + ;; Return #t when STAT1 has an mtime greater than that of STAT2. + (or (> (stat:mtime stat1) (stat:mtime stat2)) + (and (= (stat:mtime stat1) (stat:mtime stat2)) + (>= (stat:mtimensec stat1) + (stat:mtimensec stat2))))) + + (define (fallback-file-name canon-path) + ;; Return the in-cache compiled file name for source file CANON-PATH. + + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. + (and %compile-fallback-path + (string-append %compile-fallback-path + (canonical->suffix canon-path) + compiled-extension))) + + (define (compile file) + ;; Compile source FILE, lazily loading the compiler. + ((module-ref (resolve-interface '(system base compile)) + 'compile-file) + file + #:opts %auto-compilation-options + #:env (current-module))) + + (define (warn-about-exception key args) + (for-each (lambda (s) + (if (not (string-null? s)) + (format (current-warning-port) ";;; ~a\n" s))) + (string-split + (call-with-output-string + (lambda (port) (print-exception port #f key args))) + #\newline))) + ;; 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 @@ -3587,32 +3634,16 @@ module '(ice-9 q) '(make-q q-length))}." ;; 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 (compiled-file-name canon-path) - ;; FIXME: would probably be better just to append SHA1(canon-path) - ;; to the %compile-fallback-path, to avoid deep directory stats. - (and %compile-fallback-path - (string-append - %compile-fallback-path - (canonical->suffix canon-path) - (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 (fresh-compiled-file-name name go-path) + ;; Return GO-PATH after making sure that it contains a freshly compiled + ;; version of source file NAME; return #f on failure. (catch #t (lambda () (let* ((scmstat (stat name)) (gostat (and (not %fresh-auto-compile) (stat go-path #f)))) - (if (and gostat - (or (> (stat:mtime gostat) (stat:mtime scmstat)) - (and (= (stat:mtime gostat) (stat:mtime scmstat)) - (>= (stat:mtimensec gostat) - (stat:mtimensec scmstat))))) + (if (and gostat (more-recent? gostat scmstat)) go-path (begin (if gostat @@ -3623,26 +3654,14 @@ module '(ice-9 q) '(make-q q-length))}." (%load-should-auto-compile (%warn-auto-compilation-enabled) (format (current-warning-port) ";;; compiling ~a\n" name) - (let ((cfn - ((module-ref - (resolve-interface '(system base compile)) - 'compile-file) - name - #:opts %auto-compilation-options - #:env (current-module)))) + (let ((cfn (compile name))) (format (current-warning-port) ";;; compiled ~a\n" cfn) cfn)) (else #f)))))) (lambda (k . args) (format (current-warning-port) ";;; WARNING: compilation of ~a failed:\n" name) - (for-each (lambda (s) - (if (not (string-null? s)) - (format (current-warning-port) ";;; ~a\n" s))) - (string-split - (call-with-output-string - (lambda (port) (print-exception port #f k args))) - #\newline)) + (warn-about-exception k args) #f))) (define (absolute-path? path) @@ -3651,7 +3670,7 @@ module '(ice-9 q) '(make-q q-length))}." (define (load-absolute abs-path) (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path)))) (and canon - (let ((go-path (compiled-file-name canon))) + (let ((go-path (fallback-file-name canon))) (and go-path (fresh-compiled-file-name abs-path go-path))))))) (if cfn @@ -3667,7 +3686,7 @@ module '(ice-9 q) '(make-q q-length))}." (with-fluids ((current-reader reader) (%file-port-name-canonicalization 'relative)) (cond - ((or (absolute-path? path)) + ((absolute-path? path) (load-absolute path)) ((absolute-path? dir) (load-absolute (in-vicinity dir path)))