improve internal organization of the compilation manager

racket/collects/compiler/private/cm-dep.rkt

@@ -0,0 +1,64 @@
+#lang racket/base
+(require racket/list
+         syntax/modread
+         syntax/private/modresolve-noctc
+         compiler/private/dep
+         "cm-path.rkt"
+         "cm-file.rkt"
+         "cm-log.rkt")
+
+(provide (all-defined-out))
+
+;; Format in a ".dep" file is:
+;;   (list <version>
+;;         <machine> ; symbol or #f for machine-independent
+;;         <sha1s>
+;;         <dep> ...)
+;; where <sha1> = (cons <src-sha1> <imports-sha1>)
+;;              | (cons <src-sha1> (cons <imports-sha1> <assume-cmopiled-sha1>))
+;; An <assume-compiled-sha1> is for the case where a machine-independent
+;; bytecode file is recompiled, and the original machine-independent hash
+;; should be preserved.
+
+(define deps-has-version? pair?)
+(define deps-version car)
+(define (deps-has-machine? p) (and (pair? p) (pair? (cdr p))))
+(define deps-machine cadr)
+(define deps-sha1s caddr)
+(define deps-src-sha1 caaddr)
+(define (deps-imports-sha1 deps)
+  (define p (cdaddr deps))
+  (if (pair? p) (car p) p))
+(define (deps-assume-compiled-sha1 deps)
+  ;; Returns #f if ".dep" doesn't record a sha1 to assume for the compiled code
+  (define p (cdaddr deps))
+  (and (pair? p) (cdr p)))
+(define deps-imports cdddr)
+
+(define (get-deps code path)
+  (define ht
+    (let loop ([code code] [ht (hash)])
+      (define new-ht
+        (for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))]
+                              [x (in-list (cdr imports))])
+          (let* ([r (resolve-module-path-index x path)]
+                 [r (if (pair? r) (cadr r) r)])
+            (if (and (path? r) 
+                     (not (equal? path r))
+                     (not (equal? path r))
+                     (not (equal? path (rkt->ss r))))
+                (hash-set ht (path->bytes r) #t)
+                ht))))
+      (for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))]
+                                [subcode (in-list (module-compiled-submodules code non-star?))])
+        (loop subcode ht))))
+  (for/list ([k (in-hash-keys ht)]) k))
+
+(define (read-deps-file dep-path)
+  (with-handlers ([exn:fail:filesystem? (lambda (ex)
+                                          (trace-printf "failed reading ~a" dep-path)
+                                          (list #f "none" '(#f . #f)))])
+    (with-module-reading-parameterization
+      (lambda ()
+        (call-with-input-file* dep-path read)))))
+

racket/collects/compiler/private/cm-file.rkt

@@ -0,0 +1,98 @@
+#lang racket/base
+(require racket/file
+         racket/path
+         file/sha1
+         "cm-util.rkt"
+         "cm-path.rkt"
+         "cm-security.rkt"
+         "cm-log.rkt")
+
+(provide (all-defined-out))
+
+(define (try-file-time p)
+  (let ([s (file-or-directory-modify-seconds p #f (lambda () #f))])
+    (and s
+         (if (eq? (use-compiled-file-check) 'modify-seconds)
+             s
+             0))))
+
+(define (touch path)
+  (when (eq? 'modify-seconds (use-compiled-file-check))
+    (with-compiler-security-guard
+     (file-or-directory-modify-seconds 
+      path
+      (current-seconds)
+      (lambda ()
+        (close-output-port (open-output-file path #:exists 'append)))))))
+
+(define (try-delete-file path [noisy? #t])
+  ;; Attempt to delete, but give up if it doesn't work:
+  (with-handlers ([exn:fail:filesystem? void])
+    (when noisy? (trace-printf "deleting ~a" path))
+    (with-compiler-security-guard (delete-file* path))))
+
+(define (delete-file* path)
+  (if (eq? 'windows (system-type))
+      ;; Using `delete-directory/files` tries deleting by first moving
+      ;; to the temporary folder:
+      (delete-directory/files path #:must-exist? #f)
+      (delete-file path)))
+
+(define (actual-source-path path)
+  (if (file-exists? path) 
+      path
+      (let ([alt-path (rkt->ss path)])
+        (if (file-exists? alt-path)
+            alt-path
+            path))))
+
+;; with-compile-output : path (output-port path -> alpha) -> alpha
+(define (with-compile-output path proc)
+  (call-with-atomic-output-file 
+   path
+   #:security-guard (pick-security-guard)
+   proc
+   ;; On Windows, if some other process/place is reading the file, then
+   ;; an atomic move cannot succeed. Pause and try again, up to a point,
+   ;; then give up on atomicity.
+   #:rename-fail-handler (let ([amt 0.01])
+                           (lambda (exn tmp-path)
+                             (cond
+                              [(and amt
+                                    (eq? 'windows (system-type))
+                                    (exn:fail:filesystem:errno? exn)
+                                    (let ([errno (exn:fail:filesystem:errno-errno exn)])
+                                      (and (eq? 'windows (cdr errno))
+                                           (eqv? (car errno) 5)))) ; ERROR_ACCESS_DENIED
+                               (cond
+                                [(< amt 0.5)
+                                 (sleep amt)
+                                 (set! amt (* 2 amt))]
+                                [else
+                                 ;; Give up an atomicity
+                                 (try-delete-file path)
+                                 ;; And give up on trying to handle errors
+                                 (set! amt #f)])]
+                              [else (raise exn)])))))
+
+(define (get-source-sha1 p)
+  (with-handlers ([exn:fail:filesystem? (lambda (exn)
+                                          (and (path-has-extension? p #".rkt")
+                                               (get-source-sha1 (path-replace-extension p #".ss"))))])
+    (call-with-input-file* p sha1)))
+
+(define (verify-times ss-name zo-name)
+  (when (eq? 'modify-seconds (use-compiled-file-check))
+    (define ss-sec (file-or-directory-modify-seconds ss-name))
+    (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 zo-sec)
+                                    ss-name (format-time ss-sec)
+                                    (if (> ss-sec (current-seconds))
+                                        ", which appears to be in the future"
+                                        ""))])))

racket/collects/compiler/private/cm-hash.rkt

@@ -0,0 +1,33 @@
+#lang racket/base
+
+(provide install-module-hashes!)
+
+(define (install-module-hashes! s [start 0] [len (bytes-length s)])
+  (define vlen (bytes-ref s (+ start 2)))
+  (define vmlen (bytes-ref s (+ start 3 vlen)))
+  (define mode (integer->char (bytes-ref s (+ start 4 vlen vmlen))))
+  (case mode
+    [(#\B)
+     ;; A linklet bundle:
+     (define h (sha1-bytes s start (+ start len)))
+     ;; Write sha1 for bundle hash:
+     (bytes-copy! s (+ start 5 vlen vmlen) h)]
+    [(#\D)
+     ;; A linklet directory. The format starts with <count>,
+     ;; and then it's <count> records of the format:
+     ;;  <name-len> <name-bytes> <bund-pos> <bund-len> <left-pos> <right-pos>
+     (define (read-num rel-pos)
+       (define pos (+ start rel-pos))
+       (integer-bytes->integer s #t #f pos (+ pos 4)))
+     (define count (read-num (+ 5 vlen vmlen)))
+     (for/fold ([pos (+ 9 vlen vmlen)]) ([i (in-range count)])
+       (define pos-pos (+ pos 4 (read-num pos)))
+       (define bund-start (read-num pos-pos))
+       (define bund-len (read-num (+ pos-pos 4)))
+       (install-module-hashes! s (+ start bund-start) bund-len)
+       (+ pos-pos 16))
+     (void)]
+    [else 
+     ;; ?? unknown mode
+     (void)]))
+

racket/collects/compiler/private/cm-log.rkt

@@ -0,0 +1,50 @@
+#lang racket/base
+
+(provide (all-defined-out))
+
+(define cm-logger (make-logger 'compiler/cm (current-logger)))
+(define (default-manager-trace-handler str)
+  (when (log-level? cm-logger 'debug)
+    (log-message cm-logger 'debug str (current-inexact-milliseconds))))
+
+(struct compile-event (timestamp path action) #:prefab)
+(define (log-compile-event path action)
+  (when (log-level? cm-logger 'info 'compiler/cm)
+    (log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path)
+                 (compile-event (current-inexact-milliseconds) path action))))
+
+(define manager-compile-notify-handler (make-parameter void))
+(define manager-trace-handler (make-parameter default-manager-trace-handler))
+(define indent (make-parameter 0))
+
+(define managed-compiled-context-key (gensym))
+(define (make-compilation-context-error-display-handler orig)
+  (lambda (str exn)
+    (define l (continuation-mark-set->list
+               (exn-continuation-marks exn)
+               managed-compiled-context-key))
+    (orig (if (null? l)
+              str
+              (apply
+               string-append
+               str
+               "\n  compilation context...:"
+               (for/list ([i (in-list l)])
+                 (format "\n   ~a" i))))
+          exn)))
+
+(define (trace-printf fmt . args)
+  (let ([t (manager-trace-handler)])
+    (unless (or (eq? t void)
+                (and (equal? t default-manager-trace-handler)
+                     (not (log-level? cm-logger 'debug))))
+      (t (string-append (get-indent-string)
+                        (apply format fmt args))))))
+
+(define (get-indent-string)
+  (build-string (indent)
+                (λ (x)
+                  (if (and (= 2 (modulo x 3))
+                           (not (= x (- (indent) 1))))
+                      #\|
+                      #\space))))

racket/collects/compiler/private/cm-path.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+(require racket/path
+         setup/collects)
+
+(provide (all-defined-out))
+
+(define (rkt->ss p)
+  (if (path-has-extension? p #".rkt")
+      (path-replace-extension p #".ss")
+      p))
+
+(define (path*->collects-relative p)
+  (if (bytes? p)
+      (let ([q (path->collects-relative (bytes->path p))])
+        (if (path? q)
+            (path->bytes q)
+            q))
+      (path->collects-relative p)))
+
+(define (collects-relative*->path p cache)
+  (if (bytes? p)
+      (bytes->path p)
+      (hash-ref! cache p (lambda () (collects-relative->path p)))))

racket/collects/compiler/private/cm-security.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+
+(provide compiler-security-guard
+         pick-security-guard
+         with-compiler-security-guard)
+
+(define compiler-security-guard (make-parameter #f))
+
+(define (pick-security-guard)
+  (or (compiler-security-guard)
+      (current-security-guard)))
+
+(define-syntax-rule (with-compiler-security-guard expr)
+  (parameterize ([current-security-guard (pick-security-guard)]) 
+    expr))
+

racket/collects/compiler/private/cm-util.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+
+(provide (all-defined-out))
+
+(define (s-exp<? a b)
+  (string<? (format "~s" a) (format "~s" b)))
+
+(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 (ormap-strict f l)
+  (cond
+    [(null? l) #f]
+    [else
+     (define a (f (car l)))
+     (define b (ormap-strict f (cdr l)))
+     (or a b)]))