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 collection 'multi)
(define version "7.8.0.3") (define version "7.8.0.4")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

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

@ -32,27 +32,71 @@
(unless (eof-object? cmd) (unless (eof-object? cmd)
(get-u8 in) ; newline (get-u8 in) ; newline
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(case (integer->char cmd) (let ([sfd-paths
[(#\c) (case (integer->char cmd)
(compile-to-port (list `(lambda () ,(read-fasled in))) o)] [(#\c)
[(#\f) (call-with-fasled
;; Reads host fasl format, then writes target fasl format in
(let ([v (read-fasled in)]) (lambda (v pred)
(parameterize ([#%$target-machine (string->symbol target)]) (compile-to-port (list `(lambda () ,v)) o #f #f #f (string->symbol target) #f pred)))]
(fasl-write v o)))] [(#\f)
[else ;; Reads host fasl format, then writes target fasl format
(error 'serve-cross-compile (format "unrecognized command: ~s" cmd))]) (call-with-fasled
(let ([result (get)] in
[len-bv (make-bytevector 8)]) (lambda (v pred)
(bytevector-u64-set! len-bv 0 (bytevector-length result) (endianness little)) (parameterize ([#%$target-machine (string->symbol target)])
(put-bytevector out len-bv) (fasl-write v o pred))))]
(put-bytevector out result) [else
(flush-output-port out))) (error 'serve-cross-compile (format "unrecognized command: ~s" cmd))])])
(loop)))))) (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)))))))
;; ---------------------------------------- ;; ----------------------------------------
(define (read-fasled in) (define (put-num out n)
(let ([len-bv (get-bytevector-n in 8)]) (let ([bv (make-bytevector 8)])
(fasl-read (open-bytevector-input-port (bytevector-u64-set! bv 0 n (endianness little))
(get-bytevector-n in (bytevector-u64-ref len-bv 0 (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 ;; 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 33)) (values 9 5 3 34))
(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

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

@ -526,6 +526,5 @@
(set-make-async-callback-poll-wakeup! unsafe-make-signal-received) (set-make-async-callback-poll-wakeup! unsafe-make-signal-received)
(set-get-machine-info! get-machine-info) (set-get-machine-info! get-machine-info)
(set-processor-count! (1/processor-count)) (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-future-logging-procs! logging-future-events? log-future-event)
(install-place-logging-procs! logging-place-events? log-place-event)) (install-place-logging-procs! logging-place-events? log-place-event))

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

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

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

@ -48,7 +48,7 @@
[line (correlated-line v)] [line (correlated-line v)]
[column (correlated-column v)] [column (correlated-column v)]
[span (correlated-span 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 (let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based
(make-annotation e (make-annotation e
(if (and line column) (if (and line column)
@ -73,37 +73,12 @@
(define (source->sfd src serializable? sfd-cache) (define (source->sfd src serializable? sfd-cache)
(or (with-interrupts-disabled (or (with-interrupts-disabled
(hash-ref sfd-cache src #f)) (hash-ref sfd-cache src #f))
(let ([str (cond ;; We'll use a file-position object in source objects, so
[serializable? ;; the sfd checksum doesn't matter
;; Making paths to record for procedure obey (let ([sfd (source-file-descriptor src 0)])
;; `current-write-relative-directory`, etc., is (with-interrupts-disabled
;; difficult --- a lot of work for something that (hash-set! sfd-cache src sfd))
;; shows up only in stack traces. So, just keep a sfd)))
;; 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))))
;; -------------------------------------------------- ;; --------------------------------------------------

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

@ -59,9 +59,9 @@
(channel-put ch (list cmd (channel-put ch (list cmd
v v
reply-ch)) reply-ch))
(begin0 (let ([bv+paths (channel-get reply-ch)])
(channel-get reply-ch) (cache-cross-compiler a)
(cache-cross-compiler a)))) (values (car bv+paths) (cdr bv+paths)))))
(define (cross-compile machine v) (define (cross-compile machine v)
(do-cross 'c machine v)) (do-cross 'c machine v))
@ -114,21 +114,33 @@
(let ([msg (channel-get msg-ch)]) (let ([msg (channel-get msg-ch)])
;; msg is (list <command> <value> <reply-channel>) ;; msg is (list <command> <value> <reply-channel>)
(write-string (#%format "~a\n" (car msg)) to) (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 (integer->integer-bytes (bytevector-length bv) 8 #f #f) to)
(write-bytes bv to)) (write-bytes bv to)
(flush-output to) (write-bytes (integer->integer-bytes (vector-length sfd-paths) 8 #f #f) to)
(let* ([len-bstr (read-bytes 8 from)] (flush-output to)
[len (integer-bytes->integer len-bstr #f #f)] (let* ([read-num (lambda ()
[bv (read-bytes len from)]) (integer-bytes->integer (read-bytes 8 from) #f #f))]
(channel-put (caddr msg) bv)) [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))))))) (loop)))))))
(list machine msg-ch)))) (list machine msg-ch))))
(define (fasl-to-bytevector v) (define (fasl-to-bytevector v)
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* v o) (let ([sfd-paths (fasl-write/paths* v o)])
(get))) (values (get) sfd-paths))))
(define (find-exe exe) (define (find-exe exe)
(let-values ([(base name dir?) (split-path exe)]) (let-values ([(base name dir?) (split-path exe)])

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

@ -49,9 +49,13 @@
'faslable-strict]))) 'faslable-strict])))
(define (decode-linklet-paths linklet) (define (decode-linklet-paths linklet)
(let ([paths (linklet-paths linklet)]) (let ([paths (linklet-paths linklet)]
[sfd-paths (linklet-sfd-paths linklet)])
(cond (cond
[(null? paths) [(and (null? paths)
linklet] (fxzero? (#%vector-length sfd-paths)))
[else linklet]
(set-linklet-paths linklet (map compiled-path->path paths))]))) [else
(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) (define (write-linklet-bundle-hash ht dest-o)
(let-values ([(ht cross-machine) (encode-linklet-paths ht)]) (let-values ([(ht cross-machine) (encode-linklet-paths ht)])
(let ([bstr (if cross-machine (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)]) (let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* ht o) (fasl-write* ht o)
(get)))]) (get)))])
@ -24,12 +26,15 @@
(let ([new-v (cond (let ([new-v (cond
[(linklet? v) [(linklet? v)
(cond (cond
[(pair? (linklet-paths v)) [(or (pair? (linklet-paths v))
(fxpositive? (#%vector-length (linklet-sfd-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))
(#%vector-map (lambda (p) (path->compiled-path p #t))
(linklet-sfd-paths v))))]
[else (adjust-cross-perparation v)])] [else (adjust-cross-perparation v)])]
[else v])]) [else v])])
(when (linklet? new-v) (when (linklet? new-v)

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

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

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

@ -658,8 +658,7 @@
[loc (and (cdr p) [loc (and (cdr p)
(call-with-values (lambda () (call-with-values (lambda ()
(let* ([src (cdr p)] (let* ([src (cdr p)]
[path (convert-source-file-descriptor-path [path (source-file-descriptor-path (source-object-sfd src))])
(source-file-descriptor-path (source-object-sfd src)))])
(if (source-object-line src) (if (source-object-line src)
(values path (values path
(source-object-line src) (source-object-line src)
@ -677,10 +676,6 @@
(cons (cons name loc) (loop (cdr l) ls)) (cons (cons name loc) (loop (cdr l) ls))
(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) (define (default-error-display-handler msg v)
(eprintf "~a" msg) (eprintf "~a" msg)
(when (or (continuation-condition? v) (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_X 7
#define MZSCHEME_VERSION_Y 8 #define MZSCHEME_VERSION_Y 8
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_W 4
/* 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

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

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