diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5fbf347c94..f3ee228f9d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -228,6 +228,11 @@ (traverse-stx expr visit)] [(wrapped? expr) (traverse-wrapped expr visit)] + [(hash? expr) + (when (visit expr) + (for ([(k v) (in-hash expr)]) + (traverse-data k visit) + (traverse-data v visit)))] [else (void)])) @@ -987,16 +992,18 @@ (for ([v (in-vector expr)]) (out-data v out))] [(hash? expr) - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))] + (out-shared expr out + (lambda () + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? expr) 2] + [(hash-eq? expr) 0] + [else 1]) + out) + (out-number (hash-count expr) out) + (for ([(k v) (in-hash expr)]) + (out-data k out) + (out-data v out))))] [(svector? expr) (let* ([vec (svector-vec expr)] [len (vector-length vec)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6f1b338560..c7f6670fc3 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -15,8 +15,6 @@ Lines 628, 630 seem to be only for debugging and should probably throw errors - unmarshal-stx-get also seems to be for debugging and should probably throw an error - vector and pair cases of decode-wraps seem to do different things from the corresponding C code Line 816: This should be an eqv placeholder (but they don't exist) @@ -29,8 +27,6 @@ collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec - We seem to leave placeholders for hash-tables in the structs - |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -501,15 +497,9 @@ ;; ---------------------------------------- ;; Syntax unmarshaling - (define (decode-stx cp v) (if (integer? v) - (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)]) - (if decoded? - v2 - (let ([v2 (decode-stx cp v2)]) - (unmarshal-stx-set! cp v v2) - v2))) + (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) (let-values ([(cert-marks v encoded-wraps) (match v @@ -564,29 +554,17 @@ (map loop (cdr (vector->list (struct->vector v)))))))] [else (add-wrap v)])))))) - - (define (decode-wraps cp w) ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) (if (integer? w) - (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)]) - (if decoded? - w2 - (let ([w2 (decode-wraps cp w2)]) - (unmarshal-stx-set! cp w w2) - w2))) + (unmarshal-stx-get/decode cp w decode-wraps) (map (lambda (a) (let aloop ([a a]) ; A wrap-elem is either (cond ; A reference [(integer? a) - (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) - (if decoded? - a2 - (let ([a2 (aloop a2)]) - (unmarshal-stx-set! cp a a2) - a2)))] + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] ; A mark (not actually a number as the C says, but a (list ) [(and (pair? a) (null? (cdr a)) (number? (car a))) (make-wrap-mark (car a))] @@ -704,23 +682,6 @@ [module-path-index (make-simple-module-binding module-path-index)])))) -(define (unmarshal-stx-get cp pos) - (if (pos . >= . (vector-length (cport-symtab cp))) - (values `(#%bad-index ,pos) #t) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - (values v #f))) - (values v (vector-ref (cport-decoded cp) pos)))))) - -(define (unmarshal-stx-set! cp pos v) - (vector-set! (cport-symtab cp) pos v) - (vector-set! (cport-decoded cp) pos #t)) - (define (parse-module-path-index cp s) s) ;; ---------------------------------------- @@ -738,15 +699,7 @@ (case cpt-tag [(delayed) (let ([pos (read-compact-number cp)]) - (let ([v (vector-ref (cport-symtab cp) pos)]) - (if (not-ready? v) - (let ([save-pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) - (let ([v (read-compact cp)]) - (vector-set! (cport-symtab cp) pos v) - (set-cport-pos! cp save-pos) - v)) - v)))] + (read-sym cp pos))] [(escape) (let* ([len (read-compact-number cp)] [s (cport-get-bytes cp len)]) @@ -841,9 +794,8 @@ [len (read-compact-number cp)]) ((case eq [(0) make-hasheq-placeholder] - ; XXX One of these should be eqv [(1) make-hash-placeholder] - [(2) make-hash-placeholder]) + [(2) make-hasheqv-placeholder]) (for/list ([i (in-range len)]) (cons (read-compact cp) (read-compact cp)))))] @@ -894,16 +846,8 @@ (read-compact cp))))]) (read (open-input-bytes #"x")))))] [(symref) - (let* ([l (read-compact-number cp)] - [v (vector-ref (cport-symtab cp) l)]) - (if (not-ready? v) - (let ([pos (cport-pos cp)]) - (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l))) - (let ([v (read-compact cp)]) - (set-cport-pos! cp pos) - (vector-set! (cport-symtab cp) l v) - v)) - v))] + (let* ([l (read-compact-number cp)]) + (read-sym cp l))] [(weird-symbol) (let ([uninterned (read-compact-number cp)] [str (read-compact-chars cp (read-compact-number cp))]) @@ -934,7 +878,7 @@ [(closure) (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (vector-set! (cport-symtab cp) l ind) + (placeholder-set! (vector-ref (cport-symtab cp) l) ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -956,6 +900,36 @@ [else (cons v (loop (sub1 need-car) proper))])))) +(define (unmarshal-stx-get/decode cp pos decode-stx) + (define v2 (read-sym cp pos)) + (define decoded? (vector-ref (cport-decoded cp) pos)) + (if decoded? + v2 + (let ([dv2 (decode-stx cp v2)]) + (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (vector-set! (cport-decoded cp) pos #t) + dv2))) + +(require unstable/markparam) +(define read-sym-mark (mark-parameter)) +(define (read-sym cp i) + (define symtab (cport-symtab cp)) + (define ph (vector-ref symtab i)) + ; We are reading this already, so return the placeholder + (if (memq i (mark-parameter-all read-sym-mark)) + ph + ; Otherwise, try to read it and return the real thing + (local [(define vv (placeholder-get ph))] + (when (not-ready? vv) + (local [(define save-pos (cport-pos cp))] + (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) + (mark-parameterize + ([read-sym-mark i]) + (let ([v (read-compact cp)]) + (placeholder-set! ph v))) + (set-cport-pos! cp save-pos))) + (placeholder-get ph)))) + ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse port) @@ -990,18 +964,17 @@ (unless (eof-object? (read-byte port)) (error 'zo-parse "File too big")) - (define symtab (make-vector symtabsize (make-not-ready))) + (define nr (make-not-ready)) + (define symtab + (build-vector symtabsize (λ (i) (make-placeholder nr)))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) - (define vv (vector-ref symtab i)) - (when (not-ready? vv) - (set-cport-pos! cp (vector-ref so* (sub1 i))) - (let ([v (read-compact cp)]) - (vector-set! symtab i v)))) + (read-sym cp i)) (set-cport-pos! cp shared-size) - (read-marshalled 'compilation-top-type cp))) + (make-reader-graph + (read-marshalled 'compilation-top-type cp)))) ;; ---------------------------------------- diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 2d2413594d..7c3e317bd4 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,7 +22,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...) #:transparent) + (define-struct id+par (field-id ...) #:prefab) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -57,7 +57,7 @@ (define-form-struct (expr form) ()) ;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:transparent) +(define-struct indirect ([v #:mutable]) #:prefab) (define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt new file mode 100644 index 0000000000..b8ab07e067 --- /dev/null +++ b/collects/tests/compiler/zo-exs.rkt @@ -0,0 +1,22 @@ +#lang racket +(require compiler/zo-parse + compiler/zo-marshal + tests/eli-tester) + +(define (roundtrip ct) + (define bs (zo-marshal ct)) + (test bs + (zo-parse (open-input-bytes bs)) => ct)) + +(test + (local [(define (hash-test make-hash-placeholder) + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (local [(define ht-ph (make-placeholder #f)) + (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] + (placeholder-set! ht-ph ht) + (make-reader-graph ht)))))] + (hash-test make-hash-placeholder) + (hash-test make-hasheq-placeholder) + (hash-test make-hasheqv-placeholder))) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt old mode 100644 new mode 100755 index e805c64e1e..d280efac02 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -1,3 +1,8 @@ +#!/bin/sh +#| +exec racket -t "$0" -- -s -t 60 -v -R $* +|# + #lang scheme (require compiler/zo-parse compiler/zo-marshal @@ -5,9 +10,40 @@ setup/dirs) ;; Helpers +(define (bytes->hex-string bs) + (apply string-append + (for/list ([b bs]) + (format "~a~x" + (if (b . <= . 15) "0" "") + b)))) + +(define (show-bytes-side-by-side orig new) + (define max-length + (max (bytes-length orig) (bytes-length new))) + (define BYTES-PER-LINE 38) + (define lines + (ceiling (/ max-length BYTES-PER-LINE))) + (define (subbytes* b s e) + (subbytes b (min s (bytes-length b)) (min e (bytes-length b)))) + (for ([line (in-range lines)]) + (define start (* line BYTES-PER-LINE)) + (define end (* (add1 line) BYTES-PER-LINE)) + (printf "+ ~a\n" (bytes->hex-string (subbytes* orig start end))) + (printf "- ~a\n" (bytes->hex-string (subbytes* new start end))))) + (define (bytes-gulp f) (with-input-from-file f (λ () (port->bytes (current-input-port))))) + +(define (read-compiled-bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (parameterize ([read-accept-compiled #t]) + (read ib))) + (lambda () + (close-input-port ib)))) + (define (zo-parse/bytes bs) (define ib (open-input-bytes bs)) (dynamic-wind void @@ -245,6 +281,13 @@ (lambda (file) (run/stages* file [stage serious? e] ...))))) +(define debugging? (make-parameter #f)) + +(define (print-bytes orig new) + (when (debugging?) + (show-bytes-side-by-side orig new)) + #t) + (define-stages (stages run!) file [read-orig @@ -279,6 +322,12 @@ [decompile-parsed #t (decompile parse-orig)] + [show-orig-and-marshal-parsed + #f + (print-bytes read-orig marshal-parsed)] + [c-parse-marshalled + #f + (read-compiled-bytes marshal-parsed)] [compare-orig-to-marshalled #f (bytes-not-equal?-error read-orig marshal-parsed)]) @@ -345,6 +394,9 @@ #;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo")) (command-line #:program "zo-test" #:once-each + [("-D") + "Enable debugging output" + (debugging? #t)] [("-s" "--stop-on-first-error") "Stop testing when first error is encountered" (stop-on-first-error #t)] diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 639fe36e10..19c392502d 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -103,10 +103,10 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket"))) null #f - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + `(,(flags "l") ,(string-append "tests/racket/" filename))) (try-exe dest expect mred?) ;; Try explicit prefix: @@ -116,7 +116,7 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((,pfx (lib ,filename "tests" "mzscheme")) + `((,pfx (lib ,filename "tests" "racket")) (#t (lib "scheme/init"))) null #f @@ -133,7 +133,7 @@ ;; Try full path, and use literal S-exp to start (printf ">>>literal sexp\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (let ([path (build-path (collection-path "tests" "racket") filename)]) (make-embedding-executable dest mred? #f `((#t ,path)) @@ -146,7 +146,7 @@ ;; Use `file' form: (printf ">>>file\n") (prepare dest filename) - (let ([path (build-path (collection-path "tests" "mzscheme") filename)]) + (let ([path (build-path (collection-path "tests" "racket") filename)]) (make-embedding-executable dest mred? #f `((#t (file ,(path->string path)))) @@ -159,7 +159,7 @@ ;; Use relative path (printf ">>>relative path\n") (prepare dest filename) - (parameterize ([current-directory (collection-path "tests" "mzscheme")]) + (parameterize ([current-directory (collection-path "tests" "racket")]) (make-embedding-executable dest mred? #f `((#f ,filename)) @@ -174,13 +174,13 @@ (prepare dest filename) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme")) - (#t (lib "embed-me3.ss" "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket")) + (#t (lib "embed-me3.rkt" "tests" "racket"))) null (base-compile `(begin - (namespace-require '(lib "embed-me3.ss" "tests" "mzscheme")) - (namespace-require '(lib ,filename "tests" "mzscheme")))) + (namespace-require '(lib "embed-me3.rkt" "tests" "racket")) + (namespace-require '(lib ,filename "tests" "racket")))) `(,(flags ""))) (try-exe dest (string-append "3 is here, too? #t\n" expect) mred?) @@ -195,14 +195,14 @@ '(namespace-require ''#%kernel))))) (make-embedding-executable dest mred? #f - `((#t (lib ,filename "tests" "mzscheme"))) + `((#t (lib ,filename "tests" "racket"))) (list tmp - (build-path (collection-path "tests" "mzscheme") "embed-me4.ss")) + (build-path (collection-path "tests" "racket") "embed-me4.rktl")) `(with-output-to-file "stdout" (lambda () (display "... and more!\n")) 'append) - `(,(flags "l") ,(string-append "tests/mzscheme/" filename))) + `(,(flags "l") ,(string-append "tests/racket/" filename))) (delete-file tmp)) (try-exe dest (string-append "This is the literal expression 4.\n" @@ -210,12 +210,12 @@ expect) mred?))) - (one-mz-test "embed-me1.ss" "This is 1\n" #t) - (one-mz-test "embed-me1b.ss" "This is 1b\n" #f) - (one-mz-test "embed-me1c.ss" "This is 1c\n" #f) - (one-mz-test "embed-me1d.ss" "This is 1d\n" #f) - (one-mz-test "embed-me1e.ss" "This is 1e\n" #f) - (one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t) + (one-mz-test "embed-me1.rkt" "This is 1\n" #t) + (one-mz-test "embed-me1b.rkt" "This is 1b\n" #f) + (one-mz-test "embed-me1c.rkt" "This is 1c\n" #f) + (one-mz-test "embed-me1d.rkt" "This is 1d\n" #f) + (one-mz-test "embed-me1e.rkt" "This is 1e\n" #f) + (one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t) ;; Try unicode expr and cmdline: (prepare dest "unicode") @@ -238,13 +238,13 @@ (mz-tests #t) (begin - (prepare mr-dest "embed-me5.ss") + (prepare mr-dest "embed-me5.rkt") (make-embedding-executable mr-dest #t #f - `((#t (lib "embed-me5.ss" "tests" "mzscheme"))) + `((#t (lib "embed-me5.rkt" "tests" "racket"))) null #f - `("-l" "tests/mzscheme/embed-me5.ss")) + `("-l" "tests/racket/embed-me5.rkt")) (try-exe mr-dest "This is 5: #\n" #t)) ;; Try the mzc interface: @@ -260,15 +260,15 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me1.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt"))) (try-exe (mk-dest mred?) "This is 1\n" mred?) - ;; Check that etc.ss isn't found if it's not included: + ;; Check that etc.rkt isn't found if it's not included: (printf ">>not included\n") (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) ;; And it is found if it is included: @@ -276,8 +276,8 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.ss" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + "++lib" "mzlib/etc.rkt" + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred?) ;; Or, it's found if we set the collection path: @@ -287,7 +287,7 @@ (path->string (mk-dest mred?)) "--collects-path" (path->string (find-collects-dir)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) ;; Don't try a distribution for this one: (try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?) @@ -296,10 +296,10 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - "++lib" "mzlib/etc.ss" + "++lib" "mzlib/etc.rkt" "--collects-dest" "cts" "--collects-path" "cts" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt"))) (try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution (delete-directory/files "cts") (test #f system* (mk-dest mred?)) @@ -326,17 +326,17 @@ (system-library-subpath))) (define ext-file - (build-path ext-dir (append-extension-suffix "embed-me8_ss"))) + (build-path ext-dir (append-extension-suffix "embed-me8_rkt"))) (define ss-file - (build-path (find-system-path 'temp-dir) "embed-me9.ss")) + (build-path (find-system-path 'temp-dir) "embed-me9.rkt")) (make-directory* ext-dir) (system* mzc "--cc" "-d" (path->string (path-only obj-file)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me8.c"))) (system* mzc "--ld" (path->string ext-file) @@ -344,7 +344,7 @@ (when (file-exists? ss-file) (delete-file ss-file)) - (copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss") + (copy-file (build-path (collection-path "tests" "racket") "embed-me9.rkt") ss-file) (system* mzc @@ -361,7 +361,7 @@ (system* mzc (if mred? "--gui-exe" "--exe") (path->string (mk-dest mred?)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt"))) (try-exe (mk-dest mred?) "#t\n" mred?))) (extension-test #f) @@ -372,7 +372,7 @@ (system* mzc "--gui-exe" (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt"))) (try-exe (mk-dest #t) "This is 5: #\n" #t)) ;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files: @@ -382,34 +382,34 @@ (test #t system* (build-path (find-console-bin-dir) "mred") "-qu" - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")) (path->string direct)) (system* mzc "--gui-exe" (path->string (mk-dest #t)) - (path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))) + (path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))) (try-exe (mk-dest #t) "plotted\n" #t)) ;; Try including source that needs a reader extension (define (try-reader-test mred?) (define dest (mk-dest mred?)) - (define filename "embed-me11.ss") + (define filename "embed-me11.rkt") (define (flags s) (string-append "-" s)) (create-embedding-executable dest - #:modules `((#t (lib ,filename "tests" "mzscheme"))) - #:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" filename)) + #:modules `((#t (lib ,filename "tests" "racket"))) + #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) (equal? name (string->path filename)))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) (if (equal? name (string->path filename)) - '((lib "embed-me11-rd.ss" "tests" "mzscheme")) + '((lib "embed-me11-rd.rkt" "tests" "racket")) null))) #:mred? mred?)