diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5e47a7ea18..c466244325 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -76,7 +76,8 @@ (write-bytes #"#~" outp) (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) + (define symtabsize (add1 (hash-count shared))) + (write-bytes (int->bytes symtabsize) outp) (write-bytes (bytes (if all-short? 1 0)) outp) (for ([o (in-list offsets)]) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) @@ -233,6 +234,8 @@ (for ([(k v) (in-hash expr)]) (traverse-data k visit) (traverse-data v visit)))] + [(protected-symref? expr) + (visit (protected-symref-val expr))] [else (void)])) @@ -620,6 +623,21 @@ [(struct wrap-mark (val)) (list val)]))) +(define (encode-mark-map mm) + mm + #;(for/fold ([l empty]) + ([(k v) (in-hash ht)]) + (list* k v l))) + +(define-struct protected-symref (val)) + +(define encode-certs + (match-lambda + [(struct certificate:nest (m1 m2)) + (list* (encode-mark-map m1) (encode-mark-map m2))] + [(struct certificate:ref (val m)) + (list* #f (make-protected-symref val) (encode-mark-map m))])) + (define (encode-wrapped w) (match w [(struct wrapped (datum wraps certs)) @@ -659,7 +677,7 @@ [p (cons enc-datum (encode-wraps wraps))]) (if certs - (vector p certs) + (vector p (encode-certs certs)) p))])) (define (lookup-encoded-wrapped w out) @@ -932,6 +950,10 @@ (define (out-value expr out) (cond + [(protected-symref? expr) + (let* ([val (protected-symref-val expr)] + [val-ref ((out-shared-index out) val)]) + (out-value val-ref out))] [(and (symbol? expr) (not (symbol-interned? expr))) (out-as-bytes expr #:before-length (if (symbol-unreadable? expr) 0 1) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 051b578d40..4c29dab5ce 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -498,6 +498,25 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (decode-mark-map alist) + alist + #;(let loop ([alist alist] + [ht (make-immutable-hasheq empty)]) + (match alist + [(list) ht] + [(list* (? number? key) (? module-path-index? val) alist) + (loop alist (hash-set ht key val))]))) + +(define (decode-marks cp ms) + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (vector-ref (cport-symtab cp) symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (define (decode-stx cp v) (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) @@ -508,7 +527,8 @@ [`(,datum . ,wraps) (values #f datum wraps)] [else (error 'decode-wraps "bad datum+wrap: ~e" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] - [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))]) + [marks (decode-marks cp cert-marks)] + [add-wrap (lambda (v) (make-wrapped v wraps marks))]) (cond [(pair? v) (if (eq? #t (car v)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index daba19df57..e776109093 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -42,10 +42,29 @@ [phase (or/c 0 1)])) ; direct access to exported id ;; Syntax object +(define ((alist/c k? v?) l) + (let loop ([l l]) + (match l + [(list) #t] + [(list* (? k?) (? v?) l) + (loop l)] + [_ #f]))) + +(define mark-map? + (alist/c number? module-path-index?) + #;(hash/c number? module-path-index?)) +(define-form-struct certificate ()) +(define-form-struct (certificate:nest certificate) + ([nested mark-map?] + [map mark-map?])) +(define-form-struct (certificate:ref certificate) + ([val any/c] + [map mark-map?])) + (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] [wraps (listof wrap?)] - [certs (or/c list? #f)])) + [certs (or/c certificate? #f)])) ;; In stxs of prefix: (define-form-struct stx ([encoded wrapped?]))