281 lines
12 KiB
Scheme
281 lines
12 KiB
Scheme
(module cm mzscheme
|
|
(require (lib "moddep.ss" "syntax")
|
|
(lib "plthome.ss" "setup")
|
|
(lib "file.ss"))
|
|
|
|
(provide make-compilation-manager-load/use-compiled-handler
|
|
managed-compile-zo
|
|
make-caching-managed-compile-zo
|
|
trust-existing-zos
|
|
manager-compile-notify-handler
|
|
(rename 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))
|
|
|
|
(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 fs-imports ft-imports) (module-compiled-imports code)])
|
|
(map path->bytes
|
|
(map (lambda (x)
|
|
(resolve-module-path-index x path))
|
|
;; Filter symbols:
|
|
(let loop ([l (append imports fs-imports ft-imports)])
|
|
(cond
|
|
[(null? l) null]
|
|
[(symbol? (car l)) (loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))]))))))
|
|
|
|
(define (get-compilation-dir+name mode path)
|
|
(let-values (((base name-suffix must-be-dir?) (split-path path)))
|
|
(let ((name (path-replace-suffix name-suffix #"")))
|
|
(values
|
|
(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)])
|
|
(path->bytes (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 (write-deps code mode path external-deps)
|
|
(let ((dep-path (bytes->path
|
|
(bytes-append (get-compilation-path mode path) #".dep")))
|
|
(deps (get-deps code path)))
|
|
(let ((op (open-output-file dep-path 'replace)))
|
|
(write (cons (version)
|
|
(append (map plthome-ify deps)
|
|
(map (lambda (x) (plthome-ify (cons 'ext x)))
|
|
external-deps)))
|
|
op)
|
|
(newline op)
|
|
(close-output-port op))))
|
|
|
|
(define (touch path)
|
|
(close-output-port (open-output-file path 'append)))
|
|
|
|
(define (compilation-failure mode path zo-name date-path reason)
|
|
(with-handlers ((exn:fail:filesystem? void))
|
|
(delete-file zo-name))
|
|
(let ([fail-path (bytes->path
|
|
(bytes-append (get-compilation-path mode path) #".fail"))])
|
|
(let ([p (open-output-file fail-path 'truncate/replace)])
|
|
(display reason p)
|
|
(close-output-port p)))
|
|
(trace-printf "failure"))
|
|
|
|
(define (compile-zo mode path)
|
|
((manager-compile-notify-handler) path)
|
|
(trace-printf "compiling: ~a" path)
|
|
(parameterize ([indent (string-append " " (indent))])
|
|
(let ([zo-name (bytes->path (bytes-append (get-compilation-path mode path) #".zo"))])
|
|
(cond
|
|
[(and (file-exists? zo-name) (trust-existing-zos)) (touch zo-name)]
|
|
[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)))])
|
|
(let* ([param
|
|
;; Avoid using cm while loading cm-ctime:
|
|
(parameterize ([use-compiled-file-paths null])
|
|
(dynamic-require '(lib "cm-ctime.ss" "mzlib" "private")
|
|
'current-external-file-registrar))]
|
|
[external-deps null]
|
|
[code (parameterize ([param (lambda (ext-file)
|
|
(set! external-deps
|
|
(cons (path->bytes ext-file)
|
|
external-deps)))])
|
|
(get-module-code path mode))]
|
|
[code-dir (get-code-dir mode path)])
|
|
(if (not (directory-exists? code-dir))
|
|
(make-directory* code-dir))
|
|
(let ((out (open-output-file zo-name 'replace)))
|
|
(with-handlers ((exn:fail?
|
|
(lambda (ex) (compilation-failure mode path zo-name #f (exn-message ex)))))
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (write code out))
|
|
(lambda () (close-output-port out)))))
|
|
(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))
|
|
|
|
(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-replace-suffix f (case (system-type)
|
|
[(windows) #".dll"]
|
|
[else #".so"])))
|
|
|
|
(define _loader-path (append-object-suffix (bytes->path #"_loader")))
|
|
|
|
(define (get-compiled-time mode path w/fail?)
|
|
(let*-values ([(dir name) (get-compilation-dir+name mode path)])
|
|
(first-date
|
|
(lambda () (build-path dir "native" (system-library-subpath) _loader-path))
|
|
(lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix name)))
|
|
(lambda () (build-path dir (path-replace-suffix name #".zo")))
|
|
(and w/fail? (lambda () (build-path dir (path-replace-suffix name #".fail")))))))
|
|
|
|
(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)
|
|
(let ([path (simplify-path (expand-path path))])
|
|
(let ((stamp (and up-to-date
|
|
(hash-table-get up-to-date path (lambda () #f)))))
|
|
(cond
|
|
(stamp stamp)
|
|
(else
|
|
(trace-printf "checking: ~a" path)
|
|
(let ((path-zo-time (get-compiled-time mode path #f))
|
|
(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))
|
|
(else
|
|
(let ((deps (with-handlers ((exn:fail:filesystem? (lambda (ex) (list (version)))))
|
|
(call-with-input-file (bytes->path
|
|
(bytes-append (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))
|
|
((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)]
|
|
[(path? d) (compile-root mode d up-to-date)]
|
|
[(and (pair? d) (eq? (car d) 'ext))
|
|
(with-handlers ((exn:fail:filesystem?
|
|
(lambda (ex) +inf.0)))
|
|
(file-or-directory-modify-seconds (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 un-plthome-ify (cdr deps)))
|
|
(compile-zo mode path))))))
|
|
(let ((stamp (get-compiled-time mode path #t)))
|
|
(hash-table-put! up-to-date path stamp)
|
|
stamp)))))))))
|
|
|
|
(define (managed-compile-zo zo)
|
|
((make-caching-managed-compile-zo) zo))
|
|
|
|
(define (make-caching-managed-compile-zo)
|
|
(let ([cache (make-hash-table 'equal)])
|
|
(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)))))
|
|
|
|
(define (make-compilation-manager-load/use-compiled-handler)
|
|
(make-compilation-manager-load/use-compiled-handler/table (make-hash-table 'equal)))
|
|
|
|
(define (make-compilation-manager-load/use-compiled-handler/table cache)
|
|
(let ([orig-eval (current-eval)]
|
|
[orig-load (current-load)]
|
|
[orig-namespace (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-namespace (current-namespace)))
|
|
(trace-printf "skipping: ~a orig-namespace ~s current-namespace ~s"
|
|
path
|
|
orig-namespace
|
|
(current-namespace))
|
|
(default-handler path mod-name)]
|
|
[else
|
|
(trace-printf "processing: ~a" path)
|
|
(compile-root (car modes) path cache)
|
|
(trace-printf "done: ~a" path)
|
|
(default-handler path mod-name)]))])
|
|
compilation-manager-load-handler))))
|