From ae337220711e92052b2617a2b12c75b7cdc36f12 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Jun 2011 21:33:59 -0600 Subject: [PATCH] fix `compiler/zo-parse' & co. original commit: 69ad39d45c206c4283d62c5a0d1ab6da6fab9a9d --- collects/compiler/zo-marshal.rkt | 21 ++++--------- collects/compiler/zo-parse.rkt | 53 +++++++++++--------------------- collects/compiler/zo-structs.rkt | 15 ++------- 3 files changed, 26 insertions(+), 63 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9438fc71aa..124b01c48c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -304,7 +304,7 @@ (for/list ([wrap (in-list wraps)]) (match wrap [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f))] + (box (vector amt src dest #f #f))] [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) (define encoded-kind (eq? kind 'marked)) (define encoded-unmarshals (map encode-all-from-module unmarshals)) @@ -343,18 +343,9 @@ (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))] - [(struct certificate:plain (m)) - (encode-mark-map m)])) - (define (encode-wrapped w) (match w - [(struct wrapped (datum wraps certs)) + [(struct wrapped (datum wraps tamper-status)) (let* ([enc-datum (match datum [(cons a b) @@ -391,9 +382,10 @@ [_ datum])] [p (cons enc-datum (encode-wraps wraps))]) - (if certs - (vector p (encode-certs certs)) - p))])) + (case tamper-status + [(clean) p] + [(tainted) (vector p)] + [(armed) (vector p #f)]))])) (define-struct out (s shared-index shared-unsee encoded-wraps)) (define (out-shared v out k) @@ -887,7 +879,6 @@ (let ([phase (car l)] [all (append (cadr l) (caddr l))]) (list phase - (list->vector/#f #f (map provided-insp all)) (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) all)) (list->vector/#f #f (map (lambda (p) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 99d6435908..287498ba73 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -232,8 +232,8 @@ ,indirect-provides ,num-indirect-provides ,protects ,et-protects ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 9 provide-phase-count))]) - (match (list-tail rest (* 9 provide-phase-count)) + (let ([phase-data (take rest (* 8 provide-phase-count))]) + (match (list-tail rest (* 8 provide-phase-count)) [`(,syntax-body ,body ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) @@ -241,34 +241,31 @@ prefix (let loop ([l phase-data]) (if (null? l) null - (let ([num-vars (list-ref l 7)] - [ps (for/list ([name (in-vector (list-ref l 6))] - [src (in-vector (list-ref l 5))] - [src-name (in-vector (list-ref l 4))] - [nom-src (or (list-ref l 3) + (let ([num-vars (list-ref l 6)] + [ps (for/list ([name (in-vector (list-ref l 5))] + [src (in-vector (list-ref l 4))] + [src-name (in-vector (list-ref l 3))] + [nom-src (or (list-ref l 2) (in-cycle (in-value #f)))] - [src-phase (or (list-ref l 2) + [src-phase (or (list-ref l 1) (in-cycle (in-value #f)))] [protected? (or (case (car l) [(0) protects] [(1) et-protects] [else #f]) - (in-cycle (in-value #f)))] - [insp (or (list-ref l 1) - (in-cycle (in-value #f)))]) + (in-cycle (in-value #f)))]) (make-provided name src src-name (or nom-src src) (if src-phase 1 0) - protected? - insp))]) + protected?))]) (if (null? ps) - (loop (list-tail l 9)) + (loop (list-tail l 8)) (cons (list (car l) (take ps num-vars) (drop ps num-vars)) - (loop (list-tail l 9))))))) + (loop (list-tail l 8))))))) (list* (cons 0 requires) (cons 1 syntax-requires) @@ -527,20 +524,6 @@ (define (decode-mark-map alist) alist) -(define marks-memo (make-memo)) -(define (decode-marks cp ms) - (with-memo marks-memo ms - (match ms - [#f #f] - [(list* #f (? number? symref) alist) - (make-certificate:ref - (symtab-lookup cp symref) - (decode-mark-map alist))] - [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))] - [alist - (make-certificate:plain (decode-mark-map alist))]))) - (define stx-memo (make-memo)) ; XXX More memo use (define (decode-stx cp v) @@ -548,15 +531,15 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) - (let-values ([(cert-marks v encoded-wraps) + (let-values ([(tamper-status v encoded-wraps) (match v - [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] - [`(,datum . ,wraps) (values #f datum wraps)] + [`#((,datum . ,wraps)) (values 'tainted datum wraps)] + [`#((,datum . ,wraps) #f) (values 'armed datum wraps)] + [`(,datum . ,wraps) (values 'clean datum wraps)] [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] - [marks (decode-marks cp cert-marks)] [wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))]) (cond [(pair? v) (if (eq? #t (car v)) @@ -652,7 +635,7 @@ [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f) + [`#(,amt ,src ,dest #f #f) (make-phase-shift amt (parse-module-path-index cp src) (parse-module-path-index cp dest))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 6d0b29574c..e7223113ff 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -57,21 +57,11 @@ (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 (certificate:plain certificate) - ([map mark-map?])) - (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] [wraps (listof wrap?)] - [certs (or/c certificate? #f)])) + [tamper-status (or/c 'clean 'armed 'tainted)])) ;; In stxs of prefix: (define-form-struct stx ([encoded wrapped?])) @@ -91,8 +81,7 @@ [src-name symbol?] [nom-src any/c] ; should be (or/c module-path-index? #f) [src-phase (or/c 0 1)] - [protected? boolean?] - [insp (or/c boolean? void?)])) + [protected? boolean?])) (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?]