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

cs: avoid full paths attached to functions

Browse Source 
Source locations are attached to functions for backtraces. With
traditional Racket, those source locations are connected to the
machinery of `current-write-relative-directory` and
`current-load-relative-directory` to avoid absolute paths, but that
machinery is difficult to integrate into the Racket CS compilation
model. So, since they're "just" for stack traces, save only a couple
of elements of the path.
This commit is contained in:
Matthew Flatt 2019-12-06 09:49:42 -07:00
parent f664483c05
commit baab2b9974
6 changed files with 60 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.5.0.9")
(define version "7.5.0.10")
(define deps `("racket-lib"
["racket" #:version ,version]))

2
racket/src/cs/compile-file.ss
View File

@ -2,7 +2,7 @@
;; Check to make we're using a build of Chez Scheme
;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev)
(values 9 5 3 6))
(values 9 5 3 7))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

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

@ -68,7 +68,9 @@
(only (io)
path?
complete-path?
split-path
path->string
path-element->string
path->bytes
bytes->path
string->bytes/utf-8
@ -96,7 +98,6 @@
write-bytes
flush-output
read-bytes
split-path
path->complete-path
file-exists?)
(only (thread)
@ -573,7 +574,7 @@
[(jit)
;; Preserve annotated `lambda` source for on-demand compilation:
(lambda (expr arity-mask name)
(let ([a (correlated->annotation (xify expr))])
(let ([a (correlated->annotation (xify expr) serializable?)])
(make-wrapped-code (if serializable?
(add-code-hash a)
a)
@ -589,7 +590,7 @@
(lambda (s) (cross-compile cross-machine s))
compile*-to-bytevector)
compile*)
(show lambda-on? "lambda" (correlated->annotation expr)))])
(show lambda-on? "lambda" (correlated->annotation expr serializable?)))])
(if serializable?
(make-wrapped-code code arity-mask (extract-inferred-name expr name))
code))))])))]))
@ -604,7 +605,7 @@
[else (show "schemified" impl-lam/paths)])])
(if jitify-mode?
(interpretable-jitified-linklet impl-lam correlated->datum)
(correlated->annotation impl-lam))))
(correlated->annotation impl-lam serializable?))))
(when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (not jitify-mode?))

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

@ -1,18 +1,21 @@
(define (correlated->annotation v)
(let-values ([(e stripped-e) (correlated->annotation* v)])
e))
(define correlated->annotation
(case-lambda
[(v serializable?)
(let-values ([(e stripped-e) (correlated->annotation* v serializable?)])
e)]
[(v) (correlated->annotation v #f)]))
(define (correlated->annotation* v)
(define (correlated->annotation* v serializable?)
(cond
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))]
[(d stripped-d) (correlated->annotation* (cdr v))])
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable?)]
[(d stripped-d) (correlated->annotation* (cdr v) serializable?)])
(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))])
[(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v) serializable?)])
(let ([name (correlated-property v 'inferred-name)]
[method-arity-error (correlated-property v 'method-arity-error)])
(define (add-name e)
@ -24,7 +27,7 @@
`(|#%method-arity| ,e)
e))
(values (add-method-arity-error
(add-name (transfer-srcloc v e stripped-e)))
(add-name (transfer-srcloc v e stripped-e serializable?)))
(add-method-arity-error
(add-name stripped-e)))))]
;; correlated will be nested only in pairs with current expander
@ -39,7 +42,7 @@
[(symbol? name) name]
[else default-name])))
(define (transfer-srcloc v e stripped-e)
(define (transfer-srcloc v e stripped-e serializable?)
(let ([src (correlated-source v)]
[pos (correlated-position v)]
[line (correlated-line v)]
@ -50,21 +53,45 @@
(make-annotation e
(if (and line column)
;; Racket columns are 0-based; host-Scheme columns are 1-based
(make-source-object (source->sfd src) pos (+ pos span) line (add1 column))
(make-source-object (source->sfd src) pos (+ pos span)))
(make-source-object (source->sfd src serializable?) pos (+ pos span) line (add1 column))
(make-source-object (source->sfd src serializable?) pos (+ pos span)))
stripped-e))
e)))
(define sfd-cache-box (unsafe-make-place-local #f))
(define sfd-cache-box/ser (unsafe-make-place-local #f))
(define sfd-cache-box/unser (unsafe-make-place-local #f))
(define (source->sfd src)
(let ([sfd-cache (unsafe-place-local-ref sfd-cache-box)])
(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 (if (path? src)
(path->string src)
src)])
(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)])
@ -74,7 +101,7 @@
;; 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)])))
(source->sfd src serializable?)])))
;; --------------------------------------------------

11
racket/src/cs/linklet/write.ss
View File

@ -21,14 +21,17 @@
[else
(let-values ([(key v) (hash-iterate-key+value orig-ht i)])
(when (linklet? v) (check-fasl-preparation v))
(let ([new-v (if (and (linklet? v)
(pair? (linklet-paths v)))
(let ([new-v (cond
[(linklet? v)
(cond
[(pair? (linklet-paths v))
(adjust-cross-perparation
(set-linklet-paths
v
(map path->compiled-path
(linklet-paths v))))
v)])
(linklet-paths v))))]
[else (adjust-cross-perparation v)])]
[else v])])
(when (linklet? new-v)
(linklet-pack-exports-info! new-v))
(let ([new-ht (if (eq? v new-v)

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 5
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_W 10
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x