improved cm
svn: r11301 original commit: dd870c3d3020d7711371eafa7f6bb9c37b6f7fc9
This commit is contained in:
Eli Barzilay
parent
4aa143396b
commit
fe4b75e598
|
|
@ -1,338 +1,290 @@
|
|||
(module cm scheme/base
|
||||
(require syntax/modcode
|
||||
syntax/modresolve
|
||||
setup/main-collects
|
||||
scheme/file
|
||||
scheme/list)
|
||||
#lang scheme/base
|
||||
(require syntax/modcode
|
||||
syntax/modresolve
|
||||
setup/main-collects
|
||||
scheme/file
|
||||
scheme/list)
|
||||
|
||||
(provide make-compilation-manager-load/use-compiled-handler
|
||||
managed-compile-zo
|
||||
make-caching-managed-compile-zo
|
||||
trust-existing-zos
|
||||
manager-compile-notify-handler
|
||||
(rename-out [trace manager-trace-handler]))
|
||||
|
||||
(define manager-compile-notify-handler (make-parameter void))
|
||||
(define trace (make-parameter void))
|
||||
(define indent (make-parameter ""))
|
||||
(define trust-existing-zos (make-parameter #f))
|
||||
(provide make-compilation-manager-load/use-compiled-handler
|
||||
managed-compile-zo
|
||||
make-caching-managed-compile-zo
|
||||
trust-existing-zos
|
||||
manager-compile-notify-handler
|
||||
(rename-out [trace manager-trace-handler]))
|
||||
|
||||
(define (trace-printf fmt . args)
|
||||
((trace) (string-append (indent) (apply format fmt args))))
|
||||
|
||||
(define my-max
|
||||
(case-lambda
|
||||
(() 0)
|
||||
(x (apply max x))))
|
||||
|
||||
(define (get-deps code path)
|
||||
(let-values ([(imports) (apply append (map cdr (module-compiled-imports code)))])
|
||||
(map path->bytes
|
||||
(let ([l (map (lambda (x)
|
||||
(resolve-module-path-index x path))
|
||||
imports)])
|
||||
;; Filter symbols:
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(symbol? (car l)) (loop (cdr l))]
|
||||
[else (cons (car l) (loop (cdr l)))]))))))
|
||||
(define manager-compile-notify-handler (make-parameter void))
|
||||
(define trace (make-parameter void))
|
||||
(define indent (make-parameter ""))
|
||||
(define trust-existing-zos (make-parameter #f))
|
||||
|
||||
(define (get-compilation-dir+name mode path)
|
||||
(let-values (((base name must-be-dir?) (split-path path)))
|
||||
(values
|
||||
(define (trace-printf fmt . args)
|
||||
(let ([t (trace)])
|
||||
(unless (eq? t void)
|
||||
(t (string-append (indent) (apply format fmt args))))))
|
||||
|
||||
(define (get-deps code path)
|
||||
(filter-map (lambda (x)
|
||||
(let ([r (resolve-module-path-index x path)])
|
||||
(and (path? x) (path->bytes x))))
|
||||
(append-map cdr (module-compiled-imports code))))
|
||||
|
||||
(define (get-compilation-dir+name mode path)
|
||||
(let-values ([(base name must-be-dir?) (split-path path)])
|
||||
(values (if (eq? 'relative base) mode (build-path base mode))
|
||||
name)))
|
||||
|
||||
(define (get-compilation-path mode path)
|
||||
(let-values ([(dir name) (get-compilation-dir+name mode path)])
|
||||
(build-path dir name)))
|
||||
|
||||
(define (get-compilation-dir mode path)
|
||||
(let-values ([(base name-suffix must-be-dir?) (split-path path)])
|
||||
(if (eq? 'relative base) mode (build-path base mode))))
|
||||
|
||||
(define (touch path)
|
||||
(close-output-port (open-output-file path #:exists 'append)))
|
||||
|
||||
(define (try-file-time path)
|
||||
;; might be better to use a `with-handlers'
|
||||
(and (file-exists? path) (file-or-directory-modify-seconds path)))
|
||||
|
||||
(define (try-delete-file path)
|
||||
;; Attempt to delete, but give up if it doesn't work:
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
(trace-printf "deleting: ~a" path)
|
||||
(delete-file path)))
|
||||
|
||||
(define (compilation-failure mode path zo-name date-path reason)
|
||||
(try-delete-file zo-name)
|
||||
(trace-printf "failure"))
|
||||
|
||||
;; with-compile-output : path (output-port -> alpha) -> alpha
|
||||
;; Open path for writing, and arranges to delete path if there's
|
||||
;; an exception. Breaks are managed so that the port is reliably
|
||||
;; closed and the file is reliably deleted if there's a break
|
||||
(define (with-compile-output path proc)
|
||||
(let ([bp (current-break-parameterization)])
|
||||
(with-handlers ([void (lambda (exn) (try-delete-file path) (raise exn))])
|
||||
(let ([out (open-output-file path #:exists 'truncate/replace)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(call-with-break-parameterization bp (lambda () (proc out))))
|
||||
(lambda ()
|
||||
(close-output-port out)))))))
|
||||
|
||||
(define (write-deps code mode path external-deps)
|
||||
(let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")]
|
||||
[deps (remove-duplicates (get-deps code path))]
|
||||
[external-deps (remove-duplicates external-deps)])
|
||||
(with-compile-output dep-path
|
||||
(lambda (op)
|
||||
(write `(,(version)
|
||||
,@(map path->main-collects-relative deps)
|
||||
,@(map (lambda (x)
|
||||
(cons 'ext (path->main-collects-relative x)))
|
||||
external-deps))
|
||||
op)
|
||||
(newline op)))))
|
||||
|
||||
(define (format-time sec)
|
||||
(let ([d (seconds->date sec)])
|
||||
(format "~a-~a-~a ~a:~a:~a"
|
||||
(date-year d) (date-month d) (date-day d)
|
||||
(date-hour d) (date-minute d) (date-second d))))
|
||||
|
||||
(define (verify-times ss-name zo-name)
|
||||
(define ss-sec (try-file-time ss-name)) ; should exist
|
||||
(define zo-sec (try-file-time zo-name))
|
||||
(cond [(not ss-sec) (error 'compile-zo "internal error")]
|
||||
[(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a"
|
||||
zo-name ss-name)]
|
||||
[(< zo-sec ss-sec) (error 'compile-zo
|
||||
"date for newly created .zo file (~a @ ~a) ~
|
||||
is before source-file date (~a @ ~a)~a"
|
||||
zo-name
|
||||
(format-time (seconds->date zo-sec))
|
||||
ss-name
|
||||
(format-time (seconds->date ss-sec))
|
||||
(if (> ss-sec (current-seconds))
|
||||
", which appears to be in the future"
|
||||
""))]))
|
||||
|
||||
(define (compile-zo* mode path read-src-syntax zo-name)
|
||||
(define param
|
||||
;; Avoid using cm while loading cm-ctime:
|
||||
(parameterize ([use-compiled-file-paths null])
|
||||
(dynamic-require 'mzlib/private/cm-ctime
|
||||
'current-external-file-registrar)))
|
||||
(define external-deps null)
|
||||
(define (external-dep! p)
|
||||
(set! external-deps (cons (path->bytes p) external-deps)))
|
||||
(define code
|
||||
(parameterize ([param external-dep!]
|
||||
[current-reader-guard
|
||||
(let ([rg (current-reader-guard)])
|
||||
(lambda (d)
|
||||
(let ([d (rg d)])
|
||||
(when (module-path? d)
|
||||
(let ([p (resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(module-path-index-join d #f)))])
|
||||
(when (path? p) (external-dep! p))))
|
||||
d)))])
|
||||
(get-module-code path mode compile
|
||||
(lambda (a b) #f) ; extension handler
|
||||
#:source-reader read-src-syntax)))
|
||||
(define code-dir (get-compilation-dir mode path))
|
||||
(when code
|
||||
(make-directory* code-dir)
|
||||
(with-compile-output zo-name
|
||||
(lambda (out)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (ex)
|
||||
(close-output-port out)
|
||||
(compilation-failure mode path zo-name #f
|
||||
(exn-message ex))
|
||||
(raise ex))])
|
||||
(parameterize ([current-write-relative-directory
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(if (eq? base 'relative)
|
||||
(current-directory)
|
||||
(path->complete-path base (current-directory))))])
|
||||
(write code out)))
|
||||
;; redundant, but close as early as possible:
|
||||
(close-output-port out)
|
||||
;; Note that we check time and write .deps before returning from
|
||||
;; with-compile-output...
|
||||
(verify-times path zo-name)
|
||||
(write-deps code mode path external-deps)))))
|
||||
|
||||
(define (compile-zo mode path read-src-syntax)
|
||||
((manager-compile-notify-handler) path)
|
||||
(trace-printf "compiling: ~a" path)
|
||||
(parameterize ([indent (string-append " " (indent))])
|
||||
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
|
||||
[zo-exists? (file-exists? zo-name)])
|
||||
(if (and zo-exists? (trust-existing-zos))
|
||||
(touch zo-name)
|
||||
(begin (when zo-exists? (delete-file zo-name))
|
||||
(with-handlers
|
||||
([exn:get-module-code?
|
||||
(lambda (ex)
|
||||
(compilation-failure mode path zo-name
|
||||
(exn:get-module-code-path ex)
|
||||
(exn-message ex))
|
||||
(raise ex))])
|
||||
(compile-zo* mode path read-src-syntax zo-name))))))
|
||||
(trace-printf "end compile: ~a" path))
|
||||
|
||||
(define (get-compiled-time mode path)
|
||||
(define-values (dir name) (get-compilation-dir+name mode path))
|
||||
(or (try-file-time (build-path dir "native" (system-library-subpath)
|
||||
(path-add-suffix name (system-type
|
||||
'so-suffix))))
|
||||
(try-file-time (build-path dir (path-add-suffix name #".zo")))
|
||||
-inf.0))
|
||||
|
||||
(define (compile-root mode path0 up-to-date read-src-syntax)
|
||||
(define path (simplify-path (cleanse-path path0)))
|
||||
(define (read-deps)
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version)))])
|
||||
(call-with-input-file
|
||||
(path-add-suffix (get-compilation-path mode path) #".dep")
|
||||
read)))
|
||||
(define (do-check)
|
||||
(define path-zo-time (get-compiled-time mode path))
|
||||
(define path-time (try-file-time path))
|
||||
(cond
|
||||
[(not path-time)
|
||||
(trace-printf "~a does not exist" path)
|
||||
path-zo-time]
|
||||
[else
|
||||
(cond
|
||||
((eq? 'relative base) mode)
|
||||
(else (build-path base mode)))
|
||||
name)))
|
||||
|
||||
(define (get-compilation-path mode path)
|
||||
(let-values ([(dir name) (get-compilation-dir+name mode path)])
|
||||
(build-path dir name)))
|
||||
|
||||
(define (get-code-dir mode path)
|
||||
(let-values (((base name-suffix must-be-dir?) (split-path path)))
|
||||
(cond
|
||||
((eq? 'relative base) mode)
|
||||
(else (build-path base mode)))))
|
||||
|
||||
(define (try-delete-file path)
|
||||
;; Attempt to delete, but give up if it
|
||||
;; doesn't work:
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
(trace-printf "deleting: ~a" path)
|
||||
(delete-file path)))
|
||||
|
||||
;; with-compile-output : path (output-port -> alpha) -> alpha
|
||||
;; Open path for writing, and arranges to delete path if there's
|
||||
;; an exception. Breaks are managed so that the port is reliably
|
||||
;; closed and the file is reliably deleted if there's a break
|
||||
(define (with-compile-output path proc)
|
||||
(let ([bp (current-break-parameterization)])
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(try-delete-file path)
|
||||
(raise exn))])
|
||||
(let ([out (open-output-file path #:exists 'truncate/replace)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(call-with-break-parameterization
|
||||
bp
|
||||
(lambda ()
|
||||
(proc out))))
|
||||
(lambda ()
|
||||
(close-output-port out)))))))
|
||||
|
||||
(define (write-deps code mode path external-deps)
|
||||
(let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")]
|
||||
[deps (remove-duplicates (get-deps code path))]
|
||||
[external-deps (remove-duplicates external-deps)])
|
||||
(with-compile-output
|
||||
dep-path
|
||||
(lambda (op)
|
||||
(write (cons (version)
|
||||
(append (map path->main-collects-relative deps)
|
||||
(map (lambda (x) (cons 'ext (path->main-collects-relative x)))
|
||||
external-deps)))
|
||||
op)
|
||||
(newline op)))))
|
||||
|
||||
(define (touch path)
|
||||
(close-output-port (open-output-file path #:exists 'append)))
|
||||
|
||||
(define (compilation-failure mode path zo-name date-path reason)
|
||||
(with-handlers ((exn:fail:filesystem? void))
|
||||
(delete-file zo-name))
|
||||
(trace-printf "failure"))
|
||||
|
||||
(define (compile-zo mode path read-src-syntax)
|
||||
((manager-compile-notify-handler) path)
|
||||
(trace-printf "compiling: ~a" path)
|
||||
(parameterize ([indent (string-append " " (indent))])
|
||||
(let ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")])
|
||||
(cond
|
||||
[(and (file-exists? zo-name) (trust-existing-zos)) (touch zo-name)]
|
||||
[(> path-time path-zo-time)
|
||||
(trace-printf "newer src...")
|
||||
(compile-zo mode path read-src-syntax)]
|
||||
[else
|
||||
(when (file-exists? zo-name) (delete-file zo-name))
|
||||
(with-handlers ([exn:get-module-code?
|
||||
(lambda (ex)
|
||||
(compilation-failure
|
||||
mode path zo-name (exn:get-module-code-path ex)
|
||||
(exn-message ex))
|
||||
(raise ex))])
|
||||
(let* ([param
|
||||
;; Avoid using cm while loading cm-ctime:
|
||||
(parameterize ([use-compiled-file-paths null])
|
||||
(dynamic-require 'mzlib/private/cm-ctime
|
||||
'current-external-file-registrar))]
|
||||
[external-deps null]
|
||||
[code (parameterize ([param (lambda (ext-file)
|
||||
(set! external-deps
|
||||
(cons (path->bytes ext-file)
|
||||
external-deps)))]
|
||||
[current-reader-guard
|
||||
(let ([rg (current-reader-guard)])
|
||||
(lambda (d)
|
||||
(let ([d (rg d)])
|
||||
(when (module-path? d)
|
||||
(let ([p (resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(module-path-index-join d #f)))])
|
||||
(when (path? p)
|
||||
(set! external-deps
|
||||
(cons (path->bytes p)
|
||||
external-deps)))))
|
||||
d)))])
|
||||
(get-module-code path mode
|
||||
compile
|
||||
(lambda (a b) #f) ; extension handler
|
||||
#:source-reader read-src-syntax))]
|
||||
[code-dir (get-code-dir mode path)])
|
||||
(when code
|
||||
(when (not (directory-exists? code-dir))
|
||||
(make-directory* code-dir))
|
||||
(with-compile-output
|
||||
zo-name
|
||||
(lambda (out)
|
||||
(with-handlers ((exn:fail?
|
||||
(lambda (ex)
|
||||
(close-output-port out)
|
||||
(compilation-failure mode path zo-name #f (exn-message ex))
|
||||
(raise ex))))
|
||||
(parameterize ([current-write-relative-directory
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(if (eq? base 'relative)
|
||||
(current-directory)
|
||||
(path->complete-path base (current-directory))))])
|
||||
(write code out)))
|
||||
;; redundant, but close as early as possible:
|
||||
(close-output-port out)
|
||||
;; Note that we check time and write .deps before returning from with-compile-output...
|
||||
(let ([ss-sec (file-or-directory-modify-seconds path)]
|
||||
[zo-sec (if (file-exists? zo-name)
|
||||
(file-or-directory-modify-seconds zo-name)
|
||||
+inf.0)])
|
||||
(when (< zo-sec ss-sec)
|
||||
(error 'compile-zo
|
||||
"date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a"
|
||||
zo-name
|
||||
(format-date (seconds->date zo-sec))
|
||||
path
|
||||
(format-date (seconds->date ss-sec))
|
||||
(if (> ss-sec (current-seconds))
|
||||
", which appears to be in the future"
|
||||
""))))
|
||||
(write-deps code mode path external-deps))))))])))
|
||||
(trace-printf "end compile: ~a" path))
|
||||
(let ([deps (read-deps)])
|
||||
(cond
|
||||
[(not (and (pair? deps) (equal? (version) (car deps))))
|
||||
(trace-printf "newer version...")
|
||||
(compile-zo mode path read-src-syntax)]
|
||||
[(ormap
|
||||
(lambda (p)
|
||||
;; (cons 'ext rel-path) => a non-module file (check date)
|
||||
;; rel-path => a module file name (check transitive dates)
|
||||
(define ext? (and (pair? p) (eq? 'ext (car p))))
|
||||
(define d (main-collects-relative->path (if ext? (cdr p) p)))
|
||||
(define t
|
||||
(cond [(not (path? d)) #f] ;; (can this happen?)
|
||||
[ext? (try-file-time d)]
|
||||
[else (compile-root mode d up-to-date
|
||||
read-src-syntax)]))
|
||||
(and t (> t path-zo-time)
|
||||
(begin (trace-printf "newer: ~a (~a > ~a)..."
|
||||
d t path-zo-time)
|
||||
#t)))
|
||||
(cdr deps))
|
||||
(compile-zo mode path read-src-syntax)]))])
|
||||
(let ([stamp (get-compiled-time mode path)])
|
||||
(hash-set! up-to-date path stamp)
|
||||
stamp)]))
|
||||
(or (and up-to-date (hash-ref up-to-date path #f))
|
||||
(begin (trace-printf "checking: ~a" path)
|
||||
(do-check))))
|
||||
|
||||
(define (format-date date)
|
||||
(format "~a:~a:~a:~a:~a:~a"
|
||||
(date-year date)
|
||||
(date-month date)
|
||||
(date-day date)
|
||||
(date-hour date)
|
||||
(date-minute date)
|
||||
(date-second date)))
|
||||
|
||||
(define (append-object-suffix f)
|
||||
(path-add-suffix f (system-type 'so-suffix)))
|
||||
(define (managed-compile-zo zo [read-src-syntax read-syntax])
|
||||
((make-caching-managed-compile-zo read-src-syntax) zo))
|
||||
|
||||
(define (get-compiled-time mode path)
|
||||
(let*-values ([(dir name) (get-compilation-dir+name mode path)])
|
||||
(first-date
|
||||
(lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix name)))
|
||||
(lambda () (build-path dir (path-add-suffix name #".zo"))))))
|
||||
(define (make-caching-managed-compile-zo [read-src-syntax read-syntax])
|
||||
(let ([cache (make-hash)])
|
||||
(lambda (zo)
|
||||
(parameterize ([current-load/use-compiled
|
||||
(make-compilation-manager-load/use-compiled-handler/table
|
||||
cache)])
|
||||
(compile-root (car (use-compiled-file-paths))
|
||||
(path->complete-path zo)
|
||||
cache read-src-syntax)
|
||||
(void)))))
|
||||
|
||||
(define first-date
|
||||
(case-lambda
|
||||
[() -inf.0]
|
||||
[(f . l)
|
||||
(if f
|
||||
(with-handlers ([exn:fail:filesystem?
|
||||
(lambda (ex)
|
||||
(apply first-date l))])
|
||||
(let ([name (f)])
|
||||
(file-or-directory-modify-seconds name)))
|
||||
(apply first-date l))]))
|
||||
|
||||
(define (compile-root mode path up-to-date read-src-syntax)
|
||||
(let ([path (simplify-path (cleanse-path path))])
|
||||
(let ((stamp (and up-to-date
|
||||
(hash-ref up-to-date path #f))))
|
||||
(cond
|
||||
(stamp stamp)
|
||||
(else
|
||||
(trace-printf "checking: ~a" path)
|
||||
(let ((path-zo-time (get-compiled-time mode path))
|
||||
(path-time
|
||||
(with-handlers ((exn:fail:filesystem?
|
||||
(lambda (ex)
|
||||
(trace-printf "~a does not exist" path)
|
||||
#f)))
|
||||
(file-or-directory-modify-seconds path))))
|
||||
(cond
|
||||
((not path-time) path-zo-time)
|
||||
(else
|
||||
(cond
|
||||
((> path-time path-zo-time)
|
||||
(trace-printf "newer src...")
|
||||
(compile-zo mode path read-src-syntax))
|
||||
(else
|
||||
(let ((deps (with-handlers ((exn:fail:filesystem? (lambda (ex) (list (version)))))
|
||||
(call-with-input-file (path-add-suffix (get-compilation-path mode path) #".dep")
|
||||
read))))
|
||||
(cond
|
||||
((or (not (pair? deps))
|
||||
(not (equal? (version) (car deps))))
|
||||
(trace-printf "newer version...")
|
||||
(compile-zo mode path read-src-syntax))
|
||||
((ormap (lambda (d)
|
||||
;; str => str is a module file name (check transitive dates)
|
||||
;; (cons 'ext str) => str is an non-module file (check date)
|
||||
(let ([t (cond
|
||||
[(bytes? d) (compile-root mode (bytes->path d) up-to-date read-src-syntax)]
|
||||
[(path? d) (compile-root mode d up-to-date read-src-syntax)]
|
||||
[(and (pair? d)
|
||||
(eq? (car d) 'ext)
|
||||
(or (bytes? (cdr d))
|
||||
(path? (cdr d))))
|
||||
(with-handlers ((exn:fail:filesystem?
|
||||
(lambda (ex) +inf.0)))
|
||||
(file-or-directory-modify-seconds (if (bytes? (cdr d))
|
||||
(bytes->path (cdr d))
|
||||
(cdr d))))]
|
||||
[else +inf.0])])
|
||||
(when (> t path-zo-time)
|
||||
(trace-printf "newer: ~a (~a > ~a)..." d t path-zo-time))
|
||||
(> t path-zo-time)))
|
||||
(map (lambda (p)
|
||||
(if (and (pair? p)
|
||||
(eq? 'ext (car p)))
|
||||
(cons 'ext (main-collects-relative->path (cdr p)))
|
||||
(main-collects-relative->path p)))
|
||||
(cdr deps)))
|
||||
(compile-zo mode path read-src-syntax))))))
|
||||
(let ((stamp (get-compiled-time mode path)))
|
||||
(hash-set! up-to-date path stamp)
|
||||
stamp)))))))))
|
||||
|
||||
(define (managed-compile-zo zo [read-src-syntax read-syntax])
|
||||
((make-caching-managed-compile-zo read-src-syntax) zo))
|
||||
|
||||
(define (make-caching-managed-compile-zo [read-src-syntax read-syntax])
|
||||
(let ([cache (make-hash)])
|
||||
(lambda (zo)
|
||||
(parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler/table cache)])
|
||||
(compile-root (car (use-compiled-file-paths)) (path->complete-path zo) cache read-src-syntax)
|
||||
(void)))))
|
||||
(define (make-compilation-manager-load/use-compiled-handler)
|
||||
(make-compilation-manager-load/use-compiled-handler/table (make-hash)))
|
||||
|
||||
(define (make-compilation-manager-load/use-compiled-handler)
|
||||
(make-compilation-manager-load/use-compiled-handler/table (make-hash)))
|
||||
|
||||
(define (make-compilation-manager-load/use-compiled-handler/table cache)
|
||||
(let ([orig-eval (current-eval)]
|
||||
[orig-load (current-load)]
|
||||
[orig-registry (namespace-module-registry (current-namespace))]
|
||||
[default-handler (current-load/use-compiled)]
|
||||
[modes (use-compiled-file-paths)])
|
||||
(when (null? modes)
|
||||
(raise-mismatch-error 'make-compilation-manager-...
|
||||
"empty use-compiled-file-paths list: "
|
||||
modes))
|
||||
(letrec ([compilation-manager-load-handler
|
||||
(lambda (path mod-name)
|
||||
(cond
|
||||
[(not mod-name)
|
||||
(trace-printf "skipping: ~a mod-name ~s" path mod-name)
|
||||
(default-handler path mod-name)]
|
||||
[(not (member (car modes) (use-compiled-file-paths)))
|
||||
(trace-printf "skipping: ~a compiled-paths ~s" path (use-compiled-file-paths))
|
||||
(default-handler path mod-name)]
|
||||
[(not (eq? compilation-manager-load-handler (current-load/use-compiled)))
|
||||
(trace-printf "skipping: ~a current-load/use-compiled changed ~s"
|
||||
path
|
||||
(current-load/use-compiled))
|
||||
(default-handler path mod-name)]
|
||||
[(not (eq? orig-eval (current-eval)))
|
||||
(trace-printf "skipping: ~a orig-eval ~s current-eval ~s"
|
||||
path orig-eval
|
||||
(current-eval))
|
||||
(default-handler path mod-name)]
|
||||
[(not (eq? orig-load (current-load)))
|
||||
(trace-printf "skipping: ~a orig-load ~s current-load ~s"
|
||||
path
|
||||
orig-load
|
||||
(current-load))
|
||||
(default-handler path mod-name)]
|
||||
[(not (eq? orig-registry (namespace-module-registry (current-namespace))))
|
||||
(trace-printf "skipping: ~a orig-rgistry ~s current-registry ~s"
|
||||
path
|
||||
orig-registry
|
||||
(namespace-module-registry (current-namespace)))
|
||||
(default-handler path mod-name)]
|
||||
[else
|
||||
(trace-printf "processing: ~a" path)
|
||||
(compile-root (car modes) path cache read-syntax)
|
||||
(trace-printf "done: ~a" path)
|
||||
(default-handler path mod-name)]))])
|
||||
compilation-manager-load-handler))))
|
||||
(define (make-compilation-manager-load/use-compiled-handler/table cache)
|
||||
(let ([orig-eval (current-eval)]
|
||||
[orig-load (current-load)]
|
||||
[orig-registry (namespace-module-registry (current-namespace))]
|
||||
[default-handler (current-load/use-compiled)]
|
||||
[modes (use-compiled-file-paths)])
|
||||
(define (compilation-manager-load-handler path mod-name)
|
||||
(cond [(not mod-name)
|
||||
(trace-printf "skipping: ~a mod-name ~s" path mod-name)]
|
||||
[(not (member (car modes) (use-compiled-file-paths)))
|
||||
(trace-printf "skipping: ~a compiled-paths ~s"
|
||||
path (use-compiled-file-paths))]
|
||||
[(not (eq? compilation-manager-load-handler
|
||||
(current-load/use-compiled)))
|
||||
(trace-printf "skipping: ~a current-load/use-compiled changed ~s"
|
||||
path (current-load/use-compiled))]
|
||||
[(not (eq? orig-eval (current-eval)))
|
||||
(trace-printf "skipping: ~a orig-eval ~s current-eval ~s"
|
||||
path orig-eval (current-eval))]
|
||||
[(not (eq? orig-load (current-load)))
|
||||
(trace-printf "skipping: ~a orig-load ~s current-load ~s"
|
||||
path orig-load (current-load))]
|
||||
[(not (eq? orig-registry
|
||||
(namespace-module-registry (current-namespace))))
|
||||
(trace-printf "skipping: ~a orig-registry ~s current-registry ~s"
|
||||
path orig-registry
|
||||
(namespace-module-registry (current-namespace)))]
|
||||
[else
|
||||
(trace-printf "processing: ~a" path)
|
||||
(compile-root (car modes) path cache read-syntax)
|
||||
(trace-printf "done: ~a" path)])
|
||||
(default-handler path mod-name))
|
||||
(when (null? modes)
|
||||
(raise-mismatch-error 'make-compilation-manager-...
|
||||
"empty use-compiled-file-paths list: "
|
||||
modes))
|
||||
compilation-manager-load-handler))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user