fix cm-accomplice and avoid redundant reader-module dependencies

svn: r11354

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)])
+  (log-message (current-logger) 'info "compilation dependency" f))
-    ;; 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)))

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
+  ;; External dependencies registered through reader guard and accomplice-logged events:
-    ;; Avoid using cm while loading cm-ctime:
-    (parameterize ([use-compiled-file-paths null])
-      (dynamic-require 'compiler/private/cm-ctime
-                       'current-external-file-registrar)))
   (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!]
+    (parameterize ([current-reader-guard
-                   [current-reader-guard
                     (let ([rg (current-reader-guard)])
-                      (lambda (d)
+                      (make-ext-reader-guard
-                        (let ([d (rg d)])
+                       (lambda (d)
-                          (when (module-path? d)
+                         ;; Start by calling the previously installed guard
-                            (let ([p (resolved-module-path-name
+                         ;; to transform the module path, but also avoid
-                                      (module-path-index-resolve
+                         ;; redundant dependencies by skipping over cm guards
-                                       (module-path-index-join d #f)))])
+                         ;; for files being compiled.
-                              (when (path? p) (external-dep! p))))
+                         (let ([d (let loop ([rg rg])
-                          d)))])
+                                    (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

collects/compiler/private/cm-ctime.ss

@@ -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))))

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
+Logs a message (see @scheme[log-message]) at level @scheme['info]. The
-implemented by @schememodname[compiler/cm], if one is active. The
+message is @scheme["compilation dependency"], and the data associated
-compilation manager then records (in a @filepath{.dep} file) the path
+with the message is @scheme[file].
-as contributing to the implementation of the module currently being
+
+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.
 

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

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)

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)