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

cs: fix issues with source->sfd cache

Browse Source 
The cache wasn't kill-safe, and probably a weak cache could also lead
to non-determinism of source-path sharing across submodules.

Related to #3193
This commit is contained in:
Matthew Flatt 2020-05-20 08:29:56 -06:00
parent 07d3f3a2ec
commit 9ba5fd6a0f
2 changed files with 62 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
racket/src/cs/linklet.sls
View File

@ -549,6 +549,11 @@
(define quick-mode? (or default-compile-quick? (define quick-mode? (or default-compile-quick?
(and (not serializable?) (and (not serializable?)
(#%memq 'quick options)))) (#%memq 'quick options))))
(define sfd-cache (if serializable?
;; For determinism: a fresh, non-weak cache per linklet
(make-hash)
;; For speed and more flexible sharing: a weak, place-local cache
(get-nonserializable-sfd-cache)))
(performance-region (performance-region
'schemify 'schemify
(define jitify-mode? (define jitify-mode?
@ -604,7 +609,7 @@
[(jit) [(jit)
;; Preserve annotated `lambda` source for on-demand compilation: ;; Preserve annotated `lambda` source for on-demand compilation:
(lambda (expr arity-mask name) (lambda (expr arity-mask name)
(let ([a (correlated->annotation (xify expr) serializable?)]) (let ([a (correlated->annotation (xify expr) serializable? sfd-cache)])
(make-wrapped-code (if serializable? (make-wrapped-code (if serializable?
(add-code-hash a) (add-code-hash a)
a) a)
@ -620,7 +625,7 @@
(lambda (s) (cross-compile cross-machine s)) (lambda (s) (cross-compile cross-machine s))
compile*-to-bytevector) compile*-to-bytevector)
compile*) compile*)
(show lambda-on? "lambda" (correlated->annotation expr serializable?)))]) (show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache)))])
(if serializable? (if serializable?
(make-wrapped-code code arity-mask (extract-inferred-name expr name)) (make-wrapped-code code arity-mask (extract-inferred-name expr name))
code))))])))])) code))))])))]))
@ -635,7 +640,7 @@
[else (show "schemified" impl-lam/paths)])]) [else (show "schemified" impl-lam/paths)])])
(if (eq? format 'interpret) (if (eq? format 'interpret)
(interpretable-jitified-linklet impl-lam serializable?) (interpretable-jitified-linklet impl-lam serializable?)
(correlated->annotation impl-lam serializable?)))) (correlated->annotation impl-lam serializable? sfd-cache))))
(when known-on? (when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v))))) (show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (eq? format 'compile)) (when (and cp0-on? (eq? format 'compile))

106
racket/src/cs/linklet/annotation.ss
View File

