From a4f06c9201b50c130ada38b4393b4a81ec93cf85 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 19 Aug 2008 00:15:00 +0000 Subject: [PATCH] move mzlib/cm and mzlib/cm-accomplice to compiler svn: r11313 original commit: 2a2977d8043b79fd110bdaa6c7490c51a068fec6 --- collects/mzlib/cm-accomplice.ss | 19 --- collects/mzlib/cm.ss | 290 -------------------------------- 2 files changed, 309 deletions(-) delete mode 100644 collects/mzlib/cm-accomplice.ss delete mode 100644 collects/mzlib/cm.ss diff --git a/collects/mzlib/cm-accomplice.ss b/collects/mzlib/cm-accomplice.ss deleted file mode 100644 index 6ab7898..0000000 --- a/collects/mzlib/cm-accomplice.ss +++ /dev/null @@ -1,19 +0,0 @@ -(module cm-accomplice mzscheme - (provide register-external-file) - - (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)))) - - diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss deleted file mode 100644 index 3ab9f03..0000000 --- a/collects/mzlib/cm.ss +++ /dev/null @@ -1,290 +0,0 @@ -#lang scheme/base -(require syntax/modcode - syntax/modresolve - setup/main-collects - scheme/file - scheme/list) - -(provide make-compilation-manager-load/use-compiled-handler - managed-compile-zo - make-caching-managed-compile-zo - trust-existing-zos - manager-compile-notify-handler - (rename-out [trace manager-trace-handler])) - -(define manager-compile-notify-handler (make-parameter void)) -(define trace (make-parameter void)) -(define indent (make-parameter "")) -(define trust-existing-zos (make-parameter #f)) - -(define (trace-printf fmt . args) - (let ([t (trace)]) - (unless (eq? t void) - (t (string-append (indent) (apply format fmt args)))))) - -(define (get-deps code path) - (filter-map (lambda (x) - (let ([r (resolve-module-path-index x path)]) - (and (path? x) (path->bytes x)))) - (append-map cdr (module-compiled-imports code)))) - -(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))) - -(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)))) - -(define (touch path) - (close-output-port (open-output-file path #:exists 'append))) - -(define (try-file-time path) - ;; might be better to use a `with-handlers' - (and (file-exists? path) (file-or-directory-modify-seconds path))) - -(define (try-delete-file path) - ;; Attempt to delete, but give up if it doesn't work: - (with-handlers ([exn:fail:filesystem? void]) - (trace-printf "deleting: ~a" path) - (delete-file path))) - -(define (compilation-failure mode path zo-name date-path reason) - (try-delete-file zo-name) - (trace-printf "failure")) - -;; with-compile-output : path (output-port -> alpha) -> alpha -;; Open path for writing, and arranges to delete path if there's -;; an exception. Breaks are managed so that the port is reliably -;; closed and the file is reliably deleted if there's a break -(define (with-compile-output path proc) - (let ([bp (current-break-parameterization)]) - (with-handlers ([void (lambda (exn) (try-delete-file path) (raise exn))]) - (let ([out (open-output-file path #:exists 'truncate/replace)]) - (dynamic-wind - void - (lambda () - (call-with-break-parameterization bp (lambda () (proc out)))) - (lambda () - (close-output-port out))))))) - -(define (write-deps code mode path external-deps) - (let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")] - [deps (remove-duplicates (get-deps code path))] - [external-deps (remove-duplicates external-deps)]) - (with-compile-output dep-path - (lambda (op) - (write `(,(version) - ,@(map path->main-collects-relative deps) - ,@(map (lambda (x) - (cons 'ext (path->main-collects-relative x))) - external-deps)) - op) - (newline op))))) - -(define (format-time sec) - (let ([d (seconds->date sec)]) - (format "~a-~a-~a ~a:~a:~a" - (date-year d) (date-month d) (date-day d) - (date-hour d) (date-minute d) (date-second d)))) - -(define (verify-times ss-name zo-name) - (define ss-sec (try-file-time ss-name)) ; should exist - (define zo-sec (try-file-time zo-name)) - (cond [(not ss-sec) (error 'compile-zo "internal error")] - [(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a" - zo-name ss-name)] - [(< zo-sec ss-sec) (error 'compile-zo - "date for newly created .zo file (~a @ ~a) ~ - is before source-file date (~a @ ~a)~a" - zo-name - (format-time (seconds->date zo-sec)) - ss-name - (format-time (seconds->date ss-sec)) - (if (> ss-sec (current-seconds)) - ", which appears to be in the future" - ""))])) - -(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))) - (define external-deps null) - (define (external-dep! p) - (set! external-deps (cons (path->bytes p) external-deps))) - (define code - (parameterize ([param external-dep!] - [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)))]) - (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)) - (when code - (make-directory* code-dir) - (with-compile-output zo-name - (lambda (out) - (with-handlers ([exn:fail? - (lambda (ex) - (close-output-port out) - (compilation-failure mode path zo-name #f - (exn-message ex)) - (raise ex))]) - (parameterize ([current-write-relative-directory - (let-values ([(base name dir?) (split-path path)]) - (if (eq? base 'relative) - (current-directory) - (path->complete-path base (current-directory))))]) - (write code out))) - ;; redundant, but close as early as possible: - (close-output-port out) - ;; Note that we check time and write .deps before returning from - ;; with-compile-output... - (verify-times path zo-name) - (write-deps code mode path external-deps))))) - -(define (compile-zo mode path read-src-syntax) - ((manager-compile-notify-handler) path) - (trace-printf "compiling: ~a" path) - (parameterize ([indent (string-append " " (indent))]) - (let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")] - [zo-exists? (file-exists? zo-name)]) - (if (and zo-exists? (trust-existing-zos)) - (touch zo-name) - (begin (when zo-exists? (delete-file zo-name)) - (with-handlers - ([exn:get-module-code? - (lambda (ex) - (compilation-failure mode path zo-name - (exn:get-module-code-path ex) - (exn-message ex)) - (raise ex))]) - (compile-zo* mode path read-src-syntax zo-name)))))) - (trace-printf "end compile: ~a" path)) - -(define (get-compiled-time mode path) - (define-values (dir name) (get-compilation-dir+name mode path)) - (or (try-file-time (build-path dir "native" (system-library-subpath) - (path-add-suffix name (system-type - 'so-suffix)))) - (try-file-time (build-path dir (path-add-suffix name #".zo"))) - -inf.0)) - -(define (compile-root mode path0 up-to-date read-src-syntax) - (define path (simplify-path (cleanse-path path0))) - (define (read-deps) - (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version)))]) - (call-with-input-file - (path-add-suffix (get-compilation-path mode path) #".dep") - read))) - (define (do-check) - (define path-zo-time (get-compiled-time mode path)) - (define path-time (try-file-time path)) - (cond - [(not path-time) - (trace-printf "~a does not exist" path) - path-zo-time] - [else - (cond - [(> path-time path-zo-time) - (trace-printf "newer src...") - (compile-zo mode path read-src-syntax)] - [else - (let ([deps (read-deps)]) - (cond - [(not (and (pair? deps) (equal? (version) (car deps)))) - (trace-printf "newer version...") - (compile-zo mode path read-src-syntax)] - [(ormap - (lambda (p) - ;; (cons 'ext rel-path) => a non-module file (check date) - ;; rel-path => a module file name (check transitive dates) - (define ext? (and (pair? p) (eq? 'ext (car p)))) - (define d (main-collects-relative->path (if ext? (cdr p) p))) - (define t - (cond [(not (path? d)) #f] ;; (can this happen?) - [ext? (try-file-time d)] - [else (compile-root mode d up-to-date - read-src-syntax)])) - (and t (> t path-zo-time) - (begin (trace-printf "newer: ~a (~a > ~a)..." - d t path-zo-time) - #t))) - (cdr deps)) - (compile-zo mode path read-src-syntax)]))]) - (let ([stamp (get-compiled-time mode path)]) - (hash-set! up-to-date path stamp) - stamp)])) - (or (and up-to-date (hash-ref up-to-date path #f)) - (begin (trace-printf "checking: ~a" path) - (do-check)))) - -(define (managed-compile-zo zo [read-src-syntax read-syntax]) - ((make-caching-managed-compile-zo read-src-syntax) zo)) - -(define (make-caching-managed-compile-zo [read-src-syntax read-syntax]) - (let ([cache (make-hash)]) - (lambda (zo) - (parameterize ([current-load/use-compiled - (make-compilation-manager-load/use-compiled-handler/table - cache)]) - (compile-root (car (use-compiled-file-paths)) - (path->complete-path zo) - cache read-src-syntax) - (void))))) - -(define (make-compilation-manager-load/use-compiled-handler) - (make-compilation-manager-load/use-compiled-handler/table (make-hash))) - -(define (make-compilation-manager-load/use-compiled-handler/table cache) - (let ([orig-eval (current-eval)] - [orig-load (current-load)] - [orig-registry (namespace-module-registry (current-namespace))] - [default-handler (current-load/use-compiled)] - [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))] - [(not (eq? compilation-manager-load-handler - (current-load/use-compiled))) - (trace-printf "skipping: ~a current-load/use-compiled changed ~s" - path (current-load/use-compiled))] - [(not (eq? orig-eval (current-eval))) - (trace-printf "skipping: ~a orig-eval ~s current-eval ~s" - path orig-eval (current-eval))] - [(not (eq? orig-load (current-load))) - (trace-printf "skipping: ~a orig-load ~s current-load ~s" - path orig-load (current-load))] - [(not (eq? orig-registry - (namespace-module-registry (current-namespace)))) - (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" - path orig-registry - (namespace-module-registry (current-namespace)))] - [else - (trace-printf "processing: ~a" path) - (compile-root (car modes) path cache read-syntax) - (trace-printf "done: ~a" path)]) - (default-handler path mod-name)) - (when (null? modes) - (raise-mismatch-error 'make-compilation-manager-... - "empty use-compiled-file-paths list: " - modes)) - compilation-manager-load-handler))