Fixing parts of zo-marshal re protect-quote; parallelizing zo-test; there is no the path error again in zo-marshal though
This commit is contained in:
Jay McCarthy
parent
f46144d5d3
commit
8d36dfad81
|
|
@ -16,7 +16,6 @@
|
|||
|
||||
Less sharing occurs than in the C implementation, creating much larger files
|
||||
|
||||
protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off
|
||||
|#
|
||||
|
||||
(define current-wrapped-ht (make-parameter #f))
|
||||
|
|
@ -681,11 +680,11 @@
|
|||
(out-module form out)]
|
||||
[(struct def-values (ids rhs))
|
||||
(out-syntax DEFINE_VALUES_EXPD
|
||||
(list->vector (cons rhs ids))
|
||||
(list->vector (cons (protect-quote rhs) ids))
|
||||
out)]
|
||||
[(struct def-syntaxes (ids rhs prefix max-let-depth))
|
||||
(out-syntax DEFINE_SYNTAX_EXPD
|
||||
(list->vector (list* rhs
|
||||
(list->vector (list* (protect-quote rhs)
|
||||
prefix
|
||||
max-let-depth
|
||||
*dummy*
|
||||
|
|
@ -693,7 +692,7 @@
|
|||
out)]
|
||||
[(struct def-for-syntax (ids rhs prefix max-let-depth))
|
||||
(out-syntax DEFINE_FOR_SYNTAX_EXPD
|
||||
(list->vector (list* rhs
|
||||
(list->vector (list* (protect-quote rhs)
|
||||
prefix
|
||||
max-let-depth
|
||||
*dummy*
|
||||
|
|
@ -1091,11 +1090,12 @@
|
|||
|
||||
(define-struct quoted (v) #:prefab)
|
||||
|
||||
; protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off
|
||||
(define (protect-quote v)
|
||||
v
|
||||
#;(if (or (list? v) (vector? v) (box? v) (hash? v))
|
||||
(make-quoted v)
|
||||
v))
|
||||
#;v
|
||||
(if (or (list? v) (vector? v) (box? v) (hash? v))
|
||||
(make-quoted v)
|
||||
v))
|
||||
|
||||
|
||||
(define-struct svector (vec))
|
||||
|
|
|
|||
|
|
@ -19,4 +19,17 @@
|
|||
(make-reader-graph ht)))))]
|
||||
(hash-test make-hash-placeholder)
|
||||
(hash-test make-hasheq-placeholder)
|
||||
(hash-test make-hasheqv-placeholder)))
|
||||
(hash-test make-hasheqv-placeholder))
|
||||
|
||||
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(current-directory)))
|
||||
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(list (current-directory)))))
|
||||
|
||||
|
||||
|
|
|
|||
12
collects/tests/compiler/zo-test-util.rkt
Normal file
12
collects/tests/compiler/zo-test-util.rkt
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#lang racket
|
||||
|
||||
(struct result (phase) #:prefab)
|
||||
(struct failure result (serious? msg) #:prefab)
|
||||
(struct success result () #:prefab)
|
||||
|
||||
(provide/contract
|
||||
[struct result ([phase symbol?])]
|
||||
[struct failure ([phase symbol?]
|
||||
[serious? boolean?]
|
||||
[msg string?])]
|
||||
[struct success ([phase symbol?])])
|
||||
270
collects/tests/compiler/zo-test-worker.rkt
Normal file
270
collects/tests/compiler/zo-test-worker.rkt
Normal file
|
|
@ -0,0 +1,270 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
compiler/decompile
|
||||
racket/port
|
||||
racket/bool
|
||||
racket/list
|
||||
racket/match
|
||||
"zo-test-util.rkt")
|
||||
|
||||
(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
|
||||
(lambda ()
|
||||
(zo-parse ib))
|
||||
(lambda ()
|
||||
(close-input-port ib))))
|
||||
|
||||
(define (bytes-not-equal?-error b1 b2)
|
||||
(unless (bytes=? b1 b2)
|
||||
(error 'bytes-not-equal?-error "Not equal")))
|
||||
|
||||
(define (replace-file file bytes)
|
||||
(with-output-to-file file
|
||||
(λ () (write-bytes bytes))
|
||||
#:exists 'truncate))
|
||||
|
||||
(define (equal?/why-not v1 v2)
|
||||
(define v1->v2 (make-hasheq))
|
||||
(define (interned-symbol=? s1 s2)
|
||||
(symbol=? (hash-ref! v1->v2 s1 s2) s2))
|
||||
(define (yield p m v1 v2)
|
||||
(error 'equal?/why-not "~a in ~a: ~S ~S"
|
||||
m (reverse p) v1 v2))
|
||||
(define (inner p v1 v2)
|
||||
(unless (eq? v1 v2)
|
||||
(match v1
|
||||
[(cons car1 cdr1)
|
||||
(match v2
|
||||
[(cons car2 cdr2)
|
||||
(inner (list* 'car p) car1 car2)
|
||||
(inner (list* 'cdr p) cdr1 cdr2)]
|
||||
[_
|
||||
(yield p "Not a cons on right" v1 v2)])]
|
||||
[(? vector?)
|
||||
(match v2
|
||||
[(? vector?)
|
||||
(define v1l (vector-length v1))
|
||||
(define v2l (vector-length v2))
|
||||
(if (= v1l v2l)
|
||||
(for ([i (in-range v1l)])
|
||||
(inner (list* `(vector-ref ,i) p)
|
||||
(vector-ref v1 i)
|
||||
(vector-ref v2 i)))
|
||||
(yield p "Vector lengths not equal" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a vector on right" v1 v2)])]
|
||||
[(? struct?)
|
||||
(match v2
|
||||
[(? struct?)
|
||||
(define vv1 (struct->vector v1))
|
||||
(define vv2 (struct->vector v2))
|
||||
(inner (list* `(struct->vector ,(vector-ref vv1 0)) p)
|
||||
vv1 vv2)]
|
||||
[_
|
||||
(yield p "Not a struct on right" v1 v2)])]
|
||||
[(? hash?)
|
||||
(match v2
|
||||
[(? hash?)
|
||||
(let ([p (list* 'in-hash p)])
|
||||
(for ([(k1 hv1) (in-hash v1)])
|
||||
(define hv2
|
||||
(hash-ref v2 k1
|
||||
(lambda ()
|
||||
(yield p (format "~S not in hash on right" k1) v1 v2))))
|
||||
(inner (list* `(hash-ref ,k1) p)
|
||||
hv1 hv2)))]
|
||||
[_
|
||||
(yield p "Not a hash on right" v1 v2)])]
|
||||
[(? module-path-index?)
|
||||
(match v2
|
||||
[(? module-path-index?)
|
||||
(define-values (mp1 bmpi1) (module-path-index-split v1))
|
||||
(define-values (mp2 bmpi2) (module-path-index-split v2))
|
||||
(inner (list* 'module-path-index-split_0 p) mp1 mp2)
|
||||
(inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)]
|
||||
[_
|
||||
(yield p "Not a module path index on right" v1 v2)])]
|
||||
[(? string?)
|
||||
(match v2
|
||||
[(? string?)
|
||||
(unless (string=? v1 v2)
|
||||
(yield p "Unequal strings" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a string on right" v1 v2)])]
|
||||
[(? bytes?)
|
||||
(match v2
|
||||
[(? bytes?)
|
||||
(unless (bytes=? v1 v2)
|
||||
(yield p "Unequal bytes" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a bytes on right" v1 v2)])]
|
||||
[(? path?)
|
||||
(match v2
|
||||
[(? path?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal paths" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a path on right" v1 v2)])]
|
||||
[(? number?)
|
||||
(match v2
|
||||
[(? number?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal numbers" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a number on right" v1 v2)])]
|
||||
[(? regexp?)
|
||||
(match v2
|
||||
[(? regexp?)
|
||||
(unless (string=? (object-name v1) (object-name v2))
|
||||
(yield p "Unequal regexp" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a regexp on right" v1 v2)])]
|
||||
[(? byte-regexp?)
|
||||
(match v2
|
||||
[(? byte-regexp?)
|
||||
(unless (bytes=? (object-name v1) (object-name v2))
|
||||
(yield p "Unequal byte-regexp" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a byte-regexp on right" v1 v2)])]
|
||||
[(? box?)
|
||||
(match v2
|
||||
[(? box?)
|
||||
(inner (list* 'unbox) (unbox v1) (unbox v2))]
|
||||
[_
|
||||
(yield p "Not a box on right" v1 v2)])]
|
||||
[(? symbol?)
|
||||
(match v2
|
||||
[(? symbol?)
|
||||
(unless (symbol=? v1 v2)
|
||||
(cond
|
||||
[(and (symbol-interned? v1) (not (symbol-interned? v1)))
|
||||
(yield p "Not interned symbol on right" v1 v2)]
|
||||
[(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
|
||||
(yield p "Not unreadable symbol on right" v1 v2)]
|
||||
[(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
|
||||
(yield p "Not uninterned symbol on right" v1 v2)]
|
||||
[(and (symbol-uninterned? v1) (symbol-uninterned? v2))
|
||||
(unless (interned-symbol=? v1 v2)
|
||||
(yield p "Uninterned symbols don't align" v1 v2))]
|
||||
[else
|
||||
(yield p "Other symbol-related problem" v1 v2)]))]
|
||||
[_
|
||||
(yield p "Not a symbol on right" v1 v2)])]
|
||||
[(? empty?)
|
||||
(yield p "Not empty on right" v1 v2)]
|
||||
[_
|
||||
(yield p "Cannot inspect values deeper" v1 v2)])))
|
||||
(inner empty v1 v2))
|
||||
|
||||
(define (symbol-uninterned? s)
|
||||
(not (or (symbol-interned? s) (symbol-unreadable? s))))
|
||||
|
||||
(define (run-with-limit file k thnk)
|
||||
(define file-custodian (make-custodian))
|
||||
(define ch (make-channel))
|
||||
(custodian-limit-memory file-custodian k)
|
||||
(define worker-thread
|
||||
(parameterize ([current-custodian file-custodian])
|
||||
(thread
|
||||
(lambda ()
|
||||
(define r (thnk))
|
||||
(channel-put ch r)
|
||||
(channel-get ch)))))
|
||||
(begin0
|
||||
(sync
|
||||
(handle-evt ch
|
||||
(lambda (v)
|
||||
(when (exn? v) (raise v))
|
||||
v))
|
||||
(handle-evt worker-thread
|
||||
(lambda _
|
||||
(record! (failure 'memory #f "Over memory limit")))))
|
||||
(custodian-shutdown-all file-custodian)))
|
||||
|
||||
(define-syntax run/stages*
|
||||
(syntax-rules ()
|
||||
[(_ file)
|
||||
(record! (success 'everything))]
|
||||
[(_ file [step1 serious? e] . rst)
|
||||
(let/ec esc
|
||||
(let ([step1 (with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(record! (failure 'step1 serious?
|
||||
(exn-message x)))
|
||||
(if serious?
|
||||
(esc #f)
|
||||
#f))])
|
||||
e)])
|
||||
(record! (success 'step1))
|
||||
(run/stages* file . rst)))]))
|
||||
|
||||
(define-syntax-rule (define-stages (run! file)
|
||||
[stage serious? e] ...)
|
||||
(define (run! file)
|
||||
(run/stages* file [stage serious? e] ...)))
|
||||
|
||||
(define-stages (run! file)
|
||||
[read-orig
|
||||
#t
|
||||
(bytes-gulp file)]
|
||||
[parse-orig
|
||||
#t
|
||||
(zo-parse/bytes read-orig)]
|
||||
[marshal-parsed
|
||||
#t
|
||||
(zo-marshal parse-orig)]
|
||||
[parse-marshalled
|
||||
#t
|
||||
(zo-parse/bytes marshal-parsed)]
|
||||
[compare-parsed-to-parsed-marshalled
|
||||
#f
|
||||
(equal?/why-not parse-orig parse-marshalled)]
|
||||
[marshal-marshalled
|
||||
#t
|
||||
(zo-marshal parse-marshalled)]
|
||||
[compare-marshalled-to-marshalled-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error marshal-parsed marshal-marshalled)]
|
||||
#;[replace-with-marshalled
|
||||
#t
|
||||
(replace-file file marshal-marshalled)]
|
||||
[decompile-parsed
|
||||
#t
|
||||
(decompile parse-orig)]
|
||||
[c-parse-marshalled
|
||||
#t
|
||||
(read-compiled-bytes marshal-parsed)]
|
||||
[compare-orig-to-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error read-orig marshal-parsed)])
|
||||
|
||||
(define RESULTS empty)
|
||||
(define (record! v)
|
||||
(set! RESULTS (list* v RESULTS)))
|
||||
(define (run-test file)
|
||||
(run-with-limit
|
||||
file
|
||||
(* 1024 1024 128)
|
||||
(lambda ()
|
||||
(run! file)))
|
||||
(write (reverse RESULTS)))
|
||||
|
||||
(command-line #:program "zo-test-worker"
|
||||
#:args (file)
|
||||
(run-test file))
|
||||
|
|
@ -3,204 +3,15 @@
|
|||
exec racket -t "$0" -- -s -t 60 -v -R $*
|
||||
|#
|
||||
|
||||
#lang scheme
|
||||
(require compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
compiler/decompile
|
||||
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
|
||||
(lambda ()
|
||||
(zo-parse ib))
|
||||
(lambda ()
|
||||
(close-input-port ib))))
|
||||
|
||||
(define (bytes-not-equal?-error b1 b2)
|
||||
(unless (bytes=? b1 b2)
|
||||
(error 'bytes-not-equal?-error "Not equal")))
|
||||
|
||||
(define (replace-file file bytes)
|
||||
(with-output-to-file file
|
||||
(λ () (write-bytes bytes))
|
||||
#:exists 'truncate))
|
||||
#lang racket
|
||||
(require setup/dirs
|
||||
racket/runtime-path
|
||||
racket/future
|
||||
"zo-test-util.rkt")
|
||||
|
||||
(define ((make-recorder! ht) file phase)
|
||||
(hash-update! ht phase (curry list* file) empty))
|
||||
|
||||
(define (equal?/why-not v1 v2)
|
||||
(define v1->v2 (make-hasheq))
|
||||
(define (interned-symbol=? s1 s2)
|
||||
(symbol=? (hash-ref! v1->v2 s1 s2) s2))
|
||||
(define (yield p m v1 v2)
|
||||
(error 'equal?/why-not "~a in ~a: ~S ~S"
|
||||
m (reverse p) v1 v2))
|
||||
(define (inner p v1 v2)
|
||||
(unless (eq? v1 v2)
|
||||
(match v1
|
||||
[(cons car1 cdr1)
|
||||
(match v2
|
||||
[(cons car2 cdr2)
|
||||
(inner (list* 'car p) car1 car2)
|
||||
(inner (list* 'cdr p) cdr1 cdr2)]
|
||||
[_
|
||||
(yield p "Not a cons on right" v1 v2)])]
|
||||
[(? vector?)
|
||||
(match v2
|
||||
[(? vector?)
|
||||
(define v1l (vector-length v1))
|
||||
(define v2l (vector-length v2))
|
||||
(if (= v1l v2l)
|
||||
(for ([i (in-range v1l)])
|
||||
(inner (list* `(vector-ref ,i) p)
|
||||
(vector-ref v1 i)
|
||||
(vector-ref v2 i)))
|
||||
(yield p "Vector lengths not equal" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a vector on right" v1 v2)])]
|
||||
[(? struct?)
|
||||
(match v2
|
||||
[(? struct?)
|
||||
(define vv1 (struct->vector v1))
|
||||
(define vv2 (struct->vector v2))
|
||||
(inner (list* `(struct->vector ,(vector-ref vv1 0)) p)
|
||||
vv1 vv2)]
|
||||
[_
|
||||
(yield p "Not a struct on right" v1 v2)])]
|
||||
[(? hash?)
|
||||
(match v2
|
||||
[(? hash?)
|
||||
(let ([p (list* 'in-hash p)])
|
||||
(for ([(k1 hv1) (in-hash v1)])
|
||||
(define hv2
|
||||
(hash-ref v2 k1
|
||||
(lambda ()
|
||||
(yield p (format "~S not in hash on right" k1) v1 v2))))
|
||||
(inner (list* `(hash-ref ,k1) p)
|
||||
hv1 hv2)))]
|
||||
[_
|
||||
(yield p "Not a hash on right" v1 v2)])]
|
||||
[(? module-path-index?)
|
||||
(match v2
|
||||
[(? module-path-index?)
|
||||
(define-values (mp1 bmpi1) (module-path-index-split v1))
|
||||
(define-values (mp2 bmpi2) (module-path-index-split v2))
|
||||
(inner (list* 'module-path-index-split_0 p) mp1 mp2)
|
||||
(inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)]
|
||||
[_
|
||||
(yield p "Not a module path index on right" v1 v2)])]
|
||||
[(? string?)
|
||||
(match v2
|
||||
[(? string?)
|
||||
(unless (string=? v1 v2)
|
||||
(yield p "Unequal strings" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a string on right" v1 v2)])]
|
||||
[(? bytes?)
|
||||
(match v2
|
||||
[(? bytes?)
|
||||
(unless (bytes=? v1 v2)
|
||||
(yield p "Unequal bytes" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a bytes on right" v1 v2)])]
|
||||
[(? path?)
|
||||
(match v2
|
||||
[(? path?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal paths" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a path on right" v1 v2)])]
|
||||
[(? number?)
|
||||
(match v2
|
||||
[(? number?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal numbers" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a number on right" v1 v2)])]
|
||||
[(? regexp?)
|
||||
(match v2
|
||||
[(? regexp?)
|
||||
(unless (string=? (object-name v1) (object-name v2))
|
||||
(yield p "Unequal regexp" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a regexp on right" v1 v2)])]
|
||||
[(? byte-regexp?)
|
||||
(match v2
|
||||
[(? byte-regexp?)
|
||||
(unless (bytes=? (object-name v1) (object-name v2))
|
||||
(yield p "Unequal byte-regexp" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a byte-regexp on right" v1 v2)])]
|
||||
[(? box?)
|
||||
(match v2
|
||||
[(? box?)
|
||||
(inner (list* 'unbox) (unbox v1) (unbox v2))]
|
||||
[_
|
||||
(yield p "Not a box on right" v1 v2)])]
|
||||
[(? symbol?)
|
||||
(match v2
|
||||
[(? symbol?)
|
||||
(unless (symbol=? v1 v2)
|
||||
(cond
|
||||
[(and (symbol-interned? v1) (not (symbol-interned? v1)))
|
||||
(yield p "Not interned symbol on right" v1 v2)]
|
||||
[(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
|
||||
(yield p "Not unreadable symbol on right" v1 v2)]
|
||||
[(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
|
||||
(yield p "Not uninterned symbol on right" v1 v2)]
|
||||
[(and (symbol-uninterned? v1) (symbol-uninterned? v2))
|
||||
(unless (interned-symbol=? v1 v2)
|
||||
(yield p "Uninterned symbols don't align" v1 v2))]
|
||||
[else
|
||||
(yield p "Other symbol-related problem" v1 v2)]))]
|
||||
[_
|
||||
(yield p "Not a symbol on right" v1 v2)])]
|
||||
[(? empty?)
|
||||
(yield p "Not empty on right" v1 v2)]
|
||||
[_
|
||||
(yield p "Cannot inspect values deeper" v1 v2)])))
|
||||
(inner empty v1 v2))
|
||||
|
||||
(define (symbol-uninterned? s)
|
||||
(not (or (symbol-interned? s) (symbol-unreadable? s))))
|
||||
|
||||
;; Parameters
|
||||
(define stop-on-first-error (make-parameter #f))
|
||||
(define verbose-mode (make-parameter #f))
|
||||
(define care-about-nonserious? (make-parameter #t))
|
||||
|
|
@ -208,139 +19,23 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
|
|||
(define time-limit (make-parameter +inf.0))
|
||||
(define randomize (make-parameter #f))
|
||||
|
||||
;; Work
|
||||
(define errors (make-hash))
|
||||
(define (record-common-error! exn-msg)
|
||||
(hash-update! errors (common-message exn-msg) add1 0))
|
||||
|
||||
(define (common-message exn)
|
||||
(define given-messages (regexp-match #rx".*given" (exn-message exn)))
|
||||
(define (common-message exn-msg)
|
||||
(define given-messages (regexp-match #rx".*given" exn-msg))
|
||||
(if (and given-messages (not (empty? given-messages)))
|
||||
(first given-messages)
|
||||
(exn-message exn)))
|
||||
|
||||
(define (exn-printer file phase serious? exn)
|
||||
(hash-update! errors (common-message exn) add1 0)
|
||||
(unless (and (not (care-about-nonserious?)) (not serious?))
|
||||
(when (or (verbose-mode) (stop-on-first-error))
|
||||
(fprintf (current-error-port) "~a -- ~a: ~a~n" file phase (exn-message exn)))
|
||||
(when (stop-on-first-error)
|
||||
exn)))
|
||||
|
||||
(define (run-with-time-limit t thnk)
|
||||
(define th (thread thnk))
|
||||
(sync th
|
||||
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
||||
(* 1000 t)))
|
||||
(lambda _
|
||||
(kill-thread th)))))
|
||||
|
||||
(define (run-with-limit file k thnk)
|
||||
(define file-custodian (make-custodian))
|
||||
(define ch (make-channel))
|
||||
(custodian-limit-memory file-custodian k)
|
||||
(local [(define worker-thread
|
||||
(parameterize ([current-custodian file-custodian])
|
||||
(thread
|
||||
(lambda ()
|
||||
(define r (thnk))
|
||||
(channel-put ch r)
|
||||
(channel-get ch)))))]
|
||||
(begin0
|
||||
(sync
|
||||
(handle-evt ch
|
||||
(lambda (v)
|
||||
(when (exn? v) (raise v))
|
||||
v))
|
||||
(handle-evt worker-thread
|
||||
(lambda _
|
||||
(failure! file 'memory))))
|
||||
(custodian-shutdown-all file-custodian))))
|
||||
exn-msg))
|
||||
|
||||
(define success-ht (make-hasheq))
|
||||
(define success! (make-recorder! success-ht))
|
||||
(define failure-ht (make-hasheq))
|
||||
(define failure! (make-recorder! failure-ht))
|
||||
|
||||
(define-syntax run/stages*
|
||||
(syntax-rules ()
|
||||
[(_ file) (success! file 'everything)]
|
||||
[(_ file [step1 serious? e] . rst)
|
||||
(let/ec esc
|
||||
(let ([step1 (with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(failure! file 'step1)
|
||||
(esc (exn-printer file 'step1 serious? x)))])
|
||||
e)])
|
||||
(success! file 'step1)
|
||||
(run/stages* file . rst)))]))
|
||||
|
||||
(define-syntax-rule (define-stages (stages run!)
|
||||
file
|
||||
[stage serious? e] ...)
|
||||
(define-values (stages run!)
|
||||
(values '(stage ...)
|
||||
(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
|
||||
#t
|
||||
(bytes-gulp file)]
|
||||
[parse-orig
|
||||
#t
|
||||
(zo-parse/bytes read-orig)]
|
||||
[marshal-parsed
|
||||
#t
|
||||
(zo-marshal parse-orig)]
|
||||
#;[ignored
|
||||
#f
|
||||
(printf "orig: ~a, marshalled: ~a~n"
|
||||
(bytes-length read-orig)
|
||||
(bytes-length marshal-parsed))]
|
||||
[parse-marshalled
|
||||
#t
|
||||
(zo-parse/bytes marshal-parsed)]
|
||||
[compare-parsed-to-parsed-marshalled
|
||||
#f
|
||||
(equal?/why-not parse-orig parse-marshalled)]
|
||||
[marshal-marshalled
|
||||
#t
|
||||
(zo-marshal parse-marshalled)]
|
||||
[compare-marshalled-to-marshalled-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error marshal-parsed marshal-marshalled)]
|
||||
#;[show-orig-and-marshal-parsed
|
||||
#f
|
||||
(print-bytes read-orig marshal-parsed)]
|
||||
#;[replace-with-marshalled
|
||||
#t
|
||||
(replace-file file marshal-marshalled)]
|
||||
[decompile-parsed
|
||||
#t
|
||||
(decompile parse-orig)]
|
||||
[c-parse-marshalled
|
||||
#t
|
||||
(read-compiled-bytes marshal-parsed)]
|
||||
[compare-orig-to-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error read-orig marshal-parsed)])
|
||||
|
||||
(define (run-test file)
|
||||
(when (debugging?)
|
||||
(printf "~a\n" file))
|
||||
(run-with-limit
|
||||
file
|
||||
(* 1024 1024 128)
|
||||
(lambda ()
|
||||
(run! file))))
|
||||
|
||||
(define (randomize-list l)
|
||||
(define ll (length l))
|
||||
(define seen? (make-hasheq))
|
||||
|
|
@ -366,59 +61,162 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
|
|||
[(regexp-match #rx"\\.zo$" p-str)
|
||||
(! p-str)]))
|
||||
|
||||
(define (zo-test paths)
|
||||
(run-with-time-limit
|
||||
(time-limit)
|
||||
(lambda ()
|
||||
(for-each (curry for-zos run-test) paths)))
|
||||
|
||||
(unless (invariant-output)
|
||||
(for ([kind-name (list* 'memory stages)])
|
||||
(define fails (length (hash-ref failure-ht kind-name empty)))
|
||||
(define succs (length (hash-ref success-ht kind-name empty)))
|
||||
(define all (+ fails succs))
|
||||
(unless (zero? all)
|
||||
(printf "~S~n"
|
||||
`(,kind-name
|
||||
(#f ,fails)
|
||||
(#t ,succs)
|
||||
,all))))
|
||||
(printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty)))
|
||||
|
||||
(printf "Common Errors:~n")
|
||||
|
||||
(for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10))
|
||||
(hash-map errors (λ (k v) (cons v k))))
|
||||
> #:key car))])
|
||||
(printf "~a:~n~a~n~n" (car p) (cdr p)))))
|
||||
(define-runtime-path zo-test-worker-path "zo-test-worker.rkt")
|
||||
(define racket-path (path->string (find-executable-path "racket")))
|
||||
|
||||
; Run
|
||||
#;(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)]
|
||||
[("-S")
|
||||
"Don't take some errors seriously"
|
||||
(care-about-nonserious? #f)]
|
||||
[("-v" "--verbose")
|
||||
"Display verbose error messages"
|
||||
(verbose-mode #t)]
|
||||
[("-I")
|
||||
"Invariant output"
|
||||
(invariant-output #t)]
|
||||
[("-R")
|
||||
"Randomize"
|
||||
(randomize #t)]
|
||||
[("-t")
|
||||
number
|
||||
"Limit the run to a given amount of time"
|
||||
(time-limit (string->number number))]
|
||||
#:args p
|
||||
(zo-test (if (empty? p)
|
||||
(list (find-collects-dir))
|
||||
p)))
|
||||
(define p
|
||||
(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)]
|
||||
[("-S")
|
||||
"Don't take some errors seriously"
|
||||
(care-about-nonserious? #f)]
|
||||
[("-v" "--verbose")
|
||||
"Display verbose error messages"
|
||||
(verbose-mode #t)]
|
||||
[("-I")
|
||||
"Invariant output"
|
||||
(invariant-output #t)]
|
||||
[("-R")
|
||||
"Randomize"
|
||||
(randomize #t)]
|
||||
[("-t")
|
||||
number
|
||||
"Limit the run to a given amount of time"
|
||||
(time-limit (string->number number))]
|
||||
#:args p
|
||||
(if (empty? p)
|
||||
(list (find-collects-dir))
|
||||
p)))
|
||||
|
||||
(define to-worker-ch (make-channel))
|
||||
(define stop-ch (make-channel))
|
||||
(define from-worker-ch (make-channel))
|
||||
|
||||
(define worker-threads
|
||||
(for/list ([i (in-range (processor-count))])
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(handle-evt to-worker-ch
|
||||
(λ (p)
|
||||
(when (debugging?)
|
||||
(printf "~a\n" p))
|
||||
(define-values
|
||||
(sp stdout stdin _stderr)
|
||||
(subprocess #f #f #f racket-path (path->string zo-test-worker-path) p))
|
||||
(define r
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(read stdout))
|
||||
(λ ()
|
||||
(close-input-port stdout)
|
||||
(close-output-port stdin)
|
||||
(subprocess-kill sp #t))))
|
||||
(channel-put from-worker-ch (cons p r))
|
||||
(loop)))
|
||||
(handle-evt stop-ch
|
||||
(λ (die)
|
||||
(void)))))))))
|
||||
|
||||
(define (process-result p r)
|
||||
(match r
|
||||
[(success phase)
|
||||
(success! p phase)]
|
||||
[(failure phase serious? exn-msg)
|
||||
(record-common-error! exn-msg)
|
||||
(failure! p phase)
|
||||
|
||||
(unless (and (not (care-about-nonserious?)) (not serious?))
|
||||
(when (or (verbose-mode) (stop-on-first-error))
|
||||
(fprintf (current-error-port) "~a -- ~a: ~a\n" p phase exn-msg))
|
||||
(when (stop-on-first-error)
|
||||
(stop!)))]))
|
||||
|
||||
(define timing-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(sync
|
||||
(alarm-evt (+ (current-inexact-milliseconds)
|
||||
(* 1000 (time-limit)))))
|
||||
(stop!))))
|
||||
|
||||
(define server-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ([ts worker-threads])
|
||||
(if (empty? ts)
|
||||
(stop!)
|
||||
(apply
|
||||
sync
|
||||
(handle-evt from-worker-ch
|
||||
(match-lambda
|
||||
[(cons p rs)
|
||||
(for-each (curry process-result p) rs)
|
||||
(loop ts)]))
|
||||
(for/list ([t (in-list ts)])
|
||||
(handle-evt t (λ _ (loop (remq t ts)))))))))))
|
||||
|
||||
(define (spawn-worker p)
|
||||
(channel-put to-worker-ch p))
|
||||
|
||||
(define (zo-test paths)
|
||||
(for-each (curry for-zos spawn-worker) paths)
|
||||
|
||||
(for ([i (in-range (processor-count))])
|
||||
(channel-put stop-ch #t)))
|
||||
|
||||
(define root-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(zo-test p))))
|
||||
|
||||
(define final-sema (make-semaphore 0))
|
||||
(define (stop!)
|
||||
(semaphore-post final-sema))
|
||||
|
||||
(define (hash-keys ht)
|
||||
(hash-map ht (λ (k v) k)))
|
||||
|
||||
(define final-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(semaphore-wait final-sema)
|
||||
(for-each kill-thread
|
||||
(list* root-thread server-thread worker-threads))
|
||||
(unless (invariant-output)
|
||||
(newline)
|
||||
(for ([kind-name
|
||||
(remove-duplicates
|
||||
(append
|
||||
(hash-keys failure-ht)
|
||||
(hash-keys success-ht)))])
|
||||
(define fails (length (hash-ref failure-ht kind-name empty)))
|
||||
(define succs (length (hash-ref success-ht kind-name empty)))
|
||||
(define all (+ fails succs))
|
||||
(unless (zero? all)
|
||||
(printf "~S~n"
|
||||
`(,kind-name
|
||||
(#f ,fails)
|
||||
(#t ,succs)
|
||||
,all))))
|
||||
(newline)
|
||||
(printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty)))
|
||||
|
||||
(let ([common-errors
|
||||
(sort (filter (λ (p) ((car p) . > . 10))
|
||||
(hash-map errors (λ (k v) (cons v k))))
|
||||
> #:key car)])
|
||||
(unless (empty? common-errors)
|
||||
(printf "Common Errors:~n")
|
||||
(for ([p (in-list common-errors)])
|
||||
(printf "~a:~n~a~n~n" (car p) (cdr p)))))))))
|
||||
|
||||
(thread-wait final-thread)
|
||||
Loading…
Reference in New Issue
Block a user