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 collection 'multi)
(define version "7.5.0.9") (define version "7.5.0.10")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["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 ;; Check to make we're using a build of Chez Scheme
;; that has all the features we need. ;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev) (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)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file (error 'compile-file

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

@ -68,7 +68,9 @@
(only (io) (only (io)
path? path?
complete-path? complete-path?
split-path
path->string path->string
path-element->string
path->bytes path->bytes
bytes->path bytes->path
string->bytes/utf-8 string->bytes/utf-8
@ -96,7 +98,6 @@
write-bytes write-bytes
flush-output flush-output
read-bytes read-bytes
split-path
path->complete-path path->complete-path
file-exists?) file-exists?)
(only (thread) (only (thread)
@ -573,7 +574,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))]) (let ([a (correlated->annotation (xify expr) serializable?)])
(make-wrapped-code (if serializable? (make-wrapped-code (if serializable?
(add-code-hash a) (add-code-hash a)
a) a)
@ -589,7 +590,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)))]) (show lambda-on? "lambda" (correlated->annotation expr serializable?)))])
(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))))])))]))
@ -604,7 +605,7 @@
[else (show "schemified" impl-lam/paths)])]) [else (show "schemified" impl-lam/paths)])])
(if jitify-mode? (if jitify-mode?
(interpretable-jitified-linklet impl-lam correlated->datum) (interpretable-jitified-linklet impl-lam correlated->datum)
(correlated->annotation impl-lam)))) (correlated->annotation impl-lam serializable?))))
(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? (not jitify-mode?)) (when (and cp0-on? (not jitify-mode?))

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

@ -1,18 +1,21 @@
(define (correlated->annotation v) (define correlated->annotation
(let-values ([(e stripped-e) (correlated->annotation* v)]) (case-lambda
e)) [(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 (cond
[(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))] [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v) serializable?)]
[(d stripped-d) (correlated->annotation* (cdr v))]) [(d stripped-d) (correlated->annotation* (cdr v) serializable?)])
(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))]) [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v) serializable?)])
(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)
@ -24,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))) (add-name (transfer-srcloc v e stripped-e serializable?)))
(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
@ -39,7 +42,7 @@
[(symbol? name) name] [(symbol? name) name]
[else default-name]))) [else default-name])))
(define (transfer-srcloc v e stripped-e) (define (transfer-srcloc v e stripped-e serializable?)
(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)]
@ -50,21 +53,45 @@
(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) pos (+ pos span) line (add1 column)) (make-source-object (source->sfd src serializable?) 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)))
stripped-e)) stripped-e))
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) (define (source->sfd src serializable?)
(let ([sfd-cache (unsafe-place-local-ref sfd-cache-box)]) (let* ([sfd-cache-box (if serializable? sfd-cache-box/ser sfd-cache-box/unser)]
[sfd-cache (unsafe-place-local-ref sfd-cache-box)])
(cond (cond
[sfd-cache [sfd-cache
(or (hash-ref sfd-cache src #f) (or (hash-ref sfd-cache src #f)
(let ([str (if (path? src) (let ([str (cond
(path->string src) [serializable?
src)]) ;; 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 ;; We'll use a file-position object in source objects, so
;; the sfd checksum doesn't matter ;; the sfd checksum doesn't matter
(let ([sfd (source-file-descriptor str 0)]) (let ([sfd (source-file-descriptor str 0)])
@ -74,7 +101,7 @@
;; 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)) (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 [else
(let-values ([(key v) (hash-iterate-key+value orig-ht i)]) (let-values ([(key v) (hash-iterate-key+value orig-ht i)])
(when (linklet? v) (check-fasl-preparation v)) (when (linklet? v) (check-fasl-preparation v))
(let ([new-v (if (and (linklet? v) (let ([new-v (cond
(pair? (linklet-paths v))) [(linklet? v)
(cond
[(pair? (linklet-paths v))
(adjust-cross-perparation (adjust-cross-perparation
(set-linklet-paths (set-linklet-paths
v v
(map path->compiled-path (map path->compiled-path
(linklet-paths v)))) (linklet-paths v))))]
v)]) [else (adjust-cross-perparation v)])]
[else v])])
(when (linklet? new-v) (when (linklet? new-v)
(linklet-pack-exports-info! new-v)) (linklet-pack-exports-info! new-v))
(let ([new-ht (if (eq? v 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_X 7
#define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Y 5
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 9 #define MZSCHEME_VERSION_W 10
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x