From 1490cd1c4de51af4359bc0c0ff41ea6bc45da5bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 8 Nov 2008 18:34:39 +0000 Subject: [PATCH] added support for automatic compilation of source files to drscheme svn: r12356 --- collects/compiler/cm.ss | 33 +++++++-- collects/drscheme/private/rep.ss | 78 +++++--------------- collects/drscheme/private/zo-cache.ss | 100 ++++++++++++++++++++++++++ collects/framework/private/editor.ss | 1 + collects/scribblings/mzc/make.scrbl | 9 +++ 5 files changed, 153 insertions(+), 68 deletions(-) create mode 100644 collects/drscheme/private/zo-cache.ss diff --git a/collects/compiler/cm.ss b/collects/compiler/cm.ss index 3ff686335f..fd7912044f 100644 --- a/collects/compiler/cm.ss +++ b/collects/compiler/cm.ss @@ -10,6 +10,7 @@ make-caching-managed-compile-zo trust-existing-zos manager-compile-notify-handler + current-path->compilation-dir (rename-out [trace manager-trace-handler])) (define manager-compile-notify-handler (make-parameter void)) @@ -17,6 +18,8 @@ (define indent (make-parameter "")) (define trust-existing-zos (make-parameter #f)) +(define current-path->compilation-dir (make-parameter #f)) + (define (trace-printf fmt . args) (let ([t (trace)]) (unless (eq? t void) @@ -30,16 +33,22 @@ (define (get-compilation-dir+name mode path) (let-values ([(base name must-be-dir?) (split-path path)]) - (values (if (eq? 'relative base) mode (build-path base mode)) - name))) + (values + (cond + [(current-path->compilation-dir) + => + (λ (f) (f path))] + [(eq? 'relative base) mode] + [else (build-path base mode)]) + name))) (define (get-compilation-path mode path) (let-values ([(dir name) (get-compilation-dir+name mode path)]) (build-path dir name))) (define (get-compilation-dir mode path) - (let-values ([(base name-suffix must-be-dir?) (split-path path)]) - (if (eq? 'relative base) mode (build-path base mode)))) + (let-values ([(dir name) (get-compilation-dir+name mode path)]) + dir)) (define (touch path) (close-output-port (open-output-file path #:exists 'append))) @@ -295,13 +304,18 @@ [orig-load (current-load)] [orig-registry (namespace-module-registry (current-namespace))] [default-handler (current-load/use-compiled)] + [orig-path->compilation-dir-handler (current-path->compilation-dir)] [modes (use-compiled-file-paths)]) (define (compilation-manager-load-handler path mod-name) (cond [(not mod-name) (trace-printf "skipping: ~a mod-name ~s" path mod-name)] - [(not (member (car modes) (use-compiled-file-paths))) - (trace-printf "skipping: ~a compiled-paths ~s" - path (use-compiled-file-paths))] + [(or (null? (use-compiled-file-paths)) + (not (equal? (car modes) + (car (use-compiled-file-paths))))) + (trace-printf "skipping: ~a compiled-paths's first element changed; current value ~s, first element was ~s" + path + (use-compiled-file-paths) + (car modes))] [(not (eq? compilation-manager-load-handler (current-load/use-compiled))) (trace-printf "skipping: ~a current-load/use-compiled changed ~s" @@ -317,6 +331,11 @@ (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" path orig-registry (namespace-module-registry (current-namespace)))] + [(not (eq? (current-path->compilation-dir) + orig-path->compilation-dir-handler)) + (trace-printf "skipping: ~a orig path->compilation-dir-handler ~s current path->compilation-dir-handler ~s" + orig-path->compilation-dir-handler + (current-path->compilation-dir))] [else (trace-printf "processing: ~a" path) (compile-root (car modes) path cache read-syntax) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 1972191874..7c7c659988 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -25,12 +25,14 @@ TODO scheme/pretty scheme/unit scheme/list - "drsig.ss" + string-constants setup/xref scheme/gui/base framework - browser/external) + browser/external + "drsig.ss" + "zo-cache.ss") (provide rep@ with-stacktrace-name) @@ -1293,7 +1295,7 @@ TODO ;; set this relatively late, so that the ;; setup code for the language doesn't use it - ;(current-load/use-compiled drscheme-load/use-compiled-handler) + (current-load/use-compiled drscheme-load/use-compiled-handler) ;; after this returns, future event dispatches ;; will use the user's break parameterization @@ -1703,65 +1705,19 @@ TODO (define drscheme-load/use-compiled-handler (let ([ol (current-load/use-compiled)]) (λ (path mod) ;; =User= - (verify-file-saved path) - (cond - [(already-a-compiled-file? path) - (ol path mod)] - [else - (error 'drscheme-load/use-compiled-handler - "time to compile! ~s" path)])))) + + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (let ([s (make-semaphore 0)]) + (queue-callback + (λ () ;; =Kernel= =Handler= + (let ([frame (send (group:get-the-frame-group) locate-file path)]) + (when frame + (send frame offer-to-save-file path))) + (semaphore-post s))) + (semaphore-wait s))) + + (build-and-load-zo-file ol path mod)))) - ;; =User= - (define (verify-file-saved path) - (parameterize ([current-eventspace drscheme:init:system-eventspace]) - (let ([s (make-semaphore 0)]) - (queue-callback - (λ () ;; =Kernel= =Handler= - (let ([frame (send (group:get-the-frame-group) locate-file path)]) - (when frame - (send frame offer-to-save-file path))) - (semaphore-post s))) - (semaphore-wait s)))) - - ;; =User= - (define (already-a-compiled-file? path) - (let* ([filename (file-name-from-path path)] - [base (path-only path)] - [extension (and filename base (filename-extension filename))] - [basename (and extension - (let ([pbs (path->bytes filename)]) - (subbytes pbs - 0 - (- (bytes-length pbs) - (bytes-length extension) - 1 ;; extra one for '.' in there - ))))] - [fm (file-or-directory-modify-seconds path)] - [newer-exists? - (λ (pot-path) - (and (file-exists? pot-path) - (< fm (file-or-directory-modify-seconds pot-path))))]) - (and basename - (ormap - (λ (c-f-p) - (or (newer-exists? (build-path base c-f-p - (bytes->path - (bytes-append basename #"_" extension #".zo")))) - (ormap - (λ (ext) - (newer-exists? (build-path base - c-f-p - "native" - (system-library-subpath) - (bytes->path - (bytes-append basename #"_" extension ext))))) - '(#".so" #".dll" #".dylib")))) - (use-compiled-file-paths))))) - - (define (path->cache-zo-file-path path) - (apply build-path - - (cdr (explode-path path)))) ;; insert-error-in-text : (is-a?/c text%) diff --git a/collects/drscheme/private/zo-cache.ss b/collects/drscheme/private/zo-cache.ss new file mode 100644 index 0000000000..850d407e2f --- /dev/null +++ b/collects/drscheme/private/zo-cache.ss @@ -0,0 +1,100 @@ +#lang scheme/base +(require scheme/path + scheme/file + compiler/cm) + +#| + +All of this code runs on the user's parameterization/thread + +|# + +(provide build-and-load-zo-file) + +(define (build-and-load-zo-file original-load/use-compiled-handler path mod) + (cond + [(or (not (filename-extension path)) + (already-a-compiled-file? path)) + ;; if there is no extension, just give up. + ;; if there is a compiled file that look up to date + ;; in the usual place, use it. + (original-load/use-compiled-handler path mod)] + [else + ;; otherwise do some managed compilation + (parameterize ([current-path->compilation-dir path->cache-path]) + (managed-compile-zo path)) + ;; and then load the compiled file + (let-values ([(base name dir) (split-path path)]) + (original-load/use-compiled-handler + (build-path (path->cache-path path) (compiled-name name #".zo")) + mod))])) + +;; path->cache-path : path[w/extension] -> path +;; returns the location of the cached zo file that corresponds to its input +(define (path->cache-path path) + (cond + [(already-a-compiled-file? path) + (let ([mode (car (use-compiled-file-paths))]) + (let-values ([(base name must-be-dir?) (split-path path)]) + (cond + [(eq? 'relative base) mode] + [else (build-path base mode)])))] + [else + (apply build-path + (find-system-path 'addon-dir) + (version) + "drscheme-zo-cache" + (remove-last (cdr (explode-path (normalize-path path)))) + #;(replace-last-with-zo (cdr (explode-path (normalize-path path)))))])) + +(define (remove-last lst) (reverse (cdr (reverse lst)))) + +(define (replace-last-with-zo lst) + (cond + [(null? (cdr lst)) + (list (compiled-name (car lst)))] + [else (cons (car lst) (replace-last-with-zo (cdr lst)))])) + +(define (exists-and-is-newer? orig-path candidate-path) + (and (file-exists? candidate-path) + (< (file-or-directory-modify-seconds orig-path) + (file-or-directory-modify-seconds candidate-path)))) + +(define (already-a-compiled-file? path) + (let* ([filename (file-name-from-path path)] + [base (path-only path)] + [file-zo-name (and filename (compiled-name filename #".zo"))] + [fm (file-or-directory-modify-seconds path)] + [newer-exists? + (λ (pot-path) + (and (file-exists? pot-path) + (< fm (file-or-directory-modify-seconds pot-path))))]) + (and file-zo-name + (ormap + (λ (c-f-p) + (or (newer-exists? (build-path base c-f-p file-zo-name)) + (newer-exists? (build-path base + c-f-p + "native" + (system-library-subpath) + (compiled-name filename (system-type 'so-suffix)))))) + (use-compiled-file-paths))))) + + +;; compiled-name : path [bytes] -> path or #f +;; returns #f if the path does not have an extension. +;; otherwise, returns an appropriately modified filename, extended with new-extension +(define (compiled-name path new-extension) + (let* ([extension (filename-extension path)] + [basename (and extension + (let ([pbs (path->bytes path)]) + (subbytes pbs + 0 + (- (bytes-length pbs) + (bytes-length extension) + 1 ;; extra one for '.' in there + ))))]) + (and basename + (bytes->path + (bytes-append basename #"_" extension new-extension))))) + diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index fa3f4869e9..5c57e8eb39 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -202,6 +202,7 @@ (file-exists? filename) (file-or-directory-modify-seconds filename))))) (inner (void) after-load-file success?)) + (define/public (save-file-out-of-date?) (and last-saved-file-time (let ([fn (get-filename)]) diff --git a/collects/scribblings/mzc/make.scrbl b/collects/scribblings/mzc/make.scrbl index ec5540c413..2f48e75b4e 100644 --- a/collects/scribblings/mzc/make.scrbl +++ b/collects/scribblings/mzc/make.scrbl @@ -241,6 +241,15 @@ A parameter for a procedure of one argument that is called to report compilation-manager actions, such as checking a file. The argument to the procedure is a string.} +@defparam[current-path->compilation-dir path->compilation-dir (or/c #f (-> path? path?))]{ + + This parameter controls the location where compiled .zo files are + saved. It is called with the path of a @tt{.ss} file and is expected + to return a path where the @tt{.zo} and @tt{.dep} file can be saved. + + If it is @scheme[#f], then @scheme[use-compiled-file-paths] is used. +} + @; ---------------------------------------------------------------------- @section{Compilation Manager Hook for Syntax Transformers}