suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

compiler/cm: detect and take recompilation shortcut

Browse Source 
When a module is compiled to platform-independent form, recompile from
that form for the current platform, instead of recompiling from source.
This commit is contained in:
Matthew Flatt 2018-11-23 08:59:52 -07:00
parent 1c437793a6
commit ac70e9a058
1 changed files with 290 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

337
racket/collects/compiler/private/cm-minimal.rkt
View File

@ -129,6 +129,32 @@
(loop subcode ht))))
(for/list ([k (in-hash-keys ht)]) k))
;; 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-compilation-path path->mode roots path)
(let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)])
(build-path dir name)))
@ -148,8 +174,9 @@
(when noisy? (trace-printf "deleting ~a" path))
(with-compiler-security-guard (delete-file path))))
(define (compilation-failure path->mode roots path zo-name date-path reason)
(try-delete-file zo-name)
(define (compilation-failure path->mode roots path zo-name keep-zo-name date-path reason)
(unless (equal? zo-name keep-zo-name)
(try-delete-file zo-name))
(trace-printf "failure"))
;; with-compile-output : path (output-port path -> alpha) -> alpha
@ -176,7 +203,8 @@
(get-source-sha1 (path-replace-extension p #".ss"))))])
(call-with-input-file* p sha1)))
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen)
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots seen
#:must-exist? must-exist?)
(let ([l (for/fold ([l null]) ([dep (in-list deps)])
(and l
(let* ([ext? (external-dep? dep)]
@ -187,9 +215,11 @@
[v (cons (cons (delay v) dep) l)]
[must-exist? (error 'cm "cannot find external-dependency file: ~v" p)]
[else #f]))]
[(or (hash-ref up-to-date (simple-form-path p) #f)
;; Use `compile-root' with `sha1-only?' as #t:
(compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen))
[(or (let ([p (simple-form-path p)])
(or (hash-ref up-to-date p #f)
(hash-ref up-to-date (cons 'assume p) #f)))
(compile-root #:sha1-only? #t
path->mode roots p up-to-date collection-cache read-src-syntax seen))
=> (lambda (sh)
(cons (cons (cdr sh) dep) l))]
[must-exist?
@ -234,13 +264,27 @@
(cons 'ext d)))
external-deps))])
(write (list* (version)
(system-type 'vm)
(current-compile-target-machine)
(cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash()))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #hash()
#:must-exist? #t))
(sort deps s-exp<?))
op)
(newline op))))))
(define (write-updated-deps deps assume-compiled-sha1 path->mode roots path)
(let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")])
(with-compile-output dep-path
(lambda (op tmp-path)
(write (list* (version)
(current-compile-target-machine)
(cons (deps-src-sha1 deps)
(cons (deps-imports-sha1 deps)
assume-compiled-sha1))
(deps-imports deps))
op)
(newline op)))))
(define (s-exp<? a b)
(string<? (format "~s" a) (format "~s" b)))
@ -271,7 +315,10 @@
(define-struct file-dependency (path module?) #:prefab)
(define-struct (file-dependency/options file-dependency) (table) #:prefab)
(define (compile-zo* path->mode roots path src-sha1 read-src-syntax orig-zo-name up-to-date collection-cache)
(define (compile-zo* path->mode roots path src-sha1 read-src-syntax orig-zo-name up-to-date collection-cache
#:recompile-from recompile-from
#:assume-compiled-sha1 assume-compiled-sha1
#:use-existing-deps use-existing-deps)
;; The `path' argument has been converted to .rkt or .ss form,
;; as appropriate.
;; External dependencies registered through reader guard and
@ -338,10 +385,17 @@
(with-continuation-mark
managed-compiled-context-key
path
(cond
[recompile-from
(recompile-module-code recompile-from
path
use-existing-deps
collection-cache)]
[else
(get-module-code path (path->mode path) compile
(lambda (a b) #f) ; extension handler
#:roots (list (car roots))
#:source-reader read-src-syntax))))
#:source-reader read-src-syntax)]))))
(define dest-roots (list (car roots)))
(define-values (code-dir code-name)
(get-compilation-dir+name path #:modes (list (path->mode path)) #:roots dest-roots))
@ -374,7 +428,8 @@
(with-handlers ([exn:fail?
(lambda (ex)
(close-output-port out)
(compilation-failure path->mode dest-roots path zo-name #f
(compilation-failure path->mode dest-roots path zo-name recompile-from
#f
(exn-message ex))
(raise ex))])
(parameterize ([current-write-relative-directory
@ -407,11 +462,31 @@
;; Note that we check time and write .deps before returning from
;; with-compile-output...
(verify-times path tmp-name)
(cond
[use-existing-deps
(write-updated-deps use-existing-deps assume-compiled-sha1 path->mode roots path)]
[else
(write-deps code path->mode dest-roots path src-sha1
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)))
up-to-date collection-cache read-src-syntax)])))
(trace-printf "wrote zo file: ~a" zo-name)))
(define (recompile-module-code recompile-from src-path deps collection-cache)
;; Force potential recompilation of dependencies. Otherwise, we
;; end up relying on cross-module optimization demands, which might
;; not happen and are unlikely to cover everything.
(for ([d (in-list (deps-imports deps))]
#:unless (external-dep? d))
(define path (collects-relative*->path (dep->encoded-path d) collection-cache))
(module-path-index-resolve (module-path-index-join path #f) #t))
;; Recompile the module:
(define-values (base name dir?) (split-path src-path))
(parameterize ([current-load-relative-directory
(if (path? base) base (current-directory))])
(define code (parameterize ([read-accept-compiled #t])
(call-with-input-file* recompile-from read)))
(compiled-expression-recompile code)))
(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)))
@ -449,62 +524,118 @@
alt-path
path))))
(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen)
;; If `trying-sha1?`, then don't actually compile, but return a
;; boolean indicating whether a build is needed. Otherwise, actually
;; build if the compiled form is out of date, and return #f to report
;; that no further build is needed.
(define (maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen
#:trying-sha1? [trying-sha1? #f])
(let ([actual-path (actual-source-path orig-path)])
(unless sha1-only?
(unless trying-sha1?
((manager-compile-notify-handler) actual-path)
(trace-printf "maybe-compile-zo starting ~a" actual-path))
(begin0
(parameterize ([indent (+ 2 (indent))])
(let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(begin
(cond
[(and zo-exists? (trust-existing-zos))
(trace-printf "trusting: ~a" zo-name)
(touch zo-name)
#f)
(let ([src-sha1 (and zo-exists?
deps
(caddr deps)
(get-source-sha1 path))])
(if (and zo-exists?
src-sha1
(equal? src-sha1 (and (pair? (caddr deps))
(caaddr deps)))
(equal? (get-dep-sha1s (cdddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen)
(cdaddr deps)))
(begin
(trace-printf "hash-equivalent: ~a" zo-name)
(touch zo-name)
#f)
((if sha1-only? values (lambda (build) (build) #f))
(lambda ()
(let* ([lc (parallel-lock-client)]
[_ (when lc (log-compile-event path 'locking))]
[locked? (and lc (lc 'lock zo-name))]
[ok-to-compile? (or (not lc) locked?)])
#f]
[else
(define (build #:recompile-from [recompile-from #f]
#:assume-compiled-sha1 [assume-compiled-sha1 #f]
#:use-existing-deps [use-existing-deps #f])
(define lc (parallel-lock-client))
(when lc (log-compile-event path 'locking))
(define locked? (and lc (lc 'lock zo-name)))
(define ok-to-compile? (or (not lc) locked?))
(dynamic-wind
(lambda () (void))
(lambda ()
(when ok-to-compile?
(log-compile-event path 'start-compile)
(when zo-exists? (try-delete-file zo-name #f))
(trace-printf "compiling ~a" actual-path)
(log-compile-event path (if recompile-from 'start-recompile 'start-compile))
(when zo-exists?
(unless (equal? zo-name recompile-from)
(try-delete-file zo-name #f)))
(trace-printf "~acompiling ~a" (if recompile-from "re" "") actual-path)
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(with-handlers ([exn:get-module-code?
(lambda (ex)
(compilation-failure path->mode roots path zo-name
(compilation-failure path->mode roots path zo-name recompile-from
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache)))
(trace-printf "compiled ~a" actual-path)))
(compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache
#:recompile-from recompile-from
#:assume-compiled-sha1 assume-compiled-sha1
#:use-existing-deps use-existing-deps)))
(trace-printf "~acompiled ~a" (if recompile-from "re" "") actual-path)))
(lambda ()
(log-compile-event path (if (or (not lc) locked?) 'finish-compile 'already-done))
(log-compile-event path (if (or (not lc) locked?)
(if recompile-from 'finish-recompile 'finish-compile)
'already-done))
(when locked?
(lc 'unlock zo-name))))))))))))
(unless sha1-only?
(lc 'unlock zo-name))))
#f)
(define (build/recompile)
(build #:recompile-from zo-name
#:assume-compiled-sha1 (or (deps-assume-compiled-sha1 deps)
(call-with-input-file* zo-name sha1))
#:use-existing-deps deps))
(define src-sha1 (and zo-exists?
deps
(deps-src-sha1 deps)
(get-source-sha1 path)))
(cond
[(and zo-exists?
(not src-sha1)
(not (file-exists? actual-path)))
;; If we have bytecode but not source, then maybe we need to recompile.
(cond
[(not (equal? (deps-machine deps) (current-compile-target-machine)))
;; We'd like to recompile, but that should end up with the same reported hash,
;; so we don't need to rebuild if just looking kfor the hash.
(cond
[trying-sha1? #f]
[else (build/recompile)])]
[else
;; No need to build
#f])]
[(and zo-exists?
src-sha1
(equal? src-sha1 (and (pair? (deps-sha1s deps))
(deps-src-sha1 deps)))
(equal? (get-dep-sha1s (deps-imports deps) up-to-date collection-cache read-src-syntax path->mode roots seen
#:must-exist? #f)
(deps-imports-sha1 deps))
(or (equal? (deps-machine deps) (current-compile-target-machine))
(not (deps-machine deps))))
(trace-printf "hash-equivalent: ~a" zo-name)
(cond
[(equal? (deps-machine deps) (current-compile-target-machine))
(touch zo-name)
#f]
[else
;; (deps-machine deps) is #f, so we can recompile machine-independent
;; bytecode to this machine's format
(cond
[trying-sha1?
;; We're not supposed to build now, so claim that it's already built.
;; If we claimed that it needed to be built, then a dependent module
;; would start compiling from scratch. But either recompiling or compiling
;; that module will cause this one to be recompiled (i.e., back here
;; with `trying-sha1?` as #f)
#f]
[else (build/recompile)])])]
[trying-sha1?
;; Needs to be built, but we can't build now
#t]
[else
;; Build
(build)])])))
(unless trying-sha1?
(trace-printf "maybe-compile-zo finished ~a" actual-path)))))
(define (get-compiled-time path->mode roots path)
@ -514,20 +645,40 @@
'so-suffix))))
(try-file-time (build-path dir (path-add-extension name #".zo")))))
;; Gets a multi-sha1 string that represents the compiled code
;; as well as its dependencies:
(define (try-file-sha1 path dep-path)
(with-module-reading-parameterization
(lambda ()
;; Extract sha1s from ".dep", if possible, including a sha1
;; that we should assume for the cmopiled form:
(define-values (imports-sha1 assume-compiled-sha1)
(with-handlers ([exn:fail:filesystem? (lambda (exn)
(values "" #f))])
(call-with-input-file*
dep-path
(lambda (p)
(define deps (read p))
(define ok-machine? (and (equal? (version) (deps-version deps))
(or (equal? (current-compile-target-machine) (deps-machine deps))
(not (deps-machine deps)))))
(values (or (and ok-machine?
(deps-imports-sha1 deps))
"")
(and ok-machine?
(deps-assume-compiled-sha1 deps)))))))
;; Combine the sha1 for the compiled form with the sha1 of imports;
;; if we have to read the compiled form and that fails (e.g., because
;; the file's not there), then return #f overall:
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(string-append
(call-with-input-file* path sha1)
(with-handlers ([exn:fail:filesystem? (lambda (exn) "")])
(call-with-input-file* dep-path (lambda (p)
(define deps (read p))
(or (and (equal? (version) (car deps))
(equal? (system-type 'vm) (cadr deps))
(cdaddr deps))
"")))))))))
(or assume-compiled-sha1 (call-with-input-file* path sha1))
imports-sha1)))))
;; Gets a multi-sha1 string that represents the compiled code
;; (plus dependencies), checking for a native library before
;; falling back normally to bytecode, and returning "" insteda of
;; #f if compiled code is not available:
(define (get-compiled-sha1 path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(let ([dep-path (build-path dir (path-add-extension name #".dep"))])
@ -541,8 +692,8 @@
(define (different-source-sha1-and-dep-recorded path deps)
(define src-hash (get-source-sha1 path))
(define recorded-hash (and (pair? (caddr deps))
(caaddr deps)))
(define recorded-hash (and (pair? (deps-sha1s deps))
(deps-src-sha1 deps)))
(if (equal? src-hash recorded-hash)
#f
(list src-hash recorded-hash)))
@ -552,10 +703,11 @@
(path-replace-extension p #".ss")
p))
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen)
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax seen
#:sha1-only? [sha1-only? #f])
(define orig-path (simple-form-path path0))
(define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) (system-type 'vm) '#f))])
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) (current-compile-target-machine) '(#f . #f)))])
(with-module-reading-parameterization
(lambda ()
(call-with-input-file*
@ -577,7 +729,12 @@
"dependency cycle\n involves module: ~a"
path)
#f]
[(not path-time)
[(and (not path-time)
;; Even though the source doesn't exist, maybe
;; platform-independent bytecode needs to be recompiled,
;; so check that:
(or (not (current-compile-target-machine))
(deps-machine (read-deps path))))
(trace-printf "~a does not exist" orig-path)
(or (hash-ref up-to-date orig-path #f)
(let ([stamp (cons (or path-zo-time +inf.0)
@ -589,24 +746,26 @@
[else
(let ([deps (read-deps path)]
[new-seen (hash-set seen path #t)])
(define build
(define needs-build?
(cond
[(not (and (pair? deps)
(equal? (version) (car deps))
(pair? (cdr deps))
(equal? (system-type 'vm) (cadr deps))))
(lambda ()
[(not (and (deps-has-version? deps)
(equal? (version) (deps-version deps))))
(trace-printf "newer version...")
(maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
#t]
[(not (and (deps-has-machine? deps)
(or (equal? (current-compile-target-machine) (deps-machine deps))
(and sha1-only? (not (deps-machine deps))))))
(trace-printf "different machine...")
#t]
[(> path-time (or path-zo-time -inf.0))
(trace-printf "newer src... ~a > ~a" path-time path-zo-time)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
#:trying-sha1? sha1-only?)]
[(different-source-sha1-and-dep-recorded path deps)
=> (lambda (difference)
(trace-printf "different src hash... ~a" difference)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
#:trying-sha1? sha1-only?))]
[(ormap-strict
(lambda (p)
(define ext? (external-dep? p))
@ -614,28 +773,43 @@
(define t
(if ext?
(cons (or (try-file-time d) +inf.0) #f)
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen)))
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax new-seen)))
(and t
(car t)
(> (car t) (or path-zo-time -inf.0))
(begin (trace-printf "newer: ~a (~a > ~a)..."
d (car t) path-zo-time)
#t)))
(cdddr deps))
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
(deps-imports deps))
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
#:trying-sha1? sha1-only?)]
[else #f]))
(cond
[(and build sha1-only?) #f]
[(and needs-build? sha1-only?) #f]
[else
(when build (build))
(when needs-build?
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))
(let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0)
(delay (get-compiled-sha1 path->mode roots path)))])
(hash-set! up-to-date main-path stamp)
(when (or needs-build?
;; If `(deps-machine deps)` is #f and doesn't match the current machine,
;; then we still need to build.
(equal? (current-compile-target-machine) (deps-machine deps)))
(define (make-key p)
(if (or needs-build?
(equal? (current-compile-target-machine) (deps-machine deps)))
p
;; We didn't actually recompile, yet, so don't record the path
;; as done. But record an "assume" sha1-stamp, so we don't keep
;; computing it.
(cons 'assume p)))
(hash-set! up-to-date (make-key main-path) stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
(hash-set! up-to-date (make-key alt-path) stamp)))
stamp)]))])))
(or (hash-ref up-to-date orig-path #f)
(and sha1-only?
(hash-ref up-to-date (cons 'assume orig-path) #f))
(let ([v ((manager-skip-file-handler) orig-path)])
(and v
(hash-set! up-to-date orig-path v)
@ -675,7 +849,6 @@
cache
collection-cache
read-src-syntax
#f
#hash())
(void)))))
@ -753,7 +926,7 @@
[else
(trace-printf "processing: ~a" path)
(parameterize ([compiler-security-guard security-guard])
(compile-root path->mode roots path cache collection-cache read-syntax #f #hash()))
(compile-root path->mode roots path cache collection-cache read-syntax #hash()))
(trace-printf "done: ~a" path)])
(default-handler path mod-name))
(when (null? roots)