From b13f723ac6c2a7b7e9bdbab433d0ff6f6083cf95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Jun 2018 19:28:05 -0600 Subject: [PATCH] serialize `srcloc`s in bytecode; change expander to keep `srcloc`s To avoid recording absolute paths from a build environment in bytecode files, the bytecode writer converts paths to relative form based on `current-write-relative-directory`. For paths that cannot be made relative in that way and that are in source locations in syntax objects, the printer in v6.x converted those paths to strings that drop most of the path. The v7 expander serializes syntax objects as part of `compile` instead of `write`, so it can't truncate paths in the traditional way. To help out the expander, the core `write` function for compiled code now allows `srcloc` values --- as long as the source field is a path, string, byte string, symbol, or #f. (Constraining the source field avoids various problems, including problems that could be created by cyclic values.) As the core `write` for compiled code prints a path, it truncates a source path in the traditional way. The expander doesn't constrain source locations in syntax objects to have path, string, etc., source values. It can serialize syntax objects with non-path source values at `compile` time, so there's no loss of functionality. The end result is to fix abolute paths that were getting stored in the bytecode for compiled packages, since that's no good for installing packages in built form (which happens, for example, during a distribution build). --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/exns.scrbl | 5 +- .../scribblings/reference/fasl.scrbl | 9 ++- .../scribblings/reference/printer.scrbl | 24 ++++-- pkgs/racket-test-core/tests/racket/fasl.rktl | 26 +++++-- pkgs/racket-test-core/tests/racket/print.rktl | 29 ++++++++ pkgs/racket-test-core/tests/racket/stx.rktl | 19 ++++- pkgs/zo-lib/compiler/zo-marshal.rkt | 62 ++++++++++------ pkgs/zo-lib/compiler/zo-parse.rkt | 9 ++- racket/collects/racket/fasl.rkt | 52 +++++++++---- .../collects/racket/private/truncate-path.rkt | 21 ++++++ racket/src/expander/compile/serialize.rkt | 30 +++++--- racket/src/expander/run/linklet.rkt | 11 +++ racket/src/racket/src/print.c | 74 +++++++++++++++++++ racket/src/racket/src/read.c | 19 +++++ racket/src/racket/src/schcpt.h | 3 +- racket/src/racket/src/schpriv.h | 2 + racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.inc | 36 +++++++-- racket/src/racket/src/struct.c | 14 ++++ 20 files changed, 373 insertions(+), 78 deletions(-) create mode 100644 racket/collects/racket/private/truncate-path.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 9abd208a34..59a10159e8 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.0.0.5") +(define version "7.0.0.6") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/exns.scrbl b/pkgs/racket-doc/scribblings/reference/exns.scrbl index 0a4ff671ee..e6d0fe8601 100644 --- a/pkgs/racket-doc/scribblings/reference/exns.scrbl +++ b/pkgs/racket-doc/scribblings/reference/exns.scrbl @@ -988,7 +988,10 @@ The fields of a @racket[srcloc] instance are as follows: @item{@racket[span] --- The number of covered positions (counts from 0) or @racket[#f] (unknown).} -]} +] + +See @secref["print-compiled"] for information about the treatment of +@racket[srcloc] values that are embedded in compiled code.} @defproc[(srcloc->string [srcloc srcloc?]) (or/c string? #f)]{ diff --git a/pkgs/racket-doc/scribblings/reference/fasl.scrbl b/pkgs/racket-doc/scribblings/reference/fasl.scrbl index 54e3057c59..0e3a709685 100644 --- a/pkgs/racket-doc/scribblings/reference/fasl.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fasl.scrbl @@ -26,8 +26,9 @@ output port or returning the byte string otherwise. The @racket[s-exp->fasl]. The @racket[v] argument must be a value that could be @racket[quote]d -as a literal---that is, something for which @racket[(compile `(quote -,v))] would work and be @racket[read]able after @racket[write]. The +as a literal---that is, a value without syntax objects for which +@racket[(compile `(quote ,v))] +would work and be @racket[read]able after @racket[write]. The byte string produced by @racket[s-exp->fasl] does not use the same format as compiled code, however. @@ -38,7 +39,9 @@ preserve graph structure, handle cyclic data, and encode serializable structures. The @racket[s-exp->fasl] and @racket[fasl->s-exp] functions consult @racket[current-write-relative-directory] and @racket[current-load-relative-directory], respectively, in the same -way as bytecode saving and loading to store paths in relative form. +way as bytecode saving and loading to store paths in relative form, +and they similarly allow and convert constrained @racket[srcloc] +values (see @secref["print-compiled"]). Unless @racket[keep-mutable?] is provided as true to @racket[s-exp->fasl], then mutable values in @racket[v] are replaced diff --git a/pkgs/racket-doc/scribblings/reference/printer.scrbl b/pkgs/racket-doc/scribblings/reference/printer.scrbl index 2fdc269a51..15986820bf 100644 --- a/pkgs/racket-doc/scribblings/reference/printer.scrbl +++ b/pkgs/racket-doc/scribblings/reference/printer.scrbl @@ -555,11 +555,6 @@ assembly code for Racket, and reading such a form produces a compiled form when the @racket[read-accept-compiled] parameter is set to @racket[#t]. -When a compiled form contains syntax object constants, they must not -be @tech{tainted} or @tech{armed}; the @litchar{#~}-marshaled form -drops source-location information and properties (see -@secref["stxprops"]) for the @tech{syntax objects}. - Compiled code parsed from @litchar{#~} is marked as non-runnable if the current code inspector (see @racket[current-code-inspector]) is not the original code inspector; on attempting to evaluate or reoptimize @@ -593,7 +588,7 @@ identifier; those functions lead to top-level and module variables with @tech{unreadable symbol}ic names, and the names are deterministic as long as expansion is otherwise deterministic. -Finally, a compiled form may contain path literals. Although paths are +A compiled form may contain path literals. Although paths are not normally printed in a way that can be read back in, path literals can be written and read as part of compiled code. The @racket[current-write-relative-directory] parameter is used to convert @@ -610,6 +605,19 @@ coerced to a string that preserves only part of the path (an in effort to make it less tied to the build-time filesystem, which can be different than the run-time filesystem). +Finally, a compiled form may contain @racket[srcloc] structures if the +source field of the structure is a path for some system, a string, a +byte string, a symbol, or @racket[#f]. For a path value (matching the +current platform's convention), if the path cannot be recorded as a +relative path based on @racket[current-write-relative-directory], then +it is converted to a string with at most two path elements; if the +path contains more than two elements, then the string contains +@litchar{.../}, the next-to-last element, @litchar{/} and the last +element. The intent of the constraints on @racket[srcloc] values and +the conversion of the source field is to preserve some source +information but not expose or record a path that makes no sense on +a different filesystem or platform. + For internal testing purposes, when the @as-index{@envvar{PLT_VALIDATE_LOAD}} environment variable is set, the reader runs a validator on bytecode parsed from @litchar{#~}. The @@ -623,4 +631,6 @@ procedure is called. mark the loaded code as generally unrunnable instead of rejecting at read time references to unsafe - operations.}] + operations.} + #:changed "7.0" @elem{Allowed some @racket[srcloc] values + embedded in compiled code.}] diff --git a/pkgs/racket-test-core/tests/racket/fasl.rktl b/pkgs/racket-test-core/tests/racket/fasl.rktl index 9d467b7e91..d946ee564e 100644 --- a/pkgs/racket-test-core/tests/racket/fasl.rktl +++ b/pkgs/racket-test-core/tests/racket/fasl.rktl @@ -27,11 +27,12 @@ 43/100 44+100i 45.0+100.0i - 46f0)) + 46f0 + (srcloc "x" 1 2 3 4))) ;; The fasl format is meant to be forward-compatible: (define immutables-regression-bstr - #"racket/fasl:\0\200\371\0\34\"n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\200\16\bnineteen\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\n\0\08B") + #"racket/fasl:\0\200\n\1\34#n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\200\16\bnineteen\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\n\0\08B\34\6\16\6srcloc\23\1xopqr") (for ([i (in-list immutables)]) (test i fasl->s-exp (s-exp->fasl i))) @@ -89,16 +90,27 @@ (let ([unix-path (bytes->path #"here" 'unix)] [windows-path (bytes->path #"there" 'windows)]) (test unix-path fasl->s-exp (s-exp->fasl unix-path)) - (test windows-path fasl->s-exp (s-exp->fasl windows-path)))) + (test windows-path fasl->s-exp (s-exp->fasl windows-path)) + (if (eq? (system-path-convention-type) 'unix) + (test (srcloc "here" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc unix-path 1 2 3 4))) + (test (srcloc "there" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc windows-path 1 2 3 4)))) + (let ([root (car (filesystem-root-list))]) + (test (srcloc (path->string root) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc root 1 2 3 4))) + (test (srcloc (path->string (build-path root "x")) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path root "x") 1 2 3 4)))) + (test (srcloc ".../a/b" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path (current-directory) "a" "b") 1 2 3 4))))) (let* ([rel-p (build-path "nested" "data.rktd")] [p (build-path (current-directory) rel-p)]) - (define bstr + (define-values (bstr srcloc-bstr) (parameterize ([current-write-relative-directory (current-directory)]) - (s-exp->fasl p))) + (values + (s-exp->fasl p) + (s-exp->fasl (srcloc p 10 20 30 40))))) (parameterize ([current-load-relative-directory #f]) - (test rel-p fasl->s-exp bstr)) + (test rel-p fasl->s-exp bstr) + (test (srcloc rel-p 10 20 30 40) fasl->s-exp srcloc-bstr)) (parameterize ([current-load-relative-directory (current-directory)]) - (test p fasl->s-exp bstr))) + (test p fasl->s-exp bstr) + (test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr))) (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/print.rktl b/pkgs/racket-test-core/tests/racket/print.rktl index fe88273b93..4557b73e80 100644 --- a/pkgs/racket-test-core/tests/racket/print.rktl +++ b/pkgs/racket-test-core/tests/racket/print.rktl @@ -339,6 +339,35 @@ (write (s) (p o)) (test "ok" get-output-string o)) +;; ---------------------------------------- +;; Check that some values are allowed in a srcloc source +;; in printed compiled code, and some values are not + +(let () + (define (try v [result-v v] #:ok? [ok? #t]) + (define-values (i o) (make-pipe)) + (define c (compile `,(srcloc v 1 2 3 4))) + (cond + [ok? + (write c o) + (test result-v + srcloc-source + (parameterize ([current-load-relative-directory (build-path (current-directory) "sub")]) + (eval (parameterize ([read-accept-compiled #t]) + (read i)))))] + [else + (err/rt-test (write c o) (lambda (exn) (and (exn:fail? exn) + (regexp-match? #rx"cannot marshal" (exn-message exn)))))])) + + (try #f) + (try 'apple) + (try "apple") + (try #"apple") + (try (string->path "apple") "apple") + + (try 7 #:ok? #f) + (try (box 7) #:ok? #f)) + ;; ---------------------------------------- (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 5daaf368ba..b6d40c9b50 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2600,6 +2600,23 @@ #rx"key for a perserved property must be an interned symbol" (exn-message exn)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure that paths from the current installation are not +;; preserved in marshaled bytecode + +(let ([m '(module m racket/base + ;; Extending a primitive structure type tends to + ;; capture an identifier whose source is "kernstruct.rkt" + (define-struct (cookie-error exn:fail) ()))]) + (define o (open-output-bytes)) + (write (compile m) o) + (call-with-output-file "/tmp/d" #:exists 'replace (lambda (o) (write (compile m) o))) + (test #t + not + (regexp-match? (regexp-quote + (path->bytes (collection-file-path "kernstruct.rkt" "racket/private"))) + (get-output-bytes o)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Make sure the srcloc encoding doesn't do something strange ;; with a path in a root directory: @@ -2615,7 +2632,7 @@ (write (compile (read-syntax path p)) out) (eval (read in)) (define src (syntax-source ((dynamic-require path 'f)))) - (test path values src))) + (test (path->string path) values src))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/pkgs/zo-lib/compiler/zo-marshal.rkt b/pkgs/zo-lib/compiler/zo-marshal.rkt index 692e973e3a..f9678bfb61 100644 --- a/pkgs/zo-lib/compiler/zo-marshal.rkt +++ b/pkgs/zo-lib/compiler/zo-marshal.rkt @@ -11,7 +11,8 @@ racket/pretty racket/path racket/set - racket/extflonum) + racket/extflonum + racket/private/truncate-path) (provide/contract [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)] @@ -329,9 +330,10 @@ CPT_SET_BANG CPT_VARREF CPT_APPLY_VALUES - CPT_OTHER_FORM) + CPT_OTHER_FORM + CPT_SRCLOC) -(define CPT_SMALL_NUMBER_START 46) +(define CPT_SMALL_NUMBER_START 47) (define CPT_SMALL_NUMBER_END 74) (define CPT_SMALL_SYMBOL_START 74) @@ -745,26 +747,8 @@ (out-anything qv out))] [(? path?) (out-byte CPT_PATH out) - (define (within? p) - (and (relative-path? p) - (let loop ([p p]) - (define-values (base name dir?) (split-path p)) - (and (not (eq? name 'up)) - (not (eq? name 'same)) - (or (not (path? base)) - (loop base)))))) (define maybe-rel - (and (current-write-relative-directory) - (let ([dir (current-write-relative-directory)]) - (and (or (not dir) - (within? (find-relative-path v - (if (pair? dir) - (cdr dir) - dir)))) - (find-relative-path v - (if (pair? dir) - (car dir) - dir)))))) + (path->relative-path v)) (cond [(not maybe-rel) (define bstr (path->bytes v)) @@ -777,6 +761,19 @@ (path-element->bytes e) e)) out)])] + [(? srcloc?) + (out-byte CPT_SRCLOC out) + (define src (srcloc-source v)) + (define new-src + (cond + [(and (path? src) (not (path->relative-path src))) + (truncate-path src)] + [else src])) + (out-anything new-src out) + (out-anything (srcloc-line v) out) + (out-anything (srcloc-column v) out) + (out-anything (srcloc-position v) out) + (out-anything (srcloc-span v) out)] [(or (? regexp?) (? byte-regexp?) (? number?) @@ -973,3 +970,24 @@ [(struct-other-shape? constantness) (to-sym 5)] [else #f])) + +(define (path->relative-path v) + (define (within? p) + (and (relative-path? p) + (let loop ([p p]) + (define-values (base name dir?) (split-path p)) + (and (not (eq? name 'up)) + (not (eq? name 'same)) + (or (not (path? base)) + (loop base)))))) + (and (current-write-relative-directory) + (let ([dir (current-write-relative-directory)]) + (and (or (not dir) + (within? (find-relative-path v + (if (pair? dir) + (cdr dir) + dir)))) + (find-relative-path v + (if (pair? dir) + (car dir) + dir)))))) diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index b6d0402d20..32183beb67 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/pkgs/zo-lib/compiler/zo-parse.rkt @@ -294,7 +294,8 @@ [43 varref] [44 apply-values] [45 other-form] - [46 74 small-number] + [46 srcloc] + [47 74 small-number] [74 92 small-symbol] [92 ,(+ 92 small-list-max) small-proper-list] [,(+ 92 small-list-max) 192 small-list] @@ -460,6 +461,12 @@ (build-path p (if (bytes? e) (bytes->path-element e) e)))) ;; Read a path: (bytes->path (read-compact-bytes cp len))))] + [(srcloc) + (srcloc (read-compact cp) + (read-compact cp) + (read-compact cp) + (read-compact cp) + (read-compact cp))] [(small-number) (let ([l (- ch cpt-start)]) l)] diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index db712b7bf4..6d2978b481 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require (for-syntax racket/base)) +(require (for-syntax racket/base) + "private/truncate-path.rkt") (provide s-exp->fasl fasl->s-exp) @@ -76,6 +77,8 @@ (fasl-hash-type 36) (fasl-immutable-hash-type 37) + (fasl-srcloc 38) + ;; Unallocated numbers here are for future extensions ;; 100 to 255 is used for small integers: @@ -124,6 +127,18 @@ (loop (struct->vector v))] [else (void)])) (define exploded-wrt-dir 'not-ready) + (define (path->relative-path-elements v) + (when (and (eq? exploded-wrt-dir 'not-ready) + (path? v)) + (define wrt-dir (current-write-relative-directory)) + (set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir)))) + (and exploded-wrt-dir + (path? v) + (let ([exploded (explode-path v)]) + (and (for/and ([wrt-p (in-list exploded-wrt-dir)] + [p (in-list exploded)]) + (equal? wrt-p p)) + (list-tail exploded (length exploded-wrt-dir)))))) (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v))) ;; The fasl formal prefix: (write-bytes fasl-prefix o) @@ -203,18 +218,7 @@ (write-fasl-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o) (write-fasl-bytes v o)] [(path-for-some-system? v) - (when (and (eq? exploded-wrt-dir 'not-ready) - (path? v)) - (define wrt-dir (current-write-relative-directory)) - (set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir)))) - (define rel-elems - (and exploded-wrt-dir - (path? v) - (let ([exploded (explode-path v)]) - (and (for/and ([wrt-p (in-list exploded-wrt-dir)] - [p (in-list exploded)]) - (equal? wrt-p p)) - (list-tail exploded (length exploded-wrt-dir)))))) + (define rel-elems (path->relative-path-elements v)) (cond [rel-elems (write-byte fasl-relative-path-type o) @@ -224,6 +228,26 @@ (write-byte fasl-path-type o) (write-fasl-bytes (path->bytes v) o) (loop (path-convention-type v))])] + [(and (srcloc? v) (let ([src (srcloc-source v)]) + (or (not src) + (path-for-some-system? src) + (string? src) + (bytes? src) + (symbol? src)))) + (define src (srcloc-source v)) + (define new-src + (cond + [(and (path? src) + (not (path->relative-path-elements src))) + ;; Convert to a string + (truncate-path src)] + [else src])) + (write-fasl-integer fasl-srcloc o) + (loop new-src) + (loop (srcloc-line v)) + (loop (srcloc-column v)) + (loop (srcloc-position v)) + (loop (srcloc-span v))] [(pair? v) (cond [(pair? (cdr v)) @@ -414,6 +438,8 @@ (define len (read-fasl-integer i)) (for/fold ([ht ht]) ([j (in-range len)]) (hash-set ht (loop) (loop)))] + [(fasl-srcloc) + (srcloc (loop) (loop) (loop) (loop) (loop))] [else (cond [(type . >= . fasl-small-integer-start) diff --git a/racket/collects/racket/private/truncate-path.rkt b/racket/collects/racket/private/truncate-path.rkt new file mode 100644 index 0000000000..8217285c27 --- /dev/null +++ b/racket/collects/racket/private/truncate-path.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(provide truncate-path) + +;; Drop information from the path `p` in the same way as marshaling a +;; path in a srcloc as part of compiled code +(define (truncate-path p) + (define-values (base1 name1 dir?) (split-path p)) + (cond + [(path? base1) + (define-values (base2 name2 dir?) (split-path base1)) + (cond + [(not base2) + ;; Path at a root + (path->string p)] + [else + (string-append ".../" (path->string name2) "/" (path->string name1))])] + [(eq? base1 'relative) + (path->string name1)] + [else + ;; Path is a root + (path->string p)])) diff --git a/racket/src/expander/compile/serialize.rkt b/racket/src/expander/compile/serialize.rkt index a623e0f996..2faaad7968 100644 --- a/racket/src/expander/compile/serialize.rkt +++ b/racket/src/expander/compile/serialize.rkt @@ -51,13 +51,13 @@ ;; quoted data (that's non-cyclic and with no internal sharing). A few ;; special cases enable a more compact representation: ;; -;; - numbers, booleans, and symbols are represented as themselves -;; (i.e., self-quoting, in a sense); +;; - numbers, booleans, symbols, and path srclocs are represented +;; as themselves (i.e., self-quoting, in a sense); ;; ;; - #& is a reference to a mutable or shared value at ;; position in a deserialization array; ;; -;; - #( ...) is a `srcloc` +;; - #( ...) is a srcloc whose source is not a path ;; ;; - #:inspector and #:bulk-binding-registry refer to ;; instantiation-time values supplied as imported to the @@ -297,8 +297,9 @@ (for ([e (in-vector (struct->vector v) 1)]) (loop e))] [(srcloc? v) - (for ([e (in-vector (struct->vector v) 1)]) - (loop e))] + (unless (path? (srcloc-source v)) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e)))] [else (void)]) ;; `v` may already be in `objs`, but to get the order right @@ -483,12 +484,19 @@ (ser-push-optional-quote!) (ser-push! 'exact v)))] [(srcloc? v) - (ser-push! 'tag '#:srcloc) - (ser-push! (srcloc-source v)) - (ser-push! (srcloc-line v)) - (ser-push! (srcloc-column v)) - (ser-push! (srcloc-position v)) - (ser-push! (srcloc-span v))] + (cond + [(path? (srcloc-source v)) + ;; Let core printer handle it --- and truncate the path if it + ;; can't be made relative on serialize + (ser-push-optional-quote!) + (ser-push! 'exact v)] + [else + (ser-push! 'tag '#:srcloc) + (ser-push! (srcloc-source v)) + (ser-push! (srcloc-line v)) + (ser-push! (srcloc-column v)) + (ser-push! (srcloc-position v)) + (ser-push! (srcloc-span v))])] [else (ser-push-optional-quote!) (ser-push! 'exact v)])) diff --git a/racket/src/expander/run/linklet.rkt b/racket/src/expander/run/linklet.rkt index de4d56857e..d9f1e26092 100644 --- a/racket/src/expander/run/linklet.rkt +++ b/racket/src/expander/run/linklet.rkt @@ -417,6 +417,7 @@ (struct path-bytes (bstr) #:prefab) (struct unreadable (str) #:prefab) (struct void-value () #:prefab) +(struct srcloc-parts (source line column position span) #:prefab) (define (marshal c) (datum-map c (lambda (tail? c) @@ -424,6 +425,11 @@ [(path? c) (path-bytes (path->bytes c))] [(and (symbol? c) (symbol-unreadable? c)) (unreadable (symbol->string c))] [(void? c) (void-value)] + [(srcloc? c) (srcloc-parts (marshal (srcloc-source c)) + (marshal (srcloc-line c)) + (marshal (srcloc-column c)) + (marshal (srcloc-position c)) + (marshal (srcloc-span c)))] [else c])))) (define (unmarshal c) @@ -433,6 +439,11 @@ [(path-bytes? c) (bytes->path (path-bytes-bstr c))] [(unreadable? c) (string->unreadable-symbol (unreadable-str c))] [(void-value? c) (void)] + [(srcloc-parts? c) (srcloc (marshal (srcloc-parts-source c)) + (marshal (srcloc-parts-line c)) + (marshal (srcloc-parts-column c)) + (marshal (srcloc-parts-position c)) + (marshal (srcloc-parts-span c)))] [else c])))) ;; Like `correlated->datum`, but preserves 'inferred-name information diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 12460689e7..5df522283b 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -154,6 +154,7 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, PrintParams *pp, int notdisplay); static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp); +static Scheme_Object *srcloc_path_to_string(Scheme_Object *p); #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1) @@ -2388,6 +2389,52 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, { print_compact(pp, CPT_VOID); } + else if (compact && SCHEME_CHAPERONE_STRUCTP(obj) && scheme_is_location(obj)) + { + /* Support srclocs in marshaled form with special treatment + of paths */ + int i; + Scheme_Object *src, *rel_src, *dir; + + src = scheme_struct_ref(obj, 0); + if (SCHEME_PATHP(src)) { + /* To make paths portable and to avoid full paths, check + whether the path can be made relative, in which case it is + turned into a list of byte strings. If not, convert to a + string using only the last couple of path elements. */ + dir = scheme_get_param(scheme_current_config(), + MZCONFIG_WRITE_DIRECTORY); + if (SCHEME_TRUEP(dir)) + rel_src = scheme_extract_relative_to(src, dir, mt->path_cache); + else + rel_src = src; + if (SCHEME_PATHP(rel_src)) { + src = scheme_hash_get(mt->path_cache, scheme_box(rel_src)); + if (!src) { + src = srcloc_path_to_string(rel_src); + scheme_hash_set(mt->path_cache, scheme_box(rel_src), src); + } + } else { + /* let the printer make it relative when recurring */ + } + } else if (SCHEME_FALSEP(src) + || SCHEME_CHAR_STRINGP(src) + || SCHEME_BYTE_STRINGP(src) + || SCHEME_SYMBOLP(src) + || SCHEME_GENERAL_PATHP(src)) { + /* ok */ + } else { + cannot_print(pp, notdisplay, obj, ht, compact); + } + + print_compact(pp, CPT_SRCLOC); + print(src, notdisplay, compact, ht, mt, pp); + for (i = 1; i < 5; i++) { + print(scheme_struct_ref(obj, i), notdisplay, compact, ht, mt, pp); + } + + closed = 1; + } else if (SCHEME_CHAPERONE_STRUCTP(obj)) { if (compact && SCHEME_PREFABP(obj)) { @@ -4258,6 +4305,33 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, flush_from_byte_port(SCHEME_VEC_ELS(vec)[4], orig_pp); } +static Scheme_Object *srcloc_path_to_string(Scheme_Object *p) +{ + Scheme_Object *base, *name, *dir_name; + int isdir; + + name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); + if (SCHEME_PATHP(name) && SCHEME_PATHP(base)) { + dir_name = scheme_split_path(SCHEME_PATH_VAL(base), SCHEME_PATH_LEN(base), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); + if (SCHEME_FALSEP(base)) { + /* Path is file at root, so just keep the whole path */ + return scheme_path_to_char_string(p); + } + if (SCHEME_PATHP(dir_name)) + name = scheme_append_strings(scheme_path_to_char_string(dir_name), + scheme_append_strings(scheme_make_utf8_string("/"), + scheme_path_to_char_string(name))); + else + name = scheme_path_to_char_string(name); + return scheme_append_strings(scheme_make_utf8_string(".../"), name); + } else if (SCHEME_PATHP(name)) + return scheme_path_to_char_string(name); + else { + /* original path is a root */ + return scheme_path_to_char_string(p); + } +} + /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index 79721e9866..2ebbc8d037 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -3308,6 +3308,25 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) } } break; + case CPT_SRCLOC: + { + Scheme_Object *r; + r = scheme_unsafe_make_location(); + /* No checking of field values, so a corrupt ".zo" can + create bad srclocs (but won't crash while reading) */ + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[0] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[1] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[2] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[3] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[4] = v; + return r; + } + break; case CPT_CLOSURE: { Scheme_Closure *cl; diff --git a/racket/src/racket/src/schcpt.h b/racket/src/racket/src/schcpt.h index bf8c184d14..9ab4e72864 100644 --- a/racket/src/racket/src/schcpt.h +++ b/racket/src/racket/src/schcpt.h @@ -46,10 +46,11 @@ enum { CPT_VARREF, CPT_APPLY_VALUES, CPT_OTHER_FORM, + CPT_SRCLOC, _CPT_COUNT_ }; -#define CPT_SMALL_NUMBER_START 46 +#define CPT_SMALL_NUMBER_START 47 #define CPT_SMALL_NUMBER_END 74 #define CPT_SMALL_SYMBOL_START 74 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index d19426181d..52964c4dda 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3790,6 +3790,8 @@ Scheme_Object *scheme_copy_list(Scheme_Object *l); Scheme_Object *scheme_append_strings(Scheme_Object *s1, Scheme_Object *s2); +Scheme_Object *scheme_unsafe_make_location(void); + void scheme_reset_hash_table(Scheme_Hash_Table *ht, int *history); XFORM_NONGCING void scheme_set_distinct_eq_hash(Scheme_Object *var2); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index db97cba1aa..573d2aeead 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "7.0.0.5" +#define MZSCHEME_VERSION "7.0.0.6" #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_W 6 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index d84eacd78f..e595ae447e 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -5,6 +5,7 @@ static const char *startup_source = "((boot boot)" "(1/bound-identifier=? bound-identifier=?)" "(1/compile compile)" +"(compile-keep-source-locations! compile-keep-source-locations!)" "(compile-to-linklets compile-to-linklets)" "(1/current-compile current-compile)" "(1/current-compiled-file-roots current-compiled-file-roots)" @@ -18298,6 +18299,11 @@ static const char *startup_source = "(if(srcloc?" " v_95)" "(let-values()" +"(if(path?" +"(srcloc-source" +" v_95))" +"(void)" +"(let-values()" "(begin" "(let-values(((v*_2" " start*_2" @@ -18305,7 +18311,7 @@ static const char *startup_source = " step*_2)" "(normalise-inputs" " 'in-vector" -" \"vector\"" +" \"vector\"" "(lambda(x_46)" "(vector?" " x_46))" @@ -18350,7 +18356,7 @@ static const char *startup_source = "(values))))))" " for-loop_129)" " start*_2)))" -"(void)))" +"(void)))))" "(let-values()" "(void))))))))))" "(hash-set!" @@ -19097,20 +19103,33 @@ static const char *startup_source = " c3_0)" "(if(srcloc? v_140)" "(let-values()" +"(if(path?" +"(srcloc-source v_140))" +"(let-values()" +"(begin" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_140)))" +"(let-values()" "(begin" "(ser-push!_16" " 'tag" " '#:srcloc)" "(ser-push!_16" -"(srcloc-source v_140))" +"(srcloc-source" +" v_140))" "(ser-push!_16" "(srcloc-line v_140))" "(ser-push!_16" -"(srcloc-column v_140))" +"(srcloc-column" +" v_140))" "(ser-push!_16" -"(srcloc-position v_140))" +"(srcloc-position" +" v_140))" "(ser-push!_16" -"(srcloc-span v_140))))" +"(srcloc-span" +" v_140))))))" "(let-values()" "(begin" "(ser-push-optional-quote!_0)" @@ -27024,6 +27043,7 @@ static const char *startup_source = "(if s_80" "(vector(srcloc-source s_80)(srcloc-line s_80)(srcloc-column s_80)(srcloc-position s_80)(srcloc-span s_80))" " #f))))" +"(define-values(keep-source-locations?) #f)" "(define-values" "(correlate*)" "(lambda(stx_15 s-exp_0)" @@ -27031,9 +27051,9 @@ static const char *startup_source = "(define-values(correlate~)(lambda(stx_16 s-exp_1)(begin s-exp_1)))" "(define-values" "(correlate/app)" -"(lambda(stx_17 s-exp_2)" -"(begin(if(eq?(system-type 'vm) 'chez-scheme)(correlate* stx_17 s-exp_2)(correlate~ stx_17 s-exp_2)))))" +"(lambda(stx_17 s-exp_2)(begin(if keep-source-locations?(correlate* stx_17 s-exp_2)(correlate~ stx_17 s-exp_2)))))" "(define-values(->correlated)(lambda(s_2)(begin(datum->correlated s_2 #f))))" +"(define-values(compile-keep-source-locations!)(lambda(on?_0)(begin(set! keep-source-locations? on?_0))))" "(define-values" "(compile$2)" "(let-values(((compile5_0)" diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 84c9b1a3b3..fec8e8a04b 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -5770,6 +5770,20 @@ Scheme_Object *scheme_make_location(Scheme_Object *src, return scheme_make_struct_instance(location_struct, 5, a); } +Scheme_Object *scheme_unsafe_make_location(void) +{ + Scheme_Structure *inst; + + inst = (Scheme_Structure *)scheme_malloc_tagged(STRUCT_BYTES(5)); + + inst->so.type = scheme_structure_type; + inst->stype = (Scheme_Struct_Type *)location_struct; + + /* caller must initialize content */ + + return (Scheme_Object *)inst; +} + int scheme_is_location(Scheme_Object *o) { if (SCHEME_CHAPERONEP(o))