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?
(and (not serializable?)
(#%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
'schemify
(define jitify-mode?
@ -604,7 +609,7 @@
[(jit)
;; Preserve annotated `lambda` source for on-demand compilation:
(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?
(add-code-hash a)
a)
@ -620,7 +625,7 @@
(lambda (s) (cross-compile cross-machine s))
compile*-to-bytevector)
compile*)
(show lambda-on? "lambda" (correlated->annotation expr serializable?)))])
(show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache)))])
(if serializable?
(make-wrapped-code code arity-mask (extract-inferred-name expr name))
code))))])))]))
@ -635,7 +640,7 @@
[else (show "schemified" impl-lam/paths)])])
(if (eq? format 'interpret)
(interpretable-jitified-linklet impl-lam serializable?)
(correlated->annotation impl-lam serializable?))))
(correlated->annotation impl-lam serializable? sfd-cache))))
(when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (eq? format 'compile))

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

@ -1,21 +1,21 @@
(define correlated->annotation
(case-lambda
[(v serializable?)
(let-values ([(e stripped-e) (correlated->annotation* v serializable?)])
[(v serializable? sfd-cache)
(let-values ([(e stripped-e) (correlated->annotation* v serializable? sfd-cache)])
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
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable?)]
[(d stripped-d) (correlated->annotation* (cdr v) serializable?)])
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable? sfd-cache)]
[(d stripped-d) (correlated->annotation* (cdr v) serializable? sfd-cache)])
(cond
[(and (eq? a (car v))
(eq? d (cdr v)))
(values v v)]
[else (values (cons a 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)]
[method-arity-error (correlated-property v 'method-arity-error)])
(define (add-name e)
@ -27,7 +27,7 @@
`(|#%method-arity| ,e)
e))
(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-name stripped-e)))))]
;; correlated will be nested only in pairs with current expander
@ -42,7 +42,7 @@
[(symbol? name) 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)]
[pos (correlated-position v)]
[line (correlated-line v)]
@ -53,55 +53,57 @@
(make-annotation e
(if (and line column)
;; 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?) pos (+ pos span)))
(make-source-object (source->sfd src serializable? sfd-cache) pos (+ pos span) line (add1 column))
(make-source-object (source->sfd src serializable? sfd-cache) pos (+ pos span)))
stripped-e))
e)))
(define sfd-cache-box/ser (unsafe-make-place-local #f))
(define sfd-cache-box/unser (unsafe-make-place-local #f))
(define sfd-cache-box (unsafe-make-place-local #f))
(define (source->sfd src serializable?)
(let* ([sfd-cache-box (if serializable? sfd-cache-box/ser sfd-cache-box/unser)]
[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
(define (get-nonserializable-sfd-cache)
(or (unsafe-place-local-ref sfd-cache-box)
;; There's a race here at the level of Racket threads,
;; but that seems ok for setting up a cache
(unsafe-place-local-set! sfd-cache-box (make-weak-hash))
(source->sfd src serializable?)])))
(let ([cache (make-weak-hash)])
(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))))
;; --------------------------------------------------