better certificate handling in zo-parse and zo-marshal

original commit: 80c6ba482d

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)

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))

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?]))