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

setup/cm: fix some dependency tracking on deleted files

Browse Source 
Based on a report and patch from Tobias Hammer.
This commit is contained in:
Matthew Flatt 2013-06-10 20:31:21 -07:00
parent 0f96a6634b
commit e23b0b85c0
2 changed files with 33 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/compiler/cm.rkt
View File

@ -609,8 +609,7 @@
(or (try-file-time (build-path dir "native" (system-library-subpath) (or (try-file-time (build-path dir "native" (system-library-subpath)
(path-add-suffix name (system-type (path-add-suffix name (system-type
'so-suffix)))) 'so-suffix))))
(try-file-time (build-path dir (path-add-suffix name #".zo"))) (try-file-time (build-path dir (path-add-suffix name #".zo")))))
-inf.0))
(define (try-file-sha1 path dep-path) (define (try-file-sha1 path dep-path)
(with-module-reading-parameterization (with-module-reading-parameterization
@ -666,7 +665,7 @@
[(not path-time) [(not path-time)
(trace-printf "~a does not exist" orig-path) (trace-printf "~a does not exist" orig-path)
(or (hash-ref up-to-date orig-path #f) (or (hash-ref up-to-date orig-path #f)
(let ([stamp (cons path-zo-time (let ([stamp (cons (or path-zo-time +inf.0)
(delay (get-compiled-sha1 mode roots path)))]) (delay (get-compiled-sha1 mode roots path)))])
(hash-set! up-to-date main-path stamp) (hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path) (unless (eq? main-path alt-path)
@ -681,7 +680,7 @@
(lambda () (lambda ()
(trace-printf "newer version...") (trace-printf "newer version...")
(maybe-compile-zo #f #f mode roots path orig-path read-src-syntax up-to-date new-seen))] (maybe-compile-zo #f #f mode roots path orig-path read-src-syntax up-to-date new-seen))]
[(> path-time path-zo-time) [(> path-time (or path-zo-time -inf.0))
(trace-printf "newer src...") (trace-printf "newer src...")
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date new-seen)] (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date new-seen)]
@ -693,11 +692,11 @@
(define d (collects-relative*->path (if ext? (cdr p) p))) (define d (collects-relative*->path (if ext? (cdr p) p)))
(define t (define t
(if ext? (if ext?
(cons (try-file-time d) #f) (cons (or (try-file-time d) +inf.0) #f)
(compile-root mode roots d up-to-date read-src-syntax #f new-seen))) (compile-root mode roots d up-to-date read-src-syntax #f new-seen)))
(and t (and t
(car t) (car t)
(> (car t) path-zo-time) (> (car t) (or path-zo-time -inf.0))
(begin (trace-printf "newer: ~a (~a > ~a)..." (begin (trace-printf "newer: ~a (~a > ~a)..."
d (car t) path-zo-time) d (car t) path-zo-time)
#t))) #t)))
@ -709,7 +708,7 @@
[(and build sha1-only?) #f] [(and build sha1-only?) #f]
[else [else
(when build (build)) (when build (build))
(let ([stamp (cons (get-compiled-time mode roots path) (let ([stamp (cons (or (get-compiled-time mode roots path) +inf.0)
(delay (get-compiled-sha1 mode roots path)))]) (delay (get-compiled-sha1 mode roots path)))])
(hash-set! up-to-date main-path stamp) (hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path) (unless (eq? main-path alt-path)

31
collects/tests/racket/cm.rktl
View File

@ -55,7 +55,8 @@
(printf "mangling .zo for ~a\n" f) (printf "mangling .zo for ~a\n" f)
(with-output-to-file d (with-output-to-file d
#:exists 'truncate #:exists 'truncate
(lambda () (display "#~bad")))))) (lambda () (display "#~bad")))
(file-or-directory-modify-seconds d ts))))
(caddr recomp)) (caddr recomp))
(for-each (lambda (f) (for-each (lambda (f)
(printf "re-making ~a\n" f) (printf "re-making ~a\n" f)
@ -88,16 +89,38 @@
("i.rkt" "(module i scheme/base)" #t) ("i.rkt" "(module i scheme/base)" #t)
("j.rkt" "(module j racket/base (module+ main (require \"b.rkt\")))" #t)) ("j.rkt" "(module j racket/base (module+ main (require \"b.rkt\")))" #t))
'([("a.rkt") ("a.rkt") ("a.rkt")] '([("a.rkt") ("a.rkt") ("a.rkt")]
[("b.rkt") ("a.rkt") ("a.rkt" "b.rkt" "j.rkt")] [("b.rkt") ("a.rkt" "j.rkt") ("a.rkt" "b.rkt" "j.rkt")]
[("b.rkt") ("b.rkt") ("b.rkt" "j.rkt")] [("b.rkt") ("b.rkt") ("b.rkt")]
[() ("j.rkt") ("j.rkt")]
[() ("a.rkt") ("a.rkt")]
[("c.sch") ("j.rkt") ("b.rkt" "j.rkt")]
[() ("a.rkt") ("a.rkt")] [() ("a.rkt") ("a.rkt")]
[("c.sch") ("a.rkt") ("a.rkt" "b.rkt" "j.rkt")]
[("f.rkt") ("a.rkt") ("a.rkt" "d.rkt" "f.rkt")] [("f.rkt") ("a.rkt") ("a.rkt" "d.rkt" "f.rkt")]
[("e.rkt") ("e.rkt") ("e.rkt")] [("e.rkt") ("e.rkt") ("e.rkt")]
[() ("a.rkt") ("a.rkt" "d.rkt")] [() ("a.rkt") ("a.rkt" "d.rkt")]
[("i.rkt") ("a.rkt") ("a.rkt" "g.rkt" "i.rkt")] [("i.rkt") ("a.rkt") ("a.rkt" "g.rkt" "i.rkt")]
[("h.sch") ("a.rkt") ("a.rkt" "g.rkt")])) [("h.sch") ("a.rkt") ("a.rkt" "g.rkt")]))
;; test that deleting a relevant file makes compilation fail:
(define (try-remove rmv chk)
(printf "breaking ~a\n" rmv)
(delete-file (build-path dir rmv))
(for ([sfx '(#".zo" #".dep")])
(let ([f (build-path dir "compiled" (path-add-suffix rmv sfx))])
(when (file-exists? f)
(delete-file f))))
(test 'correctly-failed
'try-compile
(parameterize ([current-namespace (make-base-namespace)])
(with-handlers ([(lambda (exn)
(or (exn:missing-module? exn)
(exn:fail:syntax? exn)))
(lambda (exn) 'correctly-failed)])
(managed-compile-zo (build-path dir chk))))))
(try-remove "e.rkt" "d.rkt")
(try-remove "d.rkt" "a.rkt")
(try-remove "c.sch" "b.rkt")
;; test manager-skip-file-handler ;; test manager-skip-file-handler
(parameterize ([manager-skip-file-handler (parameterize ([manager-skip-file-handler
(λ (x) (λ (x)