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

update bytecode tools for syntax-object source locations

Browse Source
This commit is contained in:
Matthew Flatt 2015-09-02 12:50:09 -06:00
parent adbeebabaf
commit c1d05fa694
5 changed files with 134 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler-lib/compiler/decompile.rkt
View File

@ -200,7 +200,7 @@
(let ([p (mcons #f #f)]) (let ([p (mcons #f #f)])
(hash-set! stx-ht stx p) (hash-set! stx-ht stx p)
(match stx (match stx
[(stx-obj datum wrap tamper-status) [(stx-obj datum wrap srcloc props tamper-status)
(set-mcar! p (case tamper-status (set-mcar! p (case tamper-status
[(clean) 'wrap] [(clean) 'wrap]
[(tainted) 'wrap-tainted] [(tainted) 'wrap-tainted]
@ -223,7 +223,14 @@
[(box? datum) [(box? datum)
(box (decompile-stx (unbox datum) stx-ht))] (box (decompile-stx (unbox datum) stx-ht))]
[else datum]) [else datum])
wrap)) (let* ([l (mcons wrap null)]
[l (if (hash-count props)
(mcons props l)
l)]
[l (if srcloc
(mcons srcloc l)
l)])
l)))
p])))) p]))))
(define (mpi->string modidx) (define (mpi->string modidx)

4
compiler-lib/compiler/demodularizer/nodep.rkt
View File

@ -197,13 +197,13 @@
empty empty
(begin (begin
(hash-set! REQUIRED ct #t) (hash-set! REQUIRED ct #t)
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
[(module-path-index? ct) [(module-path-index? ct)
(if (hash-has-key? REQUIRED ct) (if (hash-has-key? REQUIRED ct)
empty empty
(begin (begin
(hash-set! REQUIRED ct #t) (hash-set! REQUIRED ct #t)
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))] (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
[(not ct) [(not ct)
empty] empty]
[(@phase? ct) [(@phase? ct)

76
zo-lib/compiler/zo-marshal.rkt
View File

@ -390,7 +390,7 @@
(define (encode-stx-obj w out) (define (encode-stx-obj w out)
(match w (match w
[(struct stx-obj (datum wraps tamper-status)) [(struct stx-obj (datum wraps srcloc props tamper-status))
(let* ([enc-datum (let* ([enc-datum
(match datum (match datum
[(cons a b) [(cons a b)
@ -424,12 +424,39 @@
(car l) (car l)
(map (lambda (e) (encode-stx-obj e out)) (cdr l)))] (map (lambda (e) (encode-stx-obj e out)) (cdr l)))]
[_ datum])] [_ datum])]
[p (cons enc-datum [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)]
(share-everywhere (encode-wrap wraps (out-wraps out)) out))]) [esrcloc (let ()
(define (avail? n) (n . >= . 0))
(define (xvector a b c d e)
(case (hash-ref props 'paren-shape #f)
[(#\[) (vector a b c d e #\[)]
[(#\{) (vector a b c d e #\{)]
[else (if (or a (avail? b) (avail? c) (avail? d))
(vector a b c d e)
#f)]))
(define (norm v) (or v -1))
(share-everywhere
(if srcloc
(xvector (srcloc-source srcloc)
(norm (srcloc-line srcloc))
(norm (srcloc-column srcloc))
(norm (srcloc-position srcloc))
(norm (srcloc-span srcloc)))
(xvector #f -1 -1 -1 -1))
out))])
(cond
[esrcloc
(case tamper-status (case tamper-status
[(clean) p] [(tainted) (vector enc-datum e-wraps esrcloc 1)]
[(tainted) (vector p)] [(armed) (vector enc-datum e-wraps esrcloc 2)]
[(armed) (vector p #f)]))])) [else (vector enc-datum e-wraps esrcloc)])]
[(not (eq? tamper-status 'clean))
(vector enc-datum e-wraps
(case tamper-status
[(tainted) 1]
[(armed) 2]))]
[else
(cons enc-datum e-wraps)]))]))
(define-struct out (s (define-struct out (s
;; The output port for writing bytecode. ;; The output port for writing bytecode.
@ -940,8 +967,41 @@
(out-byte CPT_QUOTE out) (out-byte CPT_QUOTE out)
(parameterize ([quoting? #t]) (parameterize ([quoting? #t])
(out-anything qv out))] (out-anything qv out))]
[(or (? path?) ; XXX Why not use CPT_PATH? [(? path?)
(? regexp?) (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))))))
(cond
[(not maybe-rel)
(define bstr (path->bytes v))
(out-number (bytes-length bstr) out)
(out-bytes bstr out)]
[else
(out-number 0 out)
(out-anything (for/list ([e (in-list (explode-path maybe-rel))])
(if (path? e)
(path-element->bytes e)
e))
out)])]
[(or (? regexp?)
(? byte-regexp?) (? byte-regexp?)
(? number?) (? number?)
(? extflonum?)) (? extflonum?))

63
zo-lib/compiler/zo-parse.rkt
View File

@ -600,14 +600,17 @@
(define (decode-wrapped cp v) (define (decode-wrapped cp v)
(let loop ([v v]) (let loop ([v v])
(let-values ([(tamper-status v encoded-wraps) (let-values ([(tamper-status v encoded-wraps esrcloc)
(match v (match v
[`#((,datum . ,wraps)) (values 'tainted datum wraps)] [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)]
[`#((,datum . ,wraps) #f) (values 'armed datum wraps)] [`#(,datum ,wraps 2) (values 'armed datum wraps #f)]
[`(,datum . ,wraps) (values 'clean datum wraps)] [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)]
[`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)]
[`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)]
[`(,datum . ,wraps) (values 'clean datum wraps #f)]
[else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
(let* ([wrapped-memo (make-memo)] (let* ([wrapped-memo (make-memo)]
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps tamper-status)))]) [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))])
(cond (cond
[(pair? v) [(pair? v)
(if (eq? #t (car v)) (if (eq? #t (car v))
@ -800,11 +803,15 @@
[flags (if (< p* 0) (read-compact-number cp) 0)]) [flags (if (< p* 0) (read-compact-number cp) 0)])
(make-local #t p flags))] (make-local #t p flags))]
[(path) [(path)
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) (let ([len (read-compact-number cp)])
(if (relative-path? p) (if (zero? len)
(path->complete-path p (or (current-load-relative-directory) ;; Read a list of byte strings as relative path elements:
(current-directory))) (let ([p (or (current-load-relative-directory)
p))] (current-directory))])
(for/fold ([p p]) ([e (in-list (read-compact cp))])
(build-path p (if (bytes? e) (bytes->path-element e) e))))
;; Read a path:
(bytes->path (read-compact-bytes cp len))))]
[(small-number) [(small-number)
(let ([l (- ch cpt-start)]) (let ([l (- ch cpt-start)])
l)] l)]
@ -1145,6 +1152,7 @@
;; We do this after building a graph from the input, and `decode-wrap` ;; We do this after building a graph from the input, and `decode-wrap`
;; preserves graph structure. ;; preserves graph structure.
(define decode-ht (make-hasheq)) (define decode-ht (make-hasheq))
(define srcloc-ht (make-hasheq))
(let walk ([p v]) (let walk ([p v])
(match p (match p
[(compilation-top _ pfx c) [(compilation-top _ pfx c)
@ -1182,10 +1190,13 @@
[(seq-for-syntax _ pfx _ _) [(seq-for-syntax _ pfx _ _)
(struct-copy seq-for-syntax p (struct-copy seq-for-syntax p
[prefix (walk pfx)])] [prefix (walk pfx)])]
[(stx-obj d w _) [(stx-obj d w esrcloc _ _)
(define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht))
(struct-copy stx-obj p (struct-copy stx-obj p
[datum (walk d)] [datum (walk d)]
[wrap (decode-wrap w decode-ht)])] [wrap (decode-wrap w decode-ht)]
[srcloc srcloc]
[props props])]
[(? zo?) p] [(? zo?) p]
;; Generic constructors happen inside the `datum` of `stx-obj`, ;; Generic constructors happen inside the `datum` of `stx-obj`,
;; for example (with no cycles): ;; for example (with no cycles):
@ -1217,6 +1228,32 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (decode-srcloc+props esrcloc ht)
(define (norm v) (if (v . < . 0) #f v))
(define p
(hash-ref! ht
esrcloc
(lambda ()
(cons (and esrcloc
;; We could reduce this srcloc to #f if
;; there's no source, line, column, or position
;; information, but we want to expose the actual
;; content of a bytecode stream:
(srcloc (vector-ref esrcloc 0)
(norm (vector-ref esrcloc 1))
(norm (vector-ref esrcloc 2))
(norm (vector-ref esrcloc 3))
(norm (vector-ref esrcloc 4))))
(if (and esrcloc ((vector-length esrcloc) . > . 5))
(case (vector-ref esrcloc 5)
[(#\[) #hasheq((paren-shape . #\[))]
[(#\{) #hasheq((paren-shape . #\{))]
[else #hasheq()])
#hasheq())))))
(values (car p) (cdr p)))
;; ----------------------------------------
(define (decode-wrap encoded-wrap ht) (define (decode-wrap encoded-wrap ht)
(hash-ref! ht (hash-ref! ht
encoded-wrap encoded-wrap
@ -1307,7 +1344,7 @@
[(box (cons base-b (cons (cons sym wraps) phase))) [(box (cons base-b (cons (cons sym wraps) phase)))
(free-id=?-binding (free-id=?-binding
(decode-binding base-b ht) (decode-binding base-b ht)
(stx-obj sym (decode-wrap wraps ht) 'clean) (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean)
phase)] phase)]
[(? symbol?) [(? symbol?)
(local-binding b)] (local-binding b)]

4
zo-lib/compiler/zo-structs.rkt
View File

@ -184,7 +184,9 @@
(define-form-struct stx ([content stx-obj?])) (define-form-struct stx ([content stx-obj?]))
(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components (define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components
[wrap any/c] ; shuold be `wrap?`, but encoded form appears initially [wrap any/c] ; should be `wrap?`, but encoded form appears initially
[srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially
[props (hash/c symbol? any/c)]
[tamper-status (or/c 'clean 'armed 'tainted)])) [tamper-status (or/c 'clean 'armed 'tainted)]))
(define-form-struct wrap ([shifts (listof module-shift?)] (define-form-struct wrap ([shifts (listof module-shift?)]