@ -1,21 +1,21 @@
(define correlated->annotation (define correlated->annotation
(case-lambda (case-lambda
[(v serializable?) [(v serializable? sfd-cache)
(let-values ([(e stripped-e) (correlated->annotation* v serializable?)]) (let-values ([(e stripped-e) (correlated->annotation* v serializable? sfd-cache)])
e)] e)]
[(v) (correlated->annotation v #f)])) [(v) (correlated->annotation v #f (get-nonserializable-sfd-cache))]))
(define (correlated->annotation* v serializable?) (define (correlated->annotation* v serializable? sfd-cache)
(cond (cond
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable?)] [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable? sfd-cache)]
[(d stripped-d) (correlated->annotation* (cdr v) serializable?)]) [(d stripped-d) (correlated->annotation* (cdr v) serializable? sfd-cache)])
(cond (cond
[(and (eq? a (car v)) [(and (eq? a (car v))
(eq? d (cdr v))) (eq? d (cdr v)))
(values v v)] (values v v)]
[else (values (cons a d) [else (values (cons a d)
(cons stripped-a stripped-d))]))] (cons stripped-a stripped-d))]))]
[(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v) serializable?)]) [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v) serializable? sfd-cache)])
(let ([name (correlated-property v 'inferred-name)] (let ([name (correlated-property v 'inferred-name)]
[method-arity-error (correlated-property v 'method-arity-error)]) [method-arity-error (correlated-property v 'method-arity-error)])
(define (add-name e) (define (add-name e)
@ -27,7 +27,7 @@
`(|#%method-arity| ,e) `(|#%method-arity| ,e)
e)) e))
(values (add-method-arity-error (values (add-method-arity-error
(add-name (transfer-srcloc v e stripped-e serializable?))) (add-name (transfer-srcloc v e stripped-e serializable? sfd-cache)))
(add-method-arity-error (add-method-arity-error
(add-name stripped-e)))))] (add-name stripped-e)))))]
;; correlated will be nested only in pairs with current expander ;; correlated will be nested only in pairs with current expander
@ -42,7 +42,7 @@
[(symbol? name) name] [(symbol? name) name]
[else default-name]))) [else default-name])))
(define (transfer-srcloc v e stripped-e serializable?) (define (transfer-srcloc v e stripped-e serializable? sfd-cache)
(let ([src (correlated-source v)] (let ([src (correlated-source v)]
[pos (correlated-position v)] [pos (correlated-position v)]
[line (correlated-line v)] [line (correlated-line v)]
@ -53,55 +53,57 @@
(make-annotation e (make-annotation e
(if (and line column) (if (and line column)
;; Racket columns are 0-based; host-Scheme columns are 1-based ;; Racket columns are 0-based; host-Scheme columns are 1-based
(make-source-object (source->sfd src serializable?) pos (+ pos span) line (add1 column)) (make-source-object (source->sfd src serializable? sfd-cache) pos (+ pos span) line (add1 column))
(make-source-object (source->sfd src serializable?) pos (+ pos span))) (make-source-object (source->sfd src serializable? sfd-cache) pos (+ pos span)))
stripped-e)) stripped-e))
e))) e)))
(define sfd-cache-box/ser (unsafe-make-place-local #f)) (define sfd-cache-box (unsafe-make-place-local #f))
(define sfd-cache-box/unser (unsafe-make-place-local #f))
(define (source->sfd src serializable?) (define (get-nonserializable-sfd-cache)
(let* ([sfd-cache-box (if serializable? sfd-cache-box/ser sfd-cache-box/unser)] (or (unsafe-place-local-ref sfd-cache-box)
[sfd-cache (unsafe-place-local-ref sfd-cache-box)])
(cond
[sfd-cache
(or (hash-ref sfd-cache src #f)
(let ([str (cond
[serializable?
;; Making paths to record for procedure obey
;; `current-write-relative-directory`, etc., is
;; difficult --- a lot of work for something that
;; shows up only in stack traces. So, just keep a
;; couple of path elements
(let-values ([(base name dir?) (split-path src)])
(cond
[(or (not (path? name))
(not base))
"..."]
[(path? base)
(let-values ([(base name2 dir?) (split-path base)])
(cond
[(and (path? name2)
base)
(string-append ".../" (path-element->string name2)
"/" (path-element->string name))]
[else
(string-append ".../" (path-element->string name))]))]
[else
(string-append ".../" (path-element->string name))]))]
[(path? src) (path->string src)]
[else src])])
;; We'll use a file-position object in source objects, so
;; the sfd checksum doesn't matter
(let ([sfd (source-file-descriptor str 0)])
(hash-set! sfd-cache src sfd)
sfd)))]
[else
;; There's a race here at the level of Racket threads, ;; There's a race here at the level of Racket threads,
;; but that seems ok for setting up a cache ;; but that seems ok for setting up a cache
(unsafe-place-local-set! sfd-cache-box (make-weak-hash)) (let ([cache (make-weak-hash)])
(source->sfd src serializable?)]))) (unsafe-place-local-set! sfd-cache-box cache)
;; Use this cache only with interrupts disabled, otherwise
;; it's not kill-safe
cache)))
(define (source->sfd src serializable? sfd-cache)
(or (with-interrupts-disabled
(hash-ref sfd-cache src #f))
(let ([str (cond
[serializable?
;; Making paths to record for procedure obey
;; `current-write-relative-directory`, etc., is
;; difficult --- a lot of work for something that
;; shows up only in stack traces. So, just keep a
;; couple of path elements
(let-values ([(base name dir?) (split-path src)])
(cond
[(or (not (path? name))
(not base))
"..."]
[(path? base)
(let-values ([(base name2 dir?) (split-path base)])
(cond
[(and (path? name2)
base)
(string-append ".../" (path-element->string name2)
"/" (path-element->string name))]
[else
(string-append ".../" (path-element->string name))]))]
[else
(string-append ".../" (path-element->string name))]))]
[(path? src) (path->string src)]
[else src])])
;; We'll use a file-position object in source objects, so
;; the sfd checksum doesn't matter
(let ([sfd (source-file-descriptor str 0)])
(with-interrupts-disabled
(hash-set! sfd-cache src sfd))
sfd))))
;; -------------------------------------------------- ;; --------------------------------------------------