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

cs: support source-location paths in compiled code

Browse Source 
Procedures in compiled code could not previously have source-location
paths that are managed through the write-relative and load-directory
configuration. Instead, paths were always converted to strings that
start "..." --- and those strings were sometimes incorrectly converted
back to paths in context information extracted from a continuation
mark set.

This commit takes advantage of changes to Chez Scheme `fasl-write` and
`fasl-read` (and related for compiling code) to lift paths out where
linklet-level marshaling can take care of them.
This commit is contained in:
Matthew Flatt 2020-07-14 18:09:00 -06:00
parent c135647d9c
commit 454a586a79
13 changed files with 211 additions and 143 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.8.0.3")
(define version "7.8.0.4")
(define deps `("racket-lib"
["racket" #:version ,version]))

70
racket/src/cs/c/cross-serve.ss
View File

@ -32,27 +32,71 @@
(unless (eof-object? cmd)
(get-u8 in) ; newline
(let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths
(case (integer->char cmd)
[(#\c)
(compile-to-port (list `(lambda () ,(read-fasled in))) o)]
(call-with-fasled
in
(lambda (v pred)
(compile-to-port (list `(lambda () ,v)) o #f #f #f (string->symbol target) #f pred)))]
[(#\f)
;; Reads host fasl format, then writes target fasl format
(let ([v (read-fasled in)])
(call-with-fasled
in
(lambda (v pred)
(parameterize ([#%$target-machine (string->symbol target)])
(fasl-write v o)))]
(fasl-write v o pred))))]
[else
(error 'serve-cross-compile (format "unrecognized command: ~s" cmd))])
(let ([result (get)]
[len-bv (make-bytevector 8)])
(bytevector-u64-set! len-bv 0 (bytevector-length result) (endianness little))
(put-bytevector out len-bv)
(error 'serve-cross-compile (format "unrecognized command: ~s" cmd))])])
(let ([result (get)])
(put-num out (bytevector-length result))
(put-bytevector out result)
(let ([len (vector-length sfd-paths)])
(put-num out len)
(let loop ([i 0])
(unless (fx= i len)
(put-num out (vector-ref sfd-paths i))
(loop (fx+ i 1)))))
(flush-output-port out)))
(loop))))))
(loop)))))))
;; ----------------------------------------
(define (read-fasled in)
(let ([len-bv (get-bytevector-n in 8)])
(fasl-read (open-bytevector-input-port
(get-bytevector-n in (bytevector-u64-ref len-bv 0 (endianness little)))))))
(define (put-num out n)
(let ([bv (make-bytevector 8)])
(bytevector-u64-set! bv 0 n (endianness little))
(put-bytevector out bv)))
(define (get-num in)
(let ([bv (get-bytevector-n in 8)])
(bytevector-u64-ref bv 0 (endianness little))))
;; ----------------------------------------
(define-record-type path-placeholder
(fields pos))
(define (call-with-fasled in proc)
(let* ([fasled-bv (get-bytevector-n in (get-num in))]
[num-sfd-paths (get-num in)]
[sfd-paths (list->vector
(let loop ([i 0])
(if (fx= i num-sfd-paths)
'()
(cons (make-path-placeholder i)
(loop (fx+ i 1))))))]
[used-placeholders '()]
;; v is the Chez Scheme value communicated from the client,
;; but with each path replace by a `path-placeholder`:
[v (fasl-read (open-bytevector-input-port fasled-bv)
'load
sfd-paths)])
(proc v
(lambda (a)
(and (path-placeholder? a)
(begin
(set! used-placeholders (cons a used-placeholders))
#t))))
;; Return indices of paths used in new fasled output, in the
;; order that they're used
(list->vector (map path-placeholder-pos used-placeholders))))

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 33))
(values 9 5 3 34))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

1
racket/src/cs/io.sls
View File

@ -526,6 +526,5 @@
(set-make-async-callback-poll-wakeup! unsafe-make-signal-received)
(set-get-machine-info! get-machine-info)
(set-processor-count! (1/processor-count))
(set-convert-source-file-descriptor-path! 1/string->path)
(install-future-logging-procs! logging-future-events? log-future-event)
(install-place-logging-procs! logging-place-events? log-place-event))

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

@ -235,14 +235,32 @@
(call-with-system-wind (lambda () (interpret e))))
(define (fasl-write* s o)
(call-with-system-wind (lambda () (fasl-write s o))))
(define (fasl-write/paths* s o)
(call-with-system-wind (lambda ()
(call-getting-sfd-paths
(lambda (pred)
(fasl-write s o pred))))))
(define (fasl-write-code* s o)
(call-with-system-wind (lambda ()
(parameterize ([fasl-compressed compress-code?])
(fasl-write s o)))))
(call-getting-sfd-paths
(lambda (pred)
(fasl-write s o pred 'omit-rtds)))))))
(define (compile-to-port* s o)
(call-with-system-wind (lambda ()
(parameterize ([fasl-compressed compress-code?])
(compile-to-port s o)))))
(call-getting-sfd-paths
(lambda (pred)
(compile-to-port s o #f #f #f (machine-type) #f pred 'omit-rtds)))))))
(define (call-getting-sfd-paths proc)
(let ([sfd-paths '()])
(proc (lambda (v)
(and (path? v)
(begin
(set! sfd-paths (cons v sfd-paths))
#t))))
(list->vector (reverse sfd-paths))))
(define (eval/foreign e mode)
(performance-region
@ -275,55 +293,58 @@
proc
(#%apply proc paths)))))
;; returns code bytevector and sfd-paths vector
(define (compile*-to-bytevector s)
(let-values ([(o get) (open-bytevector-output-port)])
(compile-to-port* (list `(lambda () ,s)) o)
(get)))
(let ([sfd-paths (compile-to-port* (list `(lambda () ,s)) o)])
(values (get) sfd-paths))))
(define (compile-to-bytevector s paths format)
;; returns code bytevector and sfd-paths vector
(define (compile-to-bytevector s format)
(cond
[(eq? format 'interpret)
(let-values ([(o get) (open-bytevector-output-port)])
(fasl-write-code* s o)
(get))]
(let ([sfd-paths (fasl-write-code* s o)])
(values (get) sfd-paths)))]
[else (compile*-to-bytevector s)]))
(define (make-cross-compile-to-bytevector machine)
(lambda (s paths format)
;; returns code bytevector and sfd-paths vector
(define (cross-compile-to-bytevector machine s format)
(cond
[(eq? format 'interpret) (cross-fasl-to-string machine s)]
[else (cross-compile machine s)])))
[else (cross-compile machine s)]))
(define (eval-from-bytevector bv paths format)
(define (eval-from-bytevector bv paths sfd-paths format)
(add-performance-memory! 'faslin-code (bytevector-length bv))
(cond
[(eq? format 'interpret)
(let ([r (performance-region
'faslin-code
(fasl-read (open-bytevector-input-port bv)))])
(fasl-read (open-bytevector-input-port bv) 'load sfd-paths))])
(performance-region
'outer
(run-interpret r paths)))]
[else
(let ([proc (performance-region
'faslin-code
(code-from-bytevector bv))])
(code-from-bytevector bv sfd-paths))])
(if (null? paths)
proc
(#%apply proc paths)))]))
(define (code-from-bytevector bv)
(define (code-from-bytevector bv sfd-paths)
(let ([i (open-bytevector-input-port bv)])
(let ([r (load-compiled-from-port i)])
(let ([r (load-compiled-from-port i sfd-paths)])
(performance-region
'outer
(r)))))
(define-record-type wrapped-code
(fields (mutable content) ; bytevector for 'lambda mode; annotation or (vector hash annotation) for 'jit mode
sfd-paths
arity-mask
name)
(nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-0}))
(nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-1}))
(define (force-wrapped-code wc)
(let ([f (wrapped-code-content wc)])
@ -333,7 +354,7 @@
'on-demand
(cond
[(bytevector? f)
(let* ([f (code-from-bytevector f)])
(let* ([f (code-from-bytevector f (wrapped-code-sfd-paths wc))])
(wrapped-code-content-set! wc f)
f)]
[else
@ -396,6 +417,7 @@
(define-record-type linklet
(fields (mutable code) ; the procedure or interpretable form
paths ; list of paths and other fasled; if non-empty, `code` expects them as arguments
sfd-paths ; vector of additional source-location paths intercepted during fasl
format ; 'compile or 'interpret (where the latter may have compiled internal parts)
(mutable preparation) ; 'faslable, 'faslable-strict, 'faslable-unsafe, 'callable, 'lazy, or (cons 'cross <machine>)
importss-abi ; ABI for each import, in parallel to `importss`
@ -403,11 +425,12 @@
name ; name of the linklet (for debugging purposes)
importss ; list of list of import symbols
exports) ; list of export symbol-or-pair, pair is (cons export-symbol src-symbol)
(nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-2}))
(nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-3}))
(define (set-linklet-code linklet code preparation)
(make-linklet code
(linklet-paths linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet)
preparation
(linklet-importss-abi linklet)
@ -416,9 +439,10 @@
(linklet-importss linklet)
(linklet-exports linklet)))
(define (set-linklet-paths linklet paths)
(define (set-linklet-paths linklet paths sfd-paths)
(make-linklet (linklet-code linklet)
paths
sfd-paths
(linklet-format linklet)
(linklet-preparation linklet)
(linklet-importss-abi linklet)
@ -430,6 +454,7 @@
(define (set-linklet-preparation linklet preparation)
(make-linklet (linklet-code linklet)
(linklet-paths linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet)
preparation
(linklet-importss-abi linklet)
@ -536,6 +561,7 @@
(lambda (expr arity-mask name)
(let ([a (correlated->annotation (xify expr) serializable? sfd-cache)])
(make-wrapped-code a
#f
arity-mask
(extract-inferred-name expr name))))]
[else
@ -543,15 +569,13 @@
(lambda (expr arity-mask name)
(performance-region
'compile-nested
(let ([code ((if serializable?
(if cross-machine
(lambda (s) (cross-compile cross-machine s))
compile*-to-bytevector)
compile*)
(show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache)))])
(let ([expr (show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache))])
(if serializable?
(make-wrapped-code code arity-mask (extract-inferred-name expr name))
code))))])))]))
(let-values ([(code sfd-paths) (if cross-machine
(cross-compile cross-machine expr)
(compile*-to-bytevector expr))])
(make-wrapped-code code sfd-paths arity-mask (extract-inferred-name expr name)))
(compile* expr)))))])))]))
(define-values (paths impl-lam/paths)
(if serializable?
(extract-paths-and-fasls-from-schemified-linklet impl-lam/jitified (eq? format 'compile))
@ -571,15 +595,16 @@
(performance-region
'compile-linklet
;; Create the linklet:
(let ([lk (make-linklet ((if serializable?
(let ([impl (show (and (eq? format 'interpret) post-interp-on?) "post-interp" impl-lam/interpable)])
(let-values ([(code sfd-paths)
(if serializable?
(if cross-machine
(make-cross-compile-to-bytevector cross-machine)
compile-to-bytevector)
compile-to-proc)
(show (and (eq? format 'interpret) post-interp-on?) "post-interp" impl-lam/interpable)
paths
format)
(cross-compile-to-bytevector cross-machine impl format)
(compile-to-bytevector impl format))
(values (compile-to-proc impl paths format) '#()))])
(let ([lk (make-linklet code
paths
sfd-paths
format
(if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable)
importss-abi
@ -594,7 +619,7 @@
;; direct import)
(if import-keys
(values lk new-import-keys)
lk))))]))
lk))))))]))
(define (lookup-linklet-or-instance get-import key)
;; Use the provided callback to get an linklet for the
@ -638,7 +663,10 @@
(set-linklet-code linklet (linklet-code linklet) 'lazy)]
[(faslable-strict)
(set-linklet-code linklet
(eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))
(eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet))
'callable)]
[(faslable-unsafe)
(raise (|#%app|
@ -674,7 +702,10 @@
(begin
(when (eq? 'lazy (linklet-preparation linklet))
;; Trigger lazy conversion of code from bytevector
(let ([code (eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))])
(let ([code (eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet))])
(with-interrupts-disabled
(when (eq? 'lazy (linklet-preparation linklet))
(linklet-code-set! linklet code)
@ -692,7 +723,10 @@
(apply
(if (eq? 'callable (linklet-preparation linklet))
(linklet-code linklet)
(eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet)))
(eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet)))
(make-variable-reference target-instance #f)
(extract-imported-variabless target-instance
import-instances

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

@ -48,7 +48,7 @@
[line (correlated-line v)]
[column (correlated-column v)]
[span (correlated-span v)])
(if (and pos span (or (path? src) (string? src)))
(if (and pos span (or (path? src) (string? src) (symbol? src)))
(let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based
(make-annotation e
(if (and line column)
@ -73,37 +73,12 @@
(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)])
(let ([sfd (source-file-descriptor src 0)])
(with-interrupts-disabled
(hash-set! sfd-cache src sfd))
sfd))))
sfd)))
;; --------------------------------------------------

34
racket/src/cs/linklet/cross-compile.ss
View File

@ -59,9 +59,9 @@
(channel-put ch (list cmd
v
reply-ch))
(begin0
(channel-get reply-ch)
(cache-cross-compiler a))))
(let ([bv+paths (channel-get reply-ch)])
(cache-cross-compiler a)
(values (car bv+paths) (cdr bv+paths)))))
(define (cross-compile machine v)
(do-cross 'c machine v))
@ -114,21 +114,33 @@
(let ([msg (channel-get msg-ch)])
;; msg is (list <command> <value> <reply-channel>)
(write-string (#%format "~a\n" (car msg)) to)
(let ([bv (fasl-to-bytevector (cadr msg))])
(let-values ([(bv sfd-paths) (fasl-to-bytevector (cadr msg))])
;; We can't send paths to the cross compiler, but we can tell it
;; how many paths there were, and the cross compiler can report
;; which of those remain used in the compiled form
(write-bytes (integer->integer-bytes (bytevector-length bv) 8 #f #f) to)
(write-bytes bv to))
(write-bytes bv to)
(write-bytes (integer->integer-bytes (vector-length sfd-paths) 8 #f #f) to)
(flush-output to)
(let* ([len-bstr (read-bytes 8 from)]
[len (integer-bytes->integer len-bstr #f #f)]
[bv (read-bytes len from)])
(channel-put (caddr msg) bv))
(let* ([read-num (lambda ()
(integer-bytes->integer (read-bytes 8 from) #f #f))]
[len (read-num)]
[bv (read-bytes len from)]
[kept-sfd-paths-count (read-num)] ; number of used-path indices
[kept-sfd-paths (list->vector
(let loop ([i 0])
(if (fx= i kept-sfd-paths-count)
'()
(cons (vector-ref sfd-paths (read-num))
(loop (fx+ i 1))))))])
(channel-put (caddr msg) (cons bv kept-sfd-paths))))
(loop)))))))
(list machine msg-ch))))
(define (fasl-to-bytevector v)
(let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* v o)
(get)))
(let ([sfd-paths (fasl-write/paths* v o)])
(values (get) sfd-paths))))
(define (find-exe exe)
(let-values ([(base name dir?) (split-path exe)])

10
racket/src/cs/linklet/read.ss
View File

@ -49,9 +49,13 @@
'faslable-strict])))
(define (decode-linklet-paths linklet)
(let ([paths (linklet-paths linklet)])
(let ([paths (linklet-paths linklet)]
[sfd-paths (linklet-sfd-paths linklet)])
(cond
[(null? paths)
[(and (null? paths)
(fxzero? (#%vector-length sfd-paths)))
linklet]
[else
(set-linklet-paths linklet (map compiled-path->path paths))])))
(set-linklet-paths linklet
(#%map compiled-path->path paths)
(#%vector-map compiled-path->path sfd-paths))])))

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

@ -6,7 +6,9 @@
(define (write-linklet-bundle-hash ht dest-o)
(let-values ([(ht cross-machine) (encode-linklet-paths ht)])
(let ([bstr (if cross-machine
(cross-fasl-to-string cross-machine ht)
(let-values ([(bstr sfd-paths) (cross-fasl-to-string cross-machine ht)])
;; sfd-paths should be empty
bstr)
(let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* ht o)
(get)))])
@ -24,12 +26,15 @@
(let ([new-v (cond
[(linklet? v)
(cond
[(pair? (linklet-paths v))
[(or (pair? (linklet-paths v))
(fxpositive? (#%vector-length (linklet-sfd-paths v))))
(adjust-cross-perparation
(set-linklet-paths
v
(map path->compiled-path
(linklet-paths v))))]
(#%map path->compiled-path
(linklet-paths v))
(#%vector-map (lambda (p) (path->compiled-path p #t))
(linklet-sfd-paths v))))]
[else (adjust-cross-perparation v)])]
[else v])])
(when (linklet? new-v)

1
racket/src/cs/rumble.sls
View File

@ -91,7 +91,6 @@
linklet-instantiate-key ; not exported to Racket
set-error-display-eprintf! ; not exported to Racket
set-log-system-message! ; not exported to Racket
set-convert-source-file-descriptor-path! ; not exported to Racket
current-inspector
make-inspector

7
racket/src/cs/rumble/error.ss
View File

@ -658,8 +658,7 @@
[loc (and (cdr p)
(call-with-values (lambda ()
(let* ([src (cdr p)]
[path (convert-source-file-descriptor-path
(source-file-descriptor-path (source-object-sfd src)))])
[path (source-file-descriptor-path (source-object-sfd src))])
(if (source-object-line src)
(values path
(source-object-line src)
@ -677,10 +676,6 @@
(cons (cons name loc) (loop (cdr l) ls))
(loop (cdr l) ls)))])))
(define convert-source-file-descriptor-path (lambda (s) s))
(define (set-convert-source-file-descriptor-path! proc)
(set! convert-source-file-descriptor-path proc))
(define (default-error-display-handler msg v)
(eprintf "~a" msg)
(when (or (continuation-condition? v)

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

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

5
racket/src/schemify/path-and-fasl.rkt
View File

@ -60,7 +60,7 @@
(define (make-path->compiled-path who)
(define path->relative-path-elements (make-path->relative-path-elements #:who who))
(lambda (orig-p)
(lambda (orig-p [for-srcloc? #f])
(cond
[(to-fasl? orig-p)
(define v (force-unfasl orig-p))
@ -95,7 +95,8 @@
[(path? p)
(or (path->relative-path-elements p)
(cond
[(path-for-srcloc? orig-p)
[(or for-srcloc?
(path-for-srcloc? orig-p))
;; Can't make relative, so create a string that keeps up
;; to two path elements
(truncate-path p)]