suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor compile manager check-cache function

Browse Source
This commit is contained in:
Kevin Tew 2010-06-21 14:34:09 -06:00
parent ccac23d648
commit fe60da72c8
1 changed files with 105 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
collects/compiler/cm.rkt
View File

@ -21,6 +21,7 @@
get-file-sha1 get-file-sha1
get-compiled-file-sha1) get-compiled-file-sha1)
; Parameters
(define manager-compile-notify-handler (make-parameter void)) (define manager-compile-notify-handler (make-parameter void))
(define trace (make-parameter void)) (define trace (make-parameter void))
(define indent (make-parameter "")) (define indent (make-parameter ""))
@ -142,7 +143,7 @@
(define (compilation-failure mode path zo-name date-path reason) (define (compilation-failure mode path zo-name date-path reason)
(try-delete-file zo-name) (try-delete-file zo-name)
(trace-printf "failure")) (trace-printf "failure: compiling ~a to ~a" path zo-name))
;; with-compile-output : path (output-port -> alpha) -> alpha ;; with-compile-output : path (output-port -> alpha) -> alpha
;; Open a temporary path for writing, automatically renames after, ;; Open a temporary path for writing, automatically renames after,
@ -174,7 +175,7 @@
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(call-with-input-file* p sha1))) (call-with-input-file* p sha1)))
(define (get-dep-sha1s deps up-to-date read-src-syntax mode must-exist?) (define (get-dep-sha1s deps up-to-date mode must-exist?)
(let ([l (for/fold ([l null]) ([dep (in-list deps)]) (let ([l (for/fold ([l null]) ([dep (in-list deps)])
(and l (and l
;; (cons 'ext rel-path) => a non-module file, check source ;; (cons 'ext rel-path) => a non-module file, check source
@ -187,9 +188,7 @@
[v (cons (cons (delay v) dep) l)] [v (cons (cons (delay v) dep) l)]
[must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)]
[else #f]))] [else #f]))]
[(or (hash-ref up-to-date (simple-form-path p) #f) [(check-cache mode p up-to-date (lambda x #f))
;; Use `compiler-root' with `sha1-only?' as #t:
(compile-root mode p up-to-date read-src-syntax #t))
=> (lambda (sh) => (lambda (sh)
(cons (cons (cdr sh) dep) l))] (cons (cons (cdr sh) dep) l))]
[must-exist? [must-exist?
@ -219,7 +218,7 @@
external-deps))]) external-deps))])
(write (list* (version) (write (list* (version)
(cons (or src-sha1 (get-source-sha1 path)) (cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date read-src-syntax mode #t)) (get-dep-sha1s deps up-to-date mode #t))
deps) deps)
op) op)
(newline op)))))) (newline op))))))
@ -351,60 +350,6 @@
alt-path alt-path
path)))) path))))
(define (maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)
(let ([actual-path (actual-source-path orig-path)])
(unless sha1-only?
((manager-compile-notify-handler) actual-path)
(trace-printf "compiling: ~a" actual-path))
(begin0
(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))
(begin
(log-info (format "cm: ~atrusting ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
zo-name))
(touch zo-name)
#f)
(let ([src-sha1 (and zo-exists?
deps
(cadr deps)
(get-source-sha1 path))])
(if (and zo-exists?
src-sha1
(equal? src-sha1 (caadr deps))
(equal? (get-dep-sha1s (cddr deps) up-to-date read-src-syntax mode #f)
(cdadr deps)))
(begin
(log-info (format "cm: ~ahash-equivalent ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
zo-name))
(touch zo-name)
#f)
((if sha1-only? values (lambda (build) (build) #f))
(lambda ()
(when zo-exists? (delete-file zo-name))
(log-info (format "cm: ~acompiling ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
actual-path))
(parameterize ([depth (+ (depth) 1)])
(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 src-sha1 read-src-syntax zo-name up-to-date))))))))))
(unless sha1-only?
(trace-printf "end compile: ~a" actual-path)))))
(define (get-compiled-time mode path) (define (get-compiled-time mode path)
(define-values (dir name) (get-compilation-dir+name mode path)) (define-values (dir name) (get-compilation-dir+name mode path))
@ -438,14 +383,20 @@
(path-replace-suffix p #".ss") (path-replace-suffix p #".ss")
p))) p)))
(define (compile-root mode path0 up-to-date read-src-syntax sha1-only?) ;; needs->compile: mode -> raw-path -> up-to-date -> (deps -> path -> zo-name -> src-sha1 -> dep-info ) -> dep-info
(define orig-path (simple-form-path path0)) ;; dep-info: (list path-zo-time (delay compiled-sha1))
;; checks to see if a path is already compile if so it returs a dep-info
;; if compilation is needed it calls the compile-thunk passing deps -> path -> zo-name -> src-sha1 -> update-cache-with-zo-time
(define (check-cache mode raw-path up-to-date compile-thunk)
(define orig-path (simple-form-path raw-path))
(define (read-deps path) (define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))])
(call-with-input-file (call-with-input-file
(path-add-suffix (get-compilation-path mode path) #".dep") (path-add-suffix (get-compilation-path mode path) #".dep")
read))) read)))
(define (do-check) (define (cached?) (and up-to-date (hash-ref up-to-date orig-path #f)))
(define (update-cache value) (hash-set! up-to-date orig-path value))
(define (get-ss-rkt-resolved-path orig-path)
(let* ([main-path orig-path] (let* ([main-path orig-path]
[alt-path (rkt->ss orig-path)] [alt-path (rkt->ss orig-path)]
[main-path-time (try-file-time main-path)] [main-path-time (try-file-time main-path)]
@ -455,64 +406,94 @@
[path (if alt-path-time alt-path main-path)] [path (if alt-path-time alt-path main-path)]
[path-time (or main-path-time alt-path-time)] [path-time (or main-path-time alt-path-time)]
[path-zo-time (get-compiled-time mode path)]) [path-zo-time (get-compiled-time mode path)])
(cond (define (update-cache-with-zo-time)
[(not path-time) (let ([stamp (cons (get-compiled-time mode path) (delay (get-compiled-sha1 mode path)))])
(trace-printf "~a does not exist" orig-path) (hash-set! up-to-date main-path stamp)
(or (and up-to-date (hash-ref up-to-date orig-path #f)) (unless (eq? main-path alt-path)
(let ([stamp (cons path-zo-time (hash-set! up-to-date alt-path stamp))
(delay (get-compiled-sha1 mode path)))]) stamp))
(hash-set! up-to-date main-path stamp) (values path path-time path-zo-time update-cache-with-zo-time)))
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp)) (cond
stamp))] [(cached?) => (lambda (x) x)] ; already up to date, no need to compile
[else [((manager-skip-file-handler) orig-path) => (lambda (x) (update-cache x))]
(let ([deps (read-deps path)]) [else
(define build (let-values ([(path path-time path-zo-time update-cache-with-zo-time) (get-ss-rkt-resolved-path orig-path)])
(cond (define (path-does-not-exist) (not path-time))
[(not (and (pair? deps) (equal? (version) (car deps)))) (cond
(lambda () [(not path-time) ; path to compile does not exist
(trace-printf "newer version...") (trace-printf "~a does not exist" orig-path)
(maybe-compile-zo #f #f mode path orig-path read-src-syntax up-to-date))] (update-cache-with-zo-time)]
[(> path-time path-zo-time) [else
(trace-printf "newer src...") (let ([deps (read-deps path)])
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: (define (newer-version?) (not (and (pair? deps) (equal? (version) (car deps)))))
(maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)] (define (newer-src?) (> path-time path-zo-time))
[(ormap (define (out-of-date-dep dep)
(lambda (p) ;; (cons 'ext rel-path) => a non-module file (check date)
;; (cons 'ext rel-path) => a non-module file (check date) ;; rel-path => a module file name (check transitive dates)
;; rel-path => a module file name (check transitive dates) (define ext? (and (pair? dep) (eq? 'ext (car dep))))
(define ext? (and (pair? p) (eq? 'ext (car p)))) (define dep-path (main-collects-relative->path (if ext? (cdr dep) dep)))
(define d (main-collects-relative->path (if ext? (cdr p) p))) (define t
(define t (if ext?
(if ext? (cons (try-file-time dep-path) #f)
(cons (try-file-time d) #f) (check-cache mode dep-path up-to-date compile-thunk)))
(compile-root mode d up-to-date read-src-syntax #f))) (and t
(and (car t) (car t)
(> (car t) path-zo-time) (> (car t) path-zo-time)
(begin (trace-printf "newer: ~a (~a > ~a)..." (begin
d (car t) path-zo-time) (trace-printf "newer: ~a (~a > ~a)..." dep-path (car t) path-zo-time)
#t))) #t)))
(cddr deps)) (define (check-sha1-equivalence deps)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: (let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
(maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)] [zo-exists? (file-exists? zo-name)])
[else #f])) (define (touch-update-cache msg)
(cond (define spacing (build-string (depth) (λ (x) (if (= 2 (modulo x 3)) #\| #\space))))
[(and build sha1-only?) #f] (log-info (format "cm: ~a~a ~a" spacing msg zo-name))
[else (touch zo-name)
(when build (build)) (update-cache-with-zo-time))
(let ([stamp (cons (get-compiled-time mode path) (define (zo-is-trusted?) (and zo-exists? (trust-existing-zos)))
(delay (get-compiled-sha1 mode path)))]) (define (get-valid-src-sha1) (and zo-exists? deps (cadr deps) (get-source-sha1 path)))
(hash-set! up-to-date main-path stamp) (define (sha1-equivalent? src-sha1)
(unless (eq? main-path alt-path) (and zo-exists?
(hash-set! up-to-date alt-path stamp)) src-sha1
stamp)]))]))) (equal? src-sha1 (caadr deps))
(or (and up-to-date (hash-ref up-to-date orig-path #f)) (equal? (get-dep-sha1s (cddr deps) up-to-date mode #f) (cdadr deps))))
(let ([v ((manager-skip-file-handler) orig-path)]) (if (zo-is-trusted?)
(and v (touch-update-cache "trusting-existing-zo")
(hash-set! up-to-date orig-path v) (let ([src-sha1 (get-valid-src-sha1)])
v)) (if (sha1-equivalent? src-sha1)
(begin (trace-printf "checking: ~a" orig-path) (touch-update-cache"hash-equivalent src and deps")
(do-check)))) (compile-thunk deps path zo-name src-sha1 update-cache-with-zo-time))))))
(cond
[(newer-version?)
(trace-printf "newer racket bytecode version...")
(check-sha1-equivalence #f)]
[(newer-src?)
(trace-printf "newer src...")
(check-sha1-equivalence deps)]
[(ormap out-of-date-dep (cddr deps))
(check-sha1-equivalence deps)]
[else (update-cache-with-zo-time)]))]))]))
(define (compile-root mode raw-path up-to-date read-src-syntax)
(let ([actual-path (actual-source-path (simple-form-path raw-path))])
(define (compile-it deps path zo-name src-sha1 update-cache-with-zo-time)
;(when zo-exists? (delete-file zo-name))
((manager-compile-notify-handler) actual-path)
(trace-printf "compiling: ~a" actual-path)
(parameterize ([depth (+ (depth) 1)]
[indent (string-append " " (indent))])
(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 src-sha1 read-src-syntax zo-name up-to-date)))
(trace-printf "end compile: ~a" actual-path)
(update-cache-with-zo-time))
(check-cache mode raw-path up-to-date compile-it)))
(define (managed-compile-zo zo [read-src-syntax read-syntax]) (define (managed-compile-zo zo [read-src-syntax read-syntax])
((make-caching-managed-compile-zo read-src-syntax) zo)) ((make-caching-managed-compile-zo read-src-syntax) zo))
@ -526,8 +507,7 @@
(compile-root (car (use-compiled-file-paths)) (compile-root (car (use-compiled-file-paths))
(path->complete-path src) (path->complete-path src)
cache cache
read-src-syntax read-src-syntax)
#f)
(void))))) (void)))))
(define (make-compilation-manager-load/use-compiled-handler) (define (make-compilation-manager-load/use-compiled-handler)
@ -571,7 +551,7 @@
(namespace-module-registry (current-namespace)))] (namespace-module-registry (current-namespace)))]
[else [else
(trace-printf "processing: ~a" path) (trace-printf "processing: ~a" path)
(compile-root (car modes) path cache read-syntax #f) (compile-root (car modes) path cache read-syntax)
(trace-printf "done: ~a" path)]) (trace-printf "done: ~a" path)])
(default-handler path mod-name)) (default-handler path mod-name))
(when (null? modes) (when (null? modes)