diff --git a/collects/compiler/cm-accomplice.ss b/collects/compiler/cm-accomplice.ss index 4af191efe8..efc6925f68 100644 --- a/collects/compiler/cm-accomplice.ss +++ b/collects/compiler/cm-accomplice.ss @@ -4,13 +4,4 @@ (define (register-external-file f) (unless (and (path? f) (complete-path? f)) (raise-type-error 'register-external-file "complete path" f)) - (let ([param (lambda () void)]) - ;; Load the code in a separate thread, so that the dynamic - ;; extent of this one (likely a phase-sensitive macro expansion) - ;; doesn't pollute the load: - (thread-wait - (thread (lambda () - (set! param - (dynamic-require 'compiler/private/cm-ctime - 'current-external-file-registrar))))) - ((param) f))) + (log-message (current-logger) 'info "compilation dependency" f)) diff --git a/collects/compiler/cm.ss b/collects/compiler/cm.ss index 3381b8b3cc..6209068116 100644 --- a/collects/compiler/cm.ss +++ b/collects/compiler/cm.ss @@ -110,31 +110,72 @@ ", which appears to be in the future" ""))])) +(define-struct ext-reader-guard (proc prev) + #:property prop:procedure (struct-field-index proc)) + (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 'compiler/private/cm-ctime - 'current-external-file-registrar))) + ;; External dependencies registered through reader guard and accomplice-logged events: (define external-deps null) + (define deps-sema (make-semaphore 1)) + (define done-key (gensym)) (define (external-dep! p) - (set! external-deps (cons (path->bytes p) external-deps))) + (call-with-semaphore + deps-sema + (lambda () + (set! external-deps (cons (path->bytes p) external-deps))))) + + ;; Set up a logger to receive and filter accomplice events: + (define accomplice-logger (make-logger)) + (define accomplice-log-receiver + (make-log-receiver accomplice-logger 'info)) + (define log-th + (let ([orig-log (current-logger)]) + (thread (lambda () + (let loop () + (let ([l (sync accomplice-log-receiver)]) + (cond + [(eq? (vector-ref l 2) done-key) 'done] + [(and (eq? (vector-ref l 0) 'info) + (equal? "compilation dependency" (vector-ref l 1)) + (path? (vector-ref l 2))) + (external-dep! (vector-ref l 2)) + (loop)] + [else + (log-message orig-log (vector-ref l 0) (vector-ref l 1) (vector-ref l 2)) + (loop)]))))))) + + ;; Compile the code: (define code - (parameterize ([param external-dep!] - [current-reader-guard + (parameterize ([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)))]) + (make-ext-reader-guard + (lambda (d) + ;; Start by calling the previously installed guard + ;; to transform the module path, but also avoid + ;; redundant dependencies by skipping over cm guards + ;; for files being compiled. + (let ([d (let loop ([rg rg]) + (if (ext-reader-guard? rg) + (loop (ext-reader-guard-prev rg)) + (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)) + rg))] + [current-logger accomplice-logger]) (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)) + + ;; Wait for accomplice logging to finish: + (log-message accomplice-logger 'info "stop" done-key) + (sync log-th) + + ;; Write the code and dependencies: (when code (make-directory* code-dir) (with-compile-output zo-name diff --git a/collects/compiler/private/cm-ctime.ss b/collects/compiler/private/cm-ctime.ss deleted file mode 100644 index 531071ba46..0000000000 --- a/collects/compiler/private/cm-ctime.ss +++ /dev/null @@ -1,13 +0,0 @@ -(module cm-ctime '#%kernel - (#%provide current-external-file-registrar) - - (define-values (current-external-file-registrar) - (make-parameter - void - (lambda (p) - (if (if (procedure? p) - (procedure-arity-includes? p 1) - #f) - 'ok - (raise-type-error 'current-external-file-registrar "procedure (arity 2)" p)) - p)))) diff --git a/collects/scribblings/mzc/make.scrbl b/collects/scribblings/mzc/make.scrbl index 472406bbea..e840184905 100644 --- a/collects/scribblings/mzc/make.scrbl +++ b/collects/scribblings/mzc/make.scrbl @@ -249,10 +249,14 @@ A parameter for a procedure of one argument that is called to report @defproc[(register-external-file [file (and path? complete-path?)]) void?]{ -Registers the complete path @scheme[file] with a compilation manager -implemented by @schememodname[compiler/cm], if one is active. The -compilation manager then records (in a @filepath{.dep} file) the path -as contributing to the implementation of the module currently being +Logs a message (see @scheme[log-message]) at level @scheme['info]. The +message is @scheme["compilation dependency"], and the data associated +with the message is @scheme[file]. + +A compilation manager implemented by @schememodname[compiler/cm] looks +for such messages to register an external dependency. The compilation +manager records (in a @filepath{.dep} file) the path as contributing +to the implementation of the module currently being compiled. Afterward, if the registered file is modified, the compilation manager will know to recompile the module. diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index db5aaaf63a..5f7746cd0e 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -675,6 +675,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (when (make-info-domain) + (setup-printf #f "--- updating info-domain tables ---") ;; Each ht maps a collection root dir to an info-domain table. Even when ;; `collections-to-compile' is a subset of all collections, we only care ;; about those collections that exist in the same root as the ones in diff --git a/collects/tests/mzscheme/cm.ss b/collects/tests/mzscheme/cm.ss new file mode 100644 index 0000000000..094df657c3 --- /dev/null +++ b/collects/tests/mzscheme/cm.ss @@ -0,0 +1,91 @@ + +(load-relative "loadtest.ss") + +(Section 'cm) + +(require compiler/cm + scheme/file) + +(define dir (build-path (find-system-path 'temp-dir) + "plt-cm-test")) +(make-directory* dir) + +(define (try files #; (list (list path content-str compile?) ...) + recomps #; (list (list (list touch-path ...) + (list rebuild-path ...) + (list check-rebuilt-path ...))) + ) + (delete-directory/files dir) + (make-directory* dir) + (printf "wrorking in ~s\n" dir) + (for-each (lambda (f) + (printf "writing ~a\n" (car f)) + (with-output-to-file (build-path dir (car f)) + (lambda () + (display (cadr f))))) + files) + (for-each (lambda (f) + (when (caddr f) + (printf "making ~a\n" (car f)) + (managed-compile-zo (build-path dir (car f))))) + files) + (let ([timestamps + (hash-copy + (for/hash ([f (in-list files)]) + (values (car f) + (file-or-directory-modify-seconds + (build-path dir "compiled" (path-add-suffix (car f) #".zo")) + #f + (lambda () -inf.0)))))]) + (for-each (lambda (recomp) + (printf "pausing...\n") + (sleep 1) ;; timestamps have a 1-second granularity on most filesystems + (for-each (lambda (f) + (printf "touching ~a\n" f) + (with-output-to-file (build-path dir f) + #:exists 'append + (lambda () (display " ")))) + (car recomp)) + (for-each (lambda (f) + (printf "re-making ~a\n" f) + (managed-compile-zo (build-path dir f))) + (cadr recomp)) + (for-each (lambda (f) + (let ([ts (hash-ref timestamps f)] + [new-ts + (file-or-directory-modify-seconds + (build-path dir "compiled" (path-add-suffix f #".zo")) + #f + (lambda () -inf.0))] + [updated? (lambda (a b) a)]) + (test (and (member f (caddr recomp)) #t) + updated? + (new-ts . > . ts) + f) + (hash-set! timestamps f new-ts))) + (map car files))) + recomps))) + +(try '(("a.ss" "(module a scheme/base (require \"b.ss\" \"d.ss\" \"g.ss\"))" #t) + ("b.ss" "(module b scheme/base (require scheme/include) (include \"c.sch\"))" #t) + ("d.ss" "#reader \"e.ss\" 10" #t) + ("c.sch" "5" #f) + ("e.ss" "(module e syntax/module-reader \"f.ss\")" #t) + ("f.ss" "(module f scheme/base (provide (all-from-out scheme/base)))" #t) + ("g.ss" "(module g scheme/base (require (for-syntax scheme/base scheme/include \"i.ss\")) (define-syntax (f stx) (include \"h.sch\")))" #t) + ("h.sch" "(quote-syntax 12)" #f) + ("i.ss" "(module i scheme/base)" #t)) + '([("a.ss") ("a.ss") ("a.ss")] + [("b.ss") ("a.ss") ("a.ss" "b.ss")] + [("b.ss") ("b.ss") ("b.ss")] + [() ("a.ss") ("a.ss")] + [("c.sch") ("a.ss") ("a.ss" "b.ss")] + [("f.ss") ("a.ss") ("a.ss" "d.ss" "f.ss")] + [("e.ss") ("e.ss") ("e.ss")] + [() ("a.ss") ("a.ss" "d.ss")] + [("i.ss") ("a.ss") ("a.ss" "g.ss" "i.ss")] + [("h.sch") ("a.ss") ("a.ss" "g.ss")])) + +;; ---------------------------------------- + +(report-errs) diff --git a/src/mzscheme/gc2/setup.ss b/src/mzscheme/gc2/setup.ss index 250d94666e..c30b163a78 100644 --- a/src/mzscheme/gc2/setup.ss +++ b/src/mzscheme/gc2/setup.ss @@ -67,8 +67,6 @@ (go (build-path (current-load-relative-directory) "xform-mod.ss") #f "xform-collects/xform/xform-mod.ss") -;; Needed for cm: -(go 'compiler/private/cm-ctime #f #f) ;; Readers: (go 'mzscheme/lang/reader #f #f) (go 'scheme/base/lang/reader #f #f)