From 3f60a478ad5e955a723d34ca970060652279fd13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Jun 2008 19:28:08 +0000 Subject: [PATCH] =?UTF-8?q?use=20new=20'serialized=3D=3F'=20to=20tighten?= =?UTF-8?q?=20setup=20scribble=20fixpoint?= svn: r10428 --- collects/scheme/private/serialize.ss | 113 ++++++++---- collects/scribble/search.ss | 162 ++++++++++-------- .../scribblings/reference/serialization.scrbl | 24 +++ collects/setup/scribble.ss | 83 +++++---- collects/tests/mzscheme/serialize.ss | 14 +- collects/tests/units/test-cert.ss | 8 +- 6 files changed, 253 insertions(+), 151 deletions(-) diff --git a/collects/scheme/private/serialize.ss b/collects/scheme/private/serialize.ss index 7598b74359..d2424867b4 100644 --- a/collects/scheme/private/serialize.ss +++ b/collects/scheme/private/serialize.ss @@ -17,6 +17,8 @@ serialize deserialize + serialized=? + deserialize-module-guard) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -362,7 +364,7 @@ (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 ;; refereds before referees. A `not-ready' object ;; indicates a reference before a value is ready, @@ -374,12 +376,12 @@ (let* ([v (vector-ref (not-ready-shares sv) n)] [val (if (box? v) (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) val) sv))) - (define (deserialize-one v share mod-map) + (define (deserialize-one v share mod-map module-path-index-join) (let loop ([v v]) (cond [(or (boolean? v) @@ -398,7 +400,7 @@ (apply (deserialize-info-maker info) (map loop (cdr v))))] [else (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)))] [(void) (void)] [(u) (let ([x (cdr v)]) @@ -488,17 +490,39 @@ [(mpi) (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) - (let-values ([(vers l) - (if (pair? (car l)) - (values (caar l) (cdr l)) - (values 0 l))]) + (let-values ([(vers l) (extract-version l)]) (let ([mod-map (make-vector (list-ref l 0))] - [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)]) + [mod-map-l (list-ref l 1)]) ;; Load constructor mapping (let loop ([n 0][l mod-map-l]) (unless (null? l) @@ -512,21 +536,48 @@ ;; Register maker and struct type: (vector-set! mod-map n des)) (loop (add1 n) (cdr l)))) - ;; 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) - (loop (add1 n) (cdr l)))) - ;; Fixup shell for graphs - (for-each (lambda (n+v) - (let ([v (deserialize-one (cdr n+v) share mod-map)]) - ((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)))))) + (deserialize-with-map mod-map vers l module-path-index-join)))) + + ;; ---------------------------------------- + + (define (serialized=? l1 l2) + (let-values ([(vers1 l1) (extract-version l1)] + [(vers2 l2) (extract-version l2)]) + (let ([mod-map1 (make-vector (list-ref l1 0))] + [mod-map1-l (list-ref l1 1)] + [mod-map2 (make-vector (list-ref l2 0))] + [mod-map2-l (list-ref l2 1)] + [make-key (lambda (path+name) + (if (car path+name) + (let ([p (unprotect-path (car path+name))] + [sym (cdr path+name)]) + (list p sym)) + (list #f (cdr path+name))))] + [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))))))) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index 7eb879dabb..034b72558f 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -58,13 +58,14 @@ (let ([seen (make-hasheq)] [search-key #f]) (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 [(null? queue) (if (null? rqueue) ;; Not documented #f - (loop (reverse rqueue) null))] + (loop (reverse rqueue) null need-result?))] [else (let ([mod (list-ref (car queue) 0)] [id (list-ref (car queue) 1)] @@ -80,77 +81,86 @@ (not search-key)) (set! search-key eb)) (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))]) - (or (and v - (let ([v (resolve-get/tentative part ri `(form ,eb))]) - (or (and v `(form ,eb)) - `(def ,eb)))) - ;; Maybe it's re-exported from this module... - ;; Try a shortcut: - (if (eq? rmp (and (car b) (module-path-index-resolve (car b)))) - ;; Not defined through this path, so keep looking - (loop queue rqueue) - ;; Check parents, if we can get the source: - (if (and (path? (resolved-module-path-name rmp)) - (not (hash-ref seen rmp #f))) - (let ([exports - (hash-ref - module-info-cache - rmp - (lambda () - (let-values ([(valss stxess) - (with-handlers ([exn:fail? - (lambda (exn) - (values null null))]) - (module-compiled-exports - (get-module-code (resolved-module-path-name rmp) - #:choose (lambda (src zo so) 'zo))))]) - (let ([t - ;; Merge the two association lists: - (let loop ([base valss] - [stxess stxess]) - (cond - [(null? stxess) base] - [(assoc (caar stxess) base) - => (lambda (l) - (loop (cons (cons (car l) - (append (cdar stxess) - (cdr l))) - (remq l base)) - (cdr stxess)))] - [else (loop (cons (car stxess) - base) - (cdr stxess))]))]) - (hash-set! module-info-cache rmp t) - t))))]) - (hash-set! seen rmp #t) - (let ([a (assq id (let ([a (assoc export-phase exports)]) - (if a - (cdr a) - null)))]) - (if a - (loop queue - (append (map (lambda (m) - (if (pair? m) - (list (module-path-index-rejoin (car m) mod) - (list-ref m 2) - defn-phase - (list-ref m 1) - (list-ref m 3)) - (list (module-path-index-rejoin m mod) - id - 0 - 0 - 0))) - (cadr a)) - rqueue)) - (begin - ;; A dead end may not be our fault: the files could - ;; have changed in inconsistent ways. So just say #f - ;; 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)))))))]))))))) + (let* ([here-result + (and need-result? + v + (let ([v (resolve-get/tentative part ri `(form ,eb))]) + (or (and v `(form ,eb)) + `(def ,eb))))] + [need-result? (and need-result? (not here-result))]) + ;; Even if we've found `here-result', look deeper so that we have + ;; consistent `dep' results. + (let ([nest-result + ;; Maybe it's re-exported from this module... + ;; Try a shortcut: + (if (eq? rmp (and (car b) (module-path-index-resolve (car b)))) + ;; Not defined through this path, so keep looking + (loop queue rqueue need-result?) + ;; Check parents, if we can get the source: + (if (and (path? (resolved-module-path-name rmp)) + (not (hash-ref seen rmp #f))) + (let ([exports + (hash-ref + module-info-cache + rmp + (lambda () + (let-values ([(valss stxess) + (with-handlers ([exn:fail? + (lambda (exn) + (values null null))]) + (module-compiled-exports + (get-module-code (resolved-module-path-name rmp) + #:choose (lambda (src zo so) 'zo))))]) + (let ([t + ;; Merge the two association lists: + (let loop ([base valss] + [stxess stxess]) + (cond + [(null? stxess) base] + [(assoc (caar stxess) base) + => (lambda (l) + (loop (cons (cons (car l) + (append (cdar stxess) + (cdr l))) + (remq l base)) + (cdr stxess)))] + [else (loop (cons (car stxess) + base) + (cdr stxess))]))]) + (hash-set! module-info-cache rmp t) + t))))]) + (hash-set! seen rmp #t) + (let ([a (assq id (let ([a (assoc export-phase exports)]) + (if a + (cdr a) + null)))]) + (if a + (loop queue + (append (map (lambda (m) + (if (pair? m) + (list (module-path-index-rejoin (car m) mod) + (list-ref m 2) + defn-phase + (list-ref m 1) + (list-ref m 3)) + (list (module-path-index-rejoin m mod) + id + 0 + 0 + 0))) + (cadr a)) + rqueue) + need-result?) + (begin + ;; A dead end may not be our fault: the files could + ;; have changed in inconsistent ways. So just say #f + ;; 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))))))]))))))) diff --git a/collects/scribblings/reference/serialization.scrbl b/collects/scribblings/reference/serialization.scrbl index 1c4e39afaf..b57db3760f 100644 --- a/collects/scribblings/reference/serialization.scrbl +++ b/collects/scribblings/reference/serialization.scrbl @@ -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 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?)]{ A parameter whose value is called by @scheme[deserialize] before diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 200c6d3bd6..041a999b41 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -22,7 +22,7 @@ (define verbose (make-parameter #t)) (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? need-in-write? need-out-write? vers rendered? failed?) @@ -138,12 +138,14 @@ (let ([one? #f] [added? #f] [deps (make-hasheq)] + [known-deps (make-hasheq)] [all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]) (set-info-deps! info (map (lambda (d) (if (info? d) d (or (hash-ref src->info d #f) d))) (info-deps info))) + ;; Propagate existing dependencies as expected dependencies: (for ([d (info-deps info)]) (let ([i (if (info? d) d (hash-ref src->info d #f))]) (if i @@ -159,7 +161,7 @@ (printf " [Removed Dependency: ~a]\n" (doc-src-file (info-doc info)))))))) (when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?) - ;; Add all: + ;; Add all as expected dependency: (when (verbose) (printf " [Adding all~a as dependencies: ~a]\n" (if all-main? " main" "") @@ -185,10 +187,20 @@ (for ([k (info-undef info)]) (let ([i (hash-ref ht k #f)]) (if i - (when (not (hash-ref deps i #f)) - (set! added? #t) - (hash-set! deps i #t)) - (when first? (unless (eq? (car k) 'dep) (not-found k)))))) + (begin + ;; Record a definite dependency: + (when (not (hash-ref known-deps i #f)) + (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? (for ([(s-key s-ht) (info-searches info)]) (unless (ormap (lambda (k) (hash-ref ht k #f)) @@ -199,6 +211,7 @@ (printf " [Added Dependency: ~a]\n" (doc-src-file (info-doc info)))) (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-run?! info #t)))) ;; If a dependency changed, then we need a re-run: @@ -302,6 +315,10 @@ (and (pair? cat) (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) (fasl->s-exp (current-input-port))) @@ -368,30 +385,21 @@ (error "old info has wrong version or flags")) (make-info doc - (list-ref v-out 1) ; sci + (list-ref v-out 1) ; sci (leave serialized) (let ([v (list-ref v-out 2)]) ; provides - (if (not (and (pair? v) ; temporary compatibility; used to be not serialized - (pair? (car v)) - (integer? (caar v)))) - v - (with-my-namespace - (lambda () - (deserialize v))))) + (with-my-namespace + (lambda () + (deserialize v)))) (let ([v (list-ref v-in 1)]) ; undef - (if (not (and (pair? v) ; temporary compatibility; used to be not serialized - (pair? (car v)) - (integer? (caar v)))) - v - (with-my-namespace - (lambda () - (deserialize v))))) + (with-my-namespace + (lambda () + (deserialize v)))) (let ([v (list-ref v-in 3)]) ; searches - (if (hash? v) ; temporary compatibility; used to be not serialized - v - (with-my-namespace - (lambda () - (deserialize v))))) - (map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build... + (with-my-namespace + (lambda () + (deserialize v)))) + (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build... + null ; known deps (none at this point) can-run? my-time info-out-time (and can-run? (memq 'always-run (doc-flags doc))) @@ -421,8 +429,11 @@ [defs (send renderer get-defined ci)] [searches (resolve-info-searches ri)] [need-out-write? - (or (not (equal? (list (list vers (doc-flags doc)) sci defs) - out-v)) + (or (not 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)))]) (when (and (verbose) need-out-write?) (fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc))) @@ -433,6 +444,7 @@ (send renderer get-undefined ri) searches null ; no deps, yet + null ; no known deps, yet can-run? -inf.0 (if need-out-write? @@ -485,10 +497,11 @@ [sci (render-time "serialize" (send renderer serialize-info ri))] [defs (render-time "defined" (send renderer get-defined ci))] [undef (render-time "undefined" (send renderer get-undefined ri))] - [in-delta? (not (equal? undef (info-undef info)))] - [out-delta? (not (equal? (list sci defs) - (list (info-sci info) - (info-provides info))))]) + [in-delta? (not (equal? (any-order undef) + (any-order (info-undef info))))] + [out-delta? (or (not (serialized=? sci (info-sci info))) + (not (equal? (any-order defs) + (any-order (info-provides info)))))]) (when (verbose) (printf " [~a~afor ~a]\n" (if in-delta? "New in " "") @@ -501,7 +514,9 @@ (set-info-sci! info sci) (set-info-provides! info defs) (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)) (unless latex-dest (render-time "xref-out" (write-out info))) diff --git a/collects/tests/mzscheme/serialize.ss b/collects/tests/mzscheme/serialize.ss index 8917825e80..d41a578960 100644 --- a/collects/tests/mzscheme/serialize.ss +++ b/collects/tests/mzscheme/serialize.ss @@ -4,16 +4,16 @@ (Section 'serialization) -(require mzlib/serialize) +(require scheme/serialize) ;; ---------------------------------------- (define insp (current-inspector)) -(define-serializable-struct a () insp) -(define-serializable-struct b (x y) insp) -(define-serializable-struct (c a) (z) insp) -(define-serializable-struct (d b) (w) insp) +(define-serializable-struct a () #:inspector insp #:mutable) +(define-serializable-struct b (x y) #:inspector insp #:mutable) +(define-serializable-struct (c a) (z) #:inspector insp #:mutable) +(define-serializable-struct (d b) (w) #:inspector insp #:mutable) (define (same? v1 v2) ;; This is not quite the same as `equal?', veuase it knows @@ -95,7 +95,9 @@ (parameterize ([print-graph #t]) (test #t serializable? 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) (let ([ht (mk)]) diff --git a/collects/tests/units/test-cert.ss b/collects/tests/units/test-cert.ss index 0ae87d2355..41d1d44fe4 100644 --- a/collects/tests/units/test-cert.ss +++ b/collects/tests/units/test-cert.ss @@ -13,7 +13,7 @@ (module test2 mzscheme (require mzlib/unit - test) + 'test) (define-unit u1 (import) (export s) (define a 1)) (define-unit u2 (import s) (export) @@ -25,15 +25,15 @@ ) ;; 4 - (require test2) + (require 'test2) (module test3 mzscheme (require mzlib/unit - test) + 'test) (define-unit u1 (import) (export s) (define a 1)) (define-values/invoke-unit u1 (import) (export (rename s))) (printf "~a~n" (+ y (z))) ) ;;4 - (require test3) + (require 'test3)