From 06ffb74d66c62d77f76b801dc8ca7831887136ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Nov 2012 08:56:20 -0700 Subject: [PATCH] compiler/cm-accomplice: add `register-external-module' The new function allows declaration of a module dependency, as opposed to a mere file dependency. Misuse of this function opens the door to cyclic compilation dependencies, so we have to check for that in `compiler/cm'. --- collects/compiler/cm-accomplice.rkt | 13 ++++-- collects/compiler/cm.rkt | 59 ++++++++++++++++++---------- collects/scribblings/raco/make.scrbl | 14 ++++++- 3 files changed, 61 insertions(+), 25 deletions(-) diff --git a/collects/compiler/cm-accomplice.rkt b/collects/compiler/cm-accomplice.rkt index e8474f9879..a3a62c9e85 100644 --- a/collects/compiler/cm-accomplice.rkt +++ b/collects/compiler/cm-accomplice.rkt @@ -1,10 +1,17 @@ #lang racket/base -(provide register-external-file) +(provide register-external-file + register-external-module) + (define (register-external-file f) + (register-external 'register-external-file f #f)) +(define (register-external-module f) + (register-external 'register-external-module f #t)) + +(define (register-external who f module?) (unless (and (path? f) (complete-path? f)) - (raise-type-error 'register-external-file "complete path" f)) + (raise-type-error who "complete path" f)) (log-message (current-logger) 'info (format "file dependency: ~s" f) - `#s(file-dependency ,f))) + `#s(file-dependency ,f ,module?))) diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index cc84b2281b..467dbdeddb 100644 --- a/collects/compiler/cm.rkt +++ b/collects/compiler/cm.rkt @@ -266,7 +266,7 @@ (get-source-sha1 (path-replace-suffix p #".ss"))))]) (call-with-input-file* p sha1))) -(define (get-dep-sha1s deps up-to-date read-src-syntax mode roots must-exist?) +(define (get-dep-sha1s deps up-to-date read-src-syntax mode roots must-exist? seen) (let ([l (for/fold ([l null]) ([dep (in-list deps)]) (and l ;; (cons 'ext rel-path) => a non-module file, check source @@ -280,8 +280,8 @@ [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] [else #f]))] [(or (hash-ref up-to-date (simple-form-path p) #f) - ;; Use `compiler-root' with `sha1-only?' as #t: - (compile-root mode roots p up-to-date read-src-syntax #t)) + ;; Use `compile-root' with `sha1-only?' as #t: + (compile-root mode roots p up-to-date read-src-syntax #t seen)) => (lambda (sh) (cons (cons (cdr sh) dep) l))] [must-exist? @@ -303,9 +303,12 @@ ;; compute one hash from all hashes (sha1 (open-input-bytes (get-output-bytes p))))))) -(define (write-deps code mode roots path src-sha1 external-deps reader-deps up-to-date read-src-syntax) +(define (write-deps code mode roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date read-src-syntax) (let ([dep-path (path-add-suffix (get-compilation-path mode roots path) #".dep")] [deps (remove-duplicates (append (get-deps code path) + external-module-deps ; can create cycles if misused! reader-deps))] [external-deps (remove-duplicates external-deps)]) (with-compile-output dep-path @@ -317,7 +320,7 @@ external-deps))]) (write (list* (version) (cons (or src-sha1 (get-source-sha1 path)) - (get-dep-sha1s deps up-to-date read-src-syntax mode roots #t)) + (get-dep-sha1s deps up-to-date read-src-syntax mode roots #t #hash())) deps) op) (newline op)))))) @@ -345,7 +348,7 @@ (define-struct ext-reader-guard (proc top) #:property prop:procedure (struct-field-index proc)) -(define-struct file-dependency (path) #:prefab) +(define-struct file-dependency (path module?) #:prefab) (define (compile-zo* mode roots path src-sha1 read-src-syntax zo-name up-to-date) ;; The `path' argument has been converted to .rkt or .ss form, @@ -353,14 +356,17 @@ ;; External dependencies registered through reader guard and ;; accomplice-logged events: (define external-deps null) + (define external-module-deps null) (define reader-deps null) (define deps-sema (make-semaphore 1)) (define done-key (gensym)) - (define (external-dep! p) + (define (external-dep! p module?) (call-with-semaphore deps-sema (lambda () - (set! external-deps (cons (path->bytes p) external-deps))))) + (if module? + (set! external-module-deps (cons (path->bytes p) external-module-deps)) + (set! external-deps (cons (path->bytes p) external-deps)))))) (define (reader-dep! p) (call-with-semaphore deps-sema @@ -379,7 +385,8 @@ (if (and (eq? (vector-ref l 0) 'info) (file-dependency? (vector-ref l 2)) (path? (file-dependency-path (vector-ref l 2)))) - (external-dep! (file-dependency-path (vector-ref l 2))) + (external-dep! (file-dependency-path (vector-ref l 2)) + (file-dependency-module? (vector-ref l 2))) (log-message orig-log (vector-ref l 0) (vector-ref l 1) (vector-ref l 2))) (loop)))))))) @@ -465,7 +472,9 @@ ;; Note that we check time and write .deps before returning from ;; with-compile-output... (verify-times path tmp-name) - (write-deps code mode dest-roots path src-sha1 external-deps reader-deps up-to-date read-src-syntax))))) + (write-deps code mode dest-roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date read-src-syntax))))) (define (install-module-hashes! s start len) (define vlen (bytes-ref s (+ start 2))) @@ -506,7 +515,7 @@ alt-path path)))) -(define (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date) +(define (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date seen) (let ([actual-path (actual-source-path orig-path)]) (unless sha1-only? ((manager-compile-notify-handler) actual-path) @@ -531,7 +540,7 @@ (if (and zo-exists? src-sha1 (equal? src-sha1 (caadr deps)) - (equal? (get-dep-sha1s (cddr deps) up-to-date read-src-syntax mode roots #f) + (equal? (get-dep-sha1s (cddr deps) up-to-date read-src-syntax mode roots #f seen) (cdadr deps))) (begin (log-info (format "cm: ~ahash-equivalent ~a" @@ -610,7 +619,7 @@ (path-replace-suffix p #".ss") p))) -(define (compile-root mode roots path0 up-to-date read-src-syntax sha1-only?) +(define (compile-root mode roots path0 up-to-date read-src-syntax sha1-only? seen) (define orig-path (simple-form-path path0)) (define (read-deps path) (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) @@ -630,6 +639,11 @@ [path-time (or main-path-time alt-path-time)] [path-zo-time (get-compiled-time mode roots path)]) (cond + [(hash-ref seen path #f) + (error 'compile-zo + "dependency cycle\n involves module: ~a" + path) + #f] [(not path-time) (trace-printf "~a does not exist" orig-path) (or (hash-ref up-to-date orig-path #f) @@ -640,17 +654,18 @@ (hash-set! up-to-date alt-path stamp)) stamp))] [else - (let ([deps (read-deps path)]) + (let ([deps (read-deps path)] + [new-seen (hash-set seen path #t)]) (define build (cond [(not (and (pair? deps) (equal? (version) (car deps)))) (lambda () (trace-printf "newer version...") - (maybe-compile-zo #f #f mode roots path orig-path read-src-syntax up-to-date))] + (maybe-compile-zo #f #f mode roots path orig-path read-src-syntax up-to-date new-seen))] [(> path-time path-zo-time) (trace-printf "newer src...") ;; 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)] + (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date new-seen)] [(ormap (lambda (p) ;; (cons 'ext rel-path) => a non-module file (check date) @@ -660,15 +675,16 @@ (define t (if ext? (cons (try-file-time d) #f) - (compile-root mode roots d up-to-date read-src-syntax #f))) - (and (car t) + (compile-root mode roots d up-to-date read-src-syntax #f new-seen))) + (and t + (car t) (> (car t) path-zo-time) (begin (trace-printf "newer: ~a (~a > ~a)..." d (car t) path-zo-time) #t))) (cddr deps)) ;; 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)] + (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date new-seen)] [else #f])) (cond [(and build sha1-only?) #f] @@ -704,7 +720,8 @@ (path->complete-path src) cache read-src-syntax - #f) + #f + #hash()) (void))))) (define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f] @@ -768,7 +785,7 @@ [else (trace-printf "processing: ~a" path) (parameterize ([compiler-security-guard security-guard]) - (compile-root (car modes) roots path cache read-syntax #f)) + (compile-root (car modes) roots path cache read-syntax #f #hash())) (trace-printf "done: ~a" path)]) (default-handler path mod-name)) (when (null? modes) diff --git a/collects/scribblings/raco/make.scrbl b/collects/scribblings/raco/make.scrbl index 9eebbfc0f2..609aab404b 100644 --- a/collects/scribblings/raco/make.scrbl +++ b/collects/scribblings/raco/make.scrbl @@ -528,7 +528,8 @@ directory. Logs a message (see @racket[log-message]) at level @racket['info]. The message data is a @racketidfont{file-dependency} prefab structure type -with one field whose value is @racket[file]. +with two fields; the first field's value is @racket[file] and the second +field's value is @racket[#f] (to indicate a non-module dependency). A compilation manager implemented by @racketmodname[compiler/cm] looks for such messages to register an external dependency. The compilation @@ -540,6 +541,17 @@ compilation manager will know to recompile the module. The @racket[include] macro, for example, calls this procedure with the path of an included file as it expands an @racket[include] form.} +@defproc[(register-external-module [file (and path? complete-path?)]) void?]{ + +Like @racket[register-external-file], but logs a message with a +@racketidfont{file-dependency} prefab structure type whose second +field is @racket[#t]. + +A compilation manager implemented by @racketmodname[compiler/cm] +recognizes the message to register a dependency on a +module (which implies a dependency on all of that module's +dependencies, etc.).} + @; ---------------------------------------------------------------------- @section[#:tag "zo"]{Compiling to Raw Bytecode}