fix cm-accomplice and avoid redundant reader-module dependencies
svn: r11354
This commit is contained in:
Matthew Flatt
parent
15cf8e72e1
commit
6516518ae5
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
91
collects/tests/mzscheme/cm.ss
Normal file
91
collects/tests/mzscheme/cm.ss
Normal file
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user