use new 'serialized=?' to tighten setup scribble fixpoint

svn: r10428
This commit is contained in:
Matthew Flatt 2008-06-23 19:28:08 +00:00
parent 9431017d18
commit 3f60a478ad
6 changed files with 253 additions and 151 deletions

View File

@ -17,6 +17,8 @@
serialize serialize
deserialize deserialize
serialized=?
deserialize-module-guard) deserialize-module-guard)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -362,7 +364,7 @@
(define-struct not-ready (shares fixup)) (define-struct not-ready (shares fixup))
(define (lookup-shared! share n mod-map) (define (lookup-shared! share n mod-map module-path-index-join)
;; The shared list is not necessarily in order of ;; The shared list is not necessarily in order of
;; refereds before referees. A `not-ready' object ;; refereds before referees. A `not-ready' object
;; indicates a reference before a value is ready, ;; indicates a reference before a value is ready,
@ -374,12 +376,12 @@
(let* ([v (vector-ref (not-ready-shares sv) n)] (let* ([v (vector-ref (not-ready-shares sv) n)]
[val (if (box? v) [val (if (box? v)
(deserial-shell (unbox v) mod-map (not-ready-fixup sv) n) (deserial-shell (unbox v) mod-map (not-ready-fixup sv) n)
(deserialize-one v share mod-map))]) (deserialize-one v share mod-map module-path-index-join))])
(vector-set! share n val) (vector-set! share n val)
val) val)
sv))) sv)))
(define (deserialize-one v share mod-map) (define (deserialize-one v share mod-map module-path-index-join)
(let loop ([v v]) (let loop ([v v])
(cond (cond
[(or (boolean? v) [(or (boolean? v)
@ -398,7 +400,7 @@
(apply (deserialize-info-maker info) (map loop (cdr v))))] (apply (deserialize-info-maker info) (map loop (cdr v))))]
[else [else
(case (car v) (case (car v)
[(?) (lookup-shared! share (cdr v) mod-map)] [(?) (lookup-shared! share (cdr v) mod-map module-path-index-join)]
[(f) (apply make-prefab-struct (cadr v) (map loop (cddr v)))] [(f) (apply make-prefab-struct (cadr v) (map loop (cddr v)))]
[(void) (void)] [(void) (void)]
[(u) (let ([x (cdr v)]) [(u) (let ([x (cdr v)])
@ -488,17 +490,39 @@
[(mpi) [(mpi)
(error 'deserialize "cannot restore module-path-index in cycle")])])) (error 'deserialize "cannot restore module-path-index in cycle")])]))
(define (deserialize-with-map mod-map vers l module-path-index-join)
(let ([share-n (list-ref l 2)]
[shares (list-ref l 3)]
[fixups (list-ref l 4)]
[result (list-ref l 5)])
;; Create vector for sharing:
(let* ([fixup (make-vector share-n #f)]
[share (make-vector share-n (make-not-ready
(list->vector shares)
fixup))])
;; Deserialize into sharing array:
(let loop ([n 0][l shares])
(unless (= n share-n)
(lookup-shared! share n mod-map module-path-index-join)
(loop (add1 n) (cdr l))))
;; Fixup shell for graphs
(for-each (lambda (n+v)
(let ([v (deserialize-one (cdr n+v) share mod-map module-path-index-join)])
((vector-ref fixup (car n+v)) v)))
fixups)
;; Deserialize final result. (If there's no sharing, then
;; all the work is actually here.)
(deserialize-one result share mod-map module-path-index-join))))
(define (extract-version l)
(if (pair? (car l))
(values (caar l) (cdr l))
(values 0 l)))
(define (deserialize l) (define (deserialize l)
(let-values ([(vers l) (let-values ([(vers l) (extract-version l)])
(if (pair? (car l))
(values (caar l) (cdr l))
(values 0 l))])
(let ([mod-map (make-vector (list-ref l 0))] (let ([mod-map (make-vector (list-ref l 0))]
[mod-map-l (list-ref l 1)] [mod-map-l (list-ref l 1)])
[share-n (list-ref l 2)]
[shares (list-ref l 3)]
[fixups (list-ref l 4)]
[result (list-ref l 5)])
;; Load constructor mapping ;; Load constructor mapping
(let loop ([n 0][l mod-map-l]) (let loop ([n 0][l mod-map-l])
(unless (null? l) (unless (null? l)
@ -512,21 +536,48 @@
;; Register maker and struct type: ;; Register maker and struct type:
(vector-set! mod-map n des)) (vector-set! mod-map n des))
(loop (add1 n) (cdr l)))) (loop (add1 n) (cdr l))))
;; Create vector for sharing: (deserialize-with-map mod-map vers l module-path-index-join))))
(let* ([fixup (make-vector share-n #f)]
[share (make-vector share-n (make-not-ready ;; ----------------------------------------
(list->vector shares)
fixup))]) (define (serialized=? l1 l2)
;; Deserialize into sharing array: (let-values ([(vers1 l1) (extract-version l1)]
(let loop ([n 0][l shares]) [(vers2 l2) (extract-version l2)])
(unless (= n share-n) (let ([mod-map1 (make-vector (list-ref l1 0))]
(lookup-shared! share n mod-map) [mod-map1-l (list-ref l1 1)]
(loop (add1 n) (cdr l)))) [mod-map2 (make-vector (list-ref l2 0))]
;; Fixup shell for graphs [mod-map2-l (list-ref l2 1)]
(for-each (lambda (n+v) [make-key (lambda (path+name)
(let ([v (deserialize-one (cdr n+v) share mod-map)]) (if (car path+name)
((vector-ref fixup (car n+v)) v))) (let ([p (unprotect-path (car path+name))]
fixups) [sym (cdr path+name)])
;; Deserialize final result. (If there's no sharing, then (list p sym))
;; all the work is actually here.) (list #f (cdr path+name))))]
(deserialize-one result share mod-map)))))) [mpi-key (gensym)])
(let ([keys1 (map make-key mod-map1-l)]
[keys2 (map make-key mod-map2-l)]
[ht (make-hash)]
[mpij (lambda (a b) (vector mpi-key a b))])
(for-each (lambda (key)
(unless (hash-ref ht key #f)
(hash-set! ht key (gensym))))
(append keys1 keys2))
(for-each (lambda (mod-map keys)
(let loop ([n 0][l keys])
(unless (null? l)
(let ([sym (hash-ref ht (car l))])
(vector-set! mod-map n
(make-deserialize-info
(lambda args
(vector sym (list->vector args)))
(lambda ()
(let ([v (vector sym #f)])
(values v
(lambda (vec)
(vector-set! v 1 (vector-ref vec 1)))))))))
(loop (add1 n) (cdr l)))))
(list mod-map1 mod-map2)
(list keys1 keys2))
(let ([v1 (deserialize-with-map mod-map1 vers1 l1 mpij)]
[v2 (deserialize-with-map mod-map2 vers2 l2 mpij)])
(equal? v1 v2)))))))

View File

@ -58,13 +58,14 @@
(let ([seen (make-hasheq)] (let ([seen (make-hasheq)]
[search-key #f]) [search-key #f])
(let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))] (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
[rqueue null]) [rqueue null]
[need-result? #t])
(cond (cond
[(null? queue) [(null? queue)
(if (null? rqueue) (if (null? rqueue)
;; Not documented ;; Not documented
#f #f
(loop (reverse rqueue) null))] (loop (reverse rqueue) null need-result?))]
[else [else
(let ([mod (list-ref (car queue) 0)] (let ([mod (list-ref (car queue) 0)]
[id (list-ref (car queue) 1)] [id (list-ref (car queue) 1)]
@ -80,77 +81,86 @@
(not search-key)) (not search-key))
(set! search-key eb)) (set! search-key eb))
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))]) (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
(or (and v (let* ([here-result
(let ([v (resolve-get/tentative part ri `(form ,eb))]) (and need-result?
(or (and v `(form ,eb)) v
`(def ,eb)))) (let ([v (resolve-get/tentative part ri `(form ,eb))])
;; Maybe it's re-exported from this module... (or (and v `(form ,eb))
;; Try a shortcut: `(def ,eb))))]
(if (eq? rmp (and (car b) (module-path-index-resolve (car b)))) [need-result? (and need-result? (not here-result))])
;; Not defined through this path, so keep looking ;; Even if we've found `here-result', look deeper so that we have
(loop queue rqueue) ;; consistent `dep' results.
;; Check parents, if we can get the source: (let ([nest-result
(if (and (path? (resolved-module-path-name rmp)) ;; Maybe it's re-exported from this module...
(not (hash-ref seen rmp #f))) ;; Try a shortcut:
(let ([exports (if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
(hash-ref ;; Not defined through this path, so keep looking
module-info-cache (loop queue rqueue need-result?)
rmp ;; Check parents, if we can get the source:
(lambda () (if (and (path? (resolved-module-path-name rmp))
(let-values ([(valss stxess) (not (hash-ref seen rmp #f)))
(with-handlers ([exn:fail? (let ([exports
(lambda (exn) (hash-ref
(values null null))]) module-info-cache
(module-compiled-exports rmp
(get-module-code (resolved-module-path-name rmp) (lambda ()
#:choose (lambda (src zo so) 'zo))))]) (let-values ([(valss stxess)
(let ([t (with-handlers ([exn:fail?
;; Merge the two association lists: (lambda (exn)
(let loop ([base valss] (values null null))])
[stxess stxess]) (module-compiled-exports
(cond (get-module-code (resolved-module-path-name rmp)
[(null? stxess) base] #:choose (lambda (src zo so) 'zo))))])
[(assoc (caar stxess) base) (let ([t
=> (lambda (l) ;; Merge the two association lists:
(loop (cons (cons (car l) (let loop ([base valss]
(append (cdar stxess) [stxess stxess])
(cdr l))) (cond
(remq l base)) [(null? stxess) base]
(cdr stxess)))] [(assoc (caar stxess) base)
[else (loop (cons (car stxess) => (lambda (l)
base) (loop (cons (cons (car l)
(cdr stxess))]))]) (append (cdar stxess)
(hash-set! module-info-cache rmp t) (cdr l)))
t))))]) (remq l base))
(hash-set! seen rmp #t) (cdr stxess)))]
(let ([a (assq id (let ([a (assoc export-phase exports)]) [else (loop (cons (car stxess)
(if a base)
(cdr a) (cdr stxess))]))])
null)))]) (hash-set! module-info-cache rmp t)
(if a t))))])
(loop queue (hash-set! seen rmp #t)
(append (map (lambda (m) (let ([a (assq id (let ([a (assoc export-phase exports)])
(if (pair? m) (if a
(list (module-path-index-rejoin (car m) mod) (cdr a)
(list-ref m 2) null)))])
defn-phase (if a
(list-ref m 1) (loop queue
(list-ref m 3)) (append (map (lambda (m)
(list (module-path-index-rejoin m mod) (if (pair? m)
id (list (module-path-index-rejoin (car m) mod)
0 (list-ref m 2)
0 defn-phase
0))) (list-ref m 1)
(cadr a)) (list-ref m 3))
rqueue)) (list (module-path-index-rejoin m mod)
(begin id
;; A dead end may not be our fault: the files could 0
;; have changed in inconsistent ways. So just say #f 0
;; for now. 0)))
#; (cadr a))
(error 'find-scheme-tag rqueue)
"dead end when looking for binding source: ~e" need-result?)
id) (begin
#f)))) ;; A dead end may not be our fault: the files could
;; Can't get the module source, so continue with queue: ;; have changed in inconsistent ways. So just say #f
(loop queue rqueue)))))))]))))))) ;; for now.
#;
(error 'find-scheme-tag
"dead end when looking for binding source: ~e"
id)
#f))))
;; Can't get the module source, so continue with queue:
(loop queue rqueue need-result?)))])
(or here-result
nest-result))))))])))))))

View File

@ -297,6 +297,30 @@ If a value provided to @scheme[serialize] is a simple tree (i.e., no
sharing), then the fourth and fifth elements in the serialized sharing), then the fourth and fifth elements in the serialized
representation will be empty.} representation will be empty.}
@; ----------------------------------------------------------------------
@defproc[(serialized=? [v1 any/c] [v2 any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v1] and @scheme[v2] represent the same
serialization information.
More precisely, it returns the same value that @scheme[(equal?
(deserialize v1) (deserialize v2))] would return if
@itemize[
@item{all structure types whose deserializers are accessed with
distinct module paths are actually distinct types;}
@item{all structure types are transparent; and}
@item{all structure instances contain only the constituent values
recorded in each of @scheme[v1] and @scheme[v2].}
]}
@; ----------------------------------------------------------------------
@defparam[deserialize-module-guard guard (module-path? symbol? . -> . void?)]{ @defparam[deserialize-module-guard guard (module-path? symbol? . -> . void?)]{
A parameter whose value is called by @scheme[deserialize] before A parameter whose value is called by @scheme[deserialize] before

View File

@ -22,7 +22,7 @@
(define verbose (make-parameter #t)) (define verbose (make-parameter #t))
(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category)) (define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category))
(define-struct info (doc sci provides undef searches deps (define-struct info (doc sci provides undef searches deps known-deps
build? time out-time need-run? build? time out-time need-run?
need-in-write? need-out-write? need-in-write? need-out-write?
vers rendered? failed?) vers rendered? failed?)
@ -138,12 +138,14 @@
(let ([one? #f] (let ([one? #f]
[added? #f] [added? #f]
[deps (make-hasheq)] [deps (make-hasheq)]
[known-deps (make-hasheq)]
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]) [all-main? (memq 'depends-all-main (doc-flags (info-doc info)))])
(set-info-deps! (set-info-deps!
info info
(map (lambda (d) (map (lambda (d)
(if (info? d) d (or (hash-ref src->info d #f) d))) (if (info? d) d (or (hash-ref src->info d #f) d)))
(info-deps info))) (info-deps info)))
;; Propagate existing dependencies as expected dependencies:
(for ([d (info-deps info)]) (for ([d (info-deps info)])
(let ([i (if (info? d) d (hash-ref src->info d #f))]) (let ([i (if (info? d) d (hash-ref src->info d #f))])
(if i (if i
@ -159,7 +161,7 @@
(printf " [Removed Dependency: ~a]\n" (printf " [Removed Dependency: ~a]\n"
(doc-src-file (info-doc info)))))))) (doc-src-file (info-doc info))))))))
(when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?) (when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
;; Add all: ;; Add all as expected dependency:
(when (verbose) (when (verbose)
(printf " [Adding all~a as dependencies: ~a]\n" (printf " [Adding all~a as dependencies: ~a]\n"
(if all-main? " main" "") (if all-main? " main" "")
@ -185,10 +187,20 @@
(for ([k (info-undef info)]) (for ([k (info-undef info)])
(let ([i (hash-ref ht k #f)]) (let ([i (hash-ref ht k #f)])
(if i (if i
(when (not (hash-ref deps i #f)) (begin
(set! added? #t) ;; Record a definite dependency:
(hash-set! deps i #t)) (when (not (hash-ref known-deps i #f))
(when first? (unless (eq? (car k) 'dep) (not-found k)))))) (hash-set! known-deps i #t))
;; Record also in the expected-dependency list:
(when (not (hash-ref deps i #f))
(set! added? #t)
(when (verbose)
(printf " [Adding... ~a]\n"
(doc-src-file (info-doc i))))
(hash-set! deps i #t)))
(when first?
(unless (eq? (car k) 'dep)
(not-found k))))))
(when first? (when first?
(for ([(s-key s-ht) (info-searches info)]) (for ([(s-key s-ht) (info-searches info)])
(unless (ormap (lambda (k) (hash-ref ht k #f)) (unless (ormap (lambda (k) (hash-ref ht k #f))
@ -199,6 +211,7 @@
(printf " [Added Dependency: ~a]\n" (printf " [Added Dependency: ~a]\n"
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(set-info-deps! info (hash-map deps (lambda (k v) k))) (set-info-deps! info (hash-map deps (lambda (k v) k)))
(set-info-known-deps! info (hash-map known-deps (lambda (k v) k)))
(set-info-need-in-write?! info #t) (set-info-need-in-write?! info #t)
(set-info-need-run?! info #t)))) (set-info-need-run?! info #t))))
;; If a dependency changed, then we need a re-run: ;; If a dependency changed, then we need a re-run:
@ -302,6 +315,10 @@
(and (pair? cat) (and (pair? cat)
(eq? (car cat) 'omit)))) (eq? (car cat) 'omit))))
(define (any-order keys)
(let ([ht (make-hash)])
(for-each (lambda (k) (hash-set! ht k #t)) keys)
ht))
(define (read-out-sxref) (define (read-out-sxref)
(fasl->s-exp (current-input-port))) (fasl->s-exp (current-input-port)))
@ -368,30 +385,21 @@
(error "old info has wrong version or flags")) (error "old info has wrong version or flags"))
(make-info (make-info
doc doc
(list-ref v-out 1) ; sci (list-ref v-out 1) ; sci (leave serialized)
(let ([v (list-ref v-out 2)]) ; provides (let ([v (list-ref v-out 2)]) ; provides
(if (not (and (pair? v) ; temporary compatibility; used to be not serialized (with-my-namespace
(pair? (car v)) (lambda ()
(integer? (caar v)))) (deserialize v))))
v
(with-my-namespace
(lambda ()
(deserialize v)))))
(let ([v (list-ref v-in 1)]) ; undef (let ([v (list-ref v-in 1)]) ; undef
(if (not (and (pair? v) ; temporary compatibility; used to be not serialized (with-my-namespace
(pair? (car v)) (lambda ()
(integer? (caar v)))) (deserialize v))))
v
(with-my-namespace
(lambda ()
(deserialize v)))))
(let ([v (list-ref v-in 3)]) ; searches (let ([v (list-ref v-in 3)]) ; searches
(if (hash? v) ; temporary compatibility; used to be not serialized (with-my-namespace
v (lambda ()
(with-my-namespace (deserialize v))))
(lambda () (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
(deserialize v))))) null ; known deps (none at this point)
(map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build...
can-run? can-run?
my-time info-out-time my-time info-out-time
(and can-run? (memq 'always-run (doc-flags doc))) (and can-run? (memq 'always-run (doc-flags doc)))
@ -421,8 +429,11 @@
[defs (send renderer get-defined ci)] [defs (send renderer get-defined ci)]
[searches (resolve-info-searches ri)] [searches (resolve-info-searches ri)]
[need-out-write? [need-out-write?
(or (not (equal? (list (list vers (doc-flags doc)) sci defs) (or (not out-v)
out-v)) (not (equal? (list vers (doc-flags doc))
(car out-v)))
(not (serialized=? sci (cadr out-v)))
(not (equal? (any-order defs) (any-order (deserialize (caddr out-v)))))
(info-out-time . > . (current-seconds)))]) (info-out-time . > . (current-seconds)))])
(when (and (verbose) need-out-write?) (when (and (verbose) need-out-write?)
(fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc))) (fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc)))
@ -433,6 +444,7 @@
(send renderer get-undefined ri) (send renderer get-undefined ri)
searches searches
null ; no deps, yet null ; no deps, yet
null ; no known deps, yet
can-run? can-run?
-inf.0 -inf.0
(if need-out-write? (if need-out-write?
@ -485,10 +497,11 @@
[sci (render-time "serialize" (send renderer serialize-info ri))] [sci (render-time "serialize" (send renderer serialize-info ri))]
[defs (render-time "defined" (send renderer get-defined ci))] [defs (render-time "defined" (send renderer get-defined ci))]
[undef (render-time "undefined" (send renderer get-undefined ri))] [undef (render-time "undefined" (send renderer get-undefined ri))]
[in-delta? (not (equal? undef (info-undef info)))] [in-delta? (not (equal? (any-order undef)
[out-delta? (not (equal? (list sci defs) (any-order (info-undef info))))]
(list (info-sci info) [out-delta? (or (not (serialized=? sci (info-sci info)))
(info-provides info))))]) (not (equal? (any-order defs)
(any-order (info-provides info)))))])
(when (verbose) (when (verbose)
(printf " [~a~afor ~a]\n" (printf " [~a~afor ~a]\n"
(if in-delta? "New in " "") (if in-delta? "New in " "")
@ -501,7 +514,9 @@
(set-info-sci! info sci) (set-info-sci! info sci)
(set-info-provides! info defs) (set-info-provides! info defs)
(set-info-undef! info undef) (set-info-undef! info undef)
(when in-delta? (set-info-deps! info null)) ; recompute deps outside (when in-delta?
;; Reset expected dependencies to known dependencies, and recompute later:
(set-info-deps! info (info-known-deps info)))
(when (or out-delta? (info-need-out-write? info)) (when (or out-delta? (info-need-out-write? info))
(unless latex-dest (unless latex-dest
(render-time "xref-out" (write-out info))) (render-time "xref-out" (write-out info)))

View File

@ -4,16 +4,16 @@
(Section 'serialization) (Section 'serialization)
(require mzlib/serialize) (require scheme/serialize)
;; ---------------------------------------- ;; ----------------------------------------
(define insp (current-inspector)) (define insp (current-inspector))
(define-serializable-struct a () insp) (define-serializable-struct a () #:inspector insp #:mutable)
(define-serializable-struct b (x y) insp) (define-serializable-struct b (x y) #:inspector insp #:mutable)
(define-serializable-struct (c a) (z) insp) (define-serializable-struct (c a) (z) #:inspector insp #:mutable)
(define-serializable-struct (d b) (w) insp) (define-serializable-struct (d b) (w) #:inspector insp #:mutable)
(define (same? v1 v2) (define (same? v1 v2)
;; This is not quite the same as `equal?', veuase it knows ;; This is not quite the same as `equal?', veuase it knows
@ -95,7 +95,9 @@
(parameterize ([print-graph #t]) (parameterize ([print-graph #t])
(test #t serializable? v) (test #t serializable? v)
(test #t same? v v) (test #t same? v v)
(test #t same? v (deserialize (serialize v))))) (test #t same? v (deserialize (serialize v)))
(test #t serialized=? (serialize v) (serialize v))
(test #f serialized=? (serialize v) (serialize (not v)))))
(define (mk-ht mk) (define (mk-ht mk)
(let ([ht (mk)]) (let ([ht (mk)])

View File

@ -13,7 +13,7 @@
(module test2 mzscheme (module test2 mzscheme
(require mzlib/unit (require mzlib/unit
test) 'test)
(define-unit u1 (import) (export s) (define-unit u1 (import) (export s)
(define a 1)) (define a 1))
(define-unit u2 (import s) (export) (define-unit u2 (import s) (export)
@ -25,15 +25,15 @@
) )
;; 4 ;; 4
(require test2) (require 'test2)
(module test3 mzscheme (module test3 mzscheme
(require mzlib/unit (require mzlib/unit
test) 'test)
(define-unit u1 (import) (export s) (define-unit u1 (import) (export s)
(define a 1)) (define a 1))
(define-values/invoke-unit u1 (import) (export (rename s))) (define-values/invoke-unit u1 (import) (export (rename s)))
(printf "~a~n" (+ y (z))) (printf "~a~n" (+ y (z)))
) )
;;4 ;;4
(require test3) (require 'test3)