suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improved performance of `check' by factoring language and pattern

Browse Source 
pre-processing out of its loop.

svn: r11819
This commit is contained in:
Casey Klein 2008-09-19 13:22:00 +00:00
parent 967dca08e3
commit 12bba4996f
2 changed files with 97 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
collects/redex/private/rg-test.ss
View File

@ -8,8 +8,6 @@
(reset-count)
;; to-table : hash-table -> assoc
;; extracts the hash-table's mapping in a deterministic way
(define (to-table ht)
@ -136,7 +134,7 @@
;; Generate (λ (x) x)
(test
(generate
(generate/decisions
lc e 1 0
(decisions #:var (list (λ _ 'x) (λ _'x))
#:nt (patterns third first first first)))
@ -144,7 +142,7 @@
;; Generate pattern that's not a non-terminal
(test
(generate
(generate/decisions
lc (x x x_1 x_1) 1 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'(x x y y))
@ -152,7 +150,7 @@
;; Minimum rhs is chosen with zero size
(test
(let/ec k
(generate
(generate/decisions
lc e 0 0
(decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods)))))))
'(x))
@ -161,7 +159,7 @@
(let ([size 5])
(test
(let/ec k
(generate
(generate/decisions
lc e size 0
(decisions #:nt (list (λ (prods . _) (cadr prods)) (λ (p b s) (k s))))))
(sub1 size))))
@ -176,7 +174,7 @@
(let* ([x null]
[prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))])
(test (begin
(generate lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!)))
(generate/decisions lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!)))
x)
'(x x))))
@ -187,7 +185,7 @@
(x (variable-except λ)))
(test
(exn:fail-message
(generate
(generate/decisions
postfix e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))
#:nt (patterns third second first first))))
@ -198,7 +196,7 @@
(define-language var
(e (variable-except x y)))
(test
(generate
(generate/decisions
var e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
'z))
@ -215,25 +213,25 @@
(n number)
(z 4))
(test
(generate
(generate/decisions
lang a 2 0
(decisions #:num (build-list 3 (λ (n) (λ (_) n)))
#:seq (list (λ () 2) (λ () 3) (λ () 1))))
`(0 1 2 "foo" "foo" "foo" "bar" #t))
(test (generate lang b 5 0 (decisions #:seq (list (λ () 0))))
(test (generate/decisions lang b 5 0 (decisions #:seq (list (λ () 0))))
null)
(test (generate lang c 5 0 (decisions #:seq (list (λ () 0))))
(test (generate/decisions lang c 5 0 (decisions #:seq (list (λ () 0))))
null)
(test (generate lang d 5 0 (decisions #:seq (list (λ () 2))))
(test (generate/decisions lang d 5 0 (decisions #:seq (list (λ () 2))))
'(4 4 4 4 (4 4) (4 4)))
(test (exn:fail-message (generate lang e 5 0))
(test (exn:fail-message (generate lang e 5))
#rx"generate: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\)")
(test (generate lang f 5 0 (decisions #:seq (list (λ () 0)))) null)
(test (generate lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(test (generate/decisions lang f 5 0 (decisions #:seq (list (λ () 0)))) null)
(test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 4)
(λ () 2) (λ () 3) (λ () 4) (λ () 1) (λ () 3))))
'((0 0 0) (0 0 0 0) (1 1 1)))
(test (generate lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 5))))
'((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1))))
@ -247,7 +245,7 @@
;; x and y bound in body
(test
(let/ec k
(generate
(generate/decisions
lc e 10 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
#:nt (patterns first first first third first)
@ -257,7 +255,7 @@
(let ()
(define-language lang (e (variable-prefix pf)))
(test
(generate
(generate/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x))))
'pfx))
@ -271,7 +269,7 @@
(define-language lang
(e number (e_1 e_2 e e_1 e_2)))
(test
(generate
(generate/decisions
lang e 5 0
(decisions #:nt (patterns second first first first)
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
@ -283,7 +281,7 @@
(x variable))
(test
(let/ec k
(generate
(generate/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x)))
@ -294,17 +292,17 @@
(b (c_!_1 c_!_1 c_!_1))
(c 1 2))
(test
(generate
(generate/decisions
lang a 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
(test
(generate
(generate/decisions
lang (number_!_1 number_!_2 number_!_1) 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
(test
(exn:fail-message (generate lang b 5000 0))
(exn:fail-message (generate lang b 5000))
#rx"unable"))
(let ()
@ -313,7 +311,7 @@
(f foo bar))
(test
(let/ec k
(generate
(generate/decisions
lang e 5 0
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
(cons '(#\a #\b #\f #\o #\r)
@ -327,28 +325,28 @@
(d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x)
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
(x variable))
(test (generate lang b 5 0) 43)
(test (generate lang (side-condition a (odd? (term a))) 5 0) 43)
(test (exn:fail-message (generate lang c 5 0))
(test (generate lang b 5) 43)
(test (generate lang (side-condition a (odd? (term a))) 5) 43)
(test (exn:fail-message (generate lang c 5))
#rx"unable to generate")
(test ; binding works for with side-conditions failure/retry
(let/ec k
(generate
(generate/decisions
lang d 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
'(y))
(test ; mismatch patterns work with side-condition failure/retry
(generate
(generate/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
'(y x y))
(test ; generate compiles side-conditions in pattern
(generate lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(generate/decisions lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'y)
(test ; bindings within ellipses collected properly
(let/ec k
(generate lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(generate/decisions lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(decisions #:seq (list (λ () 2) (λ () 3) (λ () 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
'((0 1 2) (3 4 5 6))))
@ -360,9 +358,9 @@
(c (side-condition (name x d) (zero? (term x))))
(d 2 1 0)
(e ((side-condition (name d_1 d) (zero? (term d_1))) d_1)))
(test (generate lang a 5 0) 4)
(test (generate lang c 5 0) 0)
(test (generate lang e 5 0) '(0 0)))
(test (generate lang a 5) 4)
(test (generate lang c 5) 0)
(test (generate lang e 5) '(0 0)))
(let ()
(define-language lang
@ -380,28 +378,28 @@
(y variable))
(test
(generate
(generate/decisions
lang (in-hole A number ) 5 0
(decisions
#:nt (patterns second second first first third first second first first)
#:num (build-list 5 (λ (x) (λ (_) x)))))
'(+ (+ 1 2) (+ 0 (+ 3 4))))
(test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5 0) '(1 5))
(test (generate lang (hole 4) 5 0) (term (hole 4)))
(test (generate lang (variable_1 (in-hole C variable_1)) 5 0
(test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5))
(test (generate lang (hole 4) 5) (term (hole 4)))
(test (generate/decisions lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
'(x x))
(test (generate lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(test (generate/decisions lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
'(x y))
(test (let/ec k (generate lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
(test (let/ec k (generate/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x))
(test (generate lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
(test (generate/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
'((2 (1 1)) 1))
(test (generate lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
(test (generate/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
'(1 0))
(test (generate lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
(test (generate/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
'((2 ((3 (2 1)) 3)) 1)))
(let ()
@ -409,7 +407,7 @@
(e (e e) (+ e e) x v)
(v (λ (x) e) number)
(x variable-not-otherwise-mentioned))
(test (generate lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
(test (generate/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
'x))
(let ()
@ -422,8 +420,8 @@
(list four 'f))
(test (call-with-values (λ () (pick-any four (make-random (list 1)))) list)
(list sexp 'sexp))
(test (generate four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
(test (generate four any 5 0
(test (generate/decisions four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
(test (generate/decisions four any 5 0
(decisions #:any (list (λ _ (values sexp 'sexp)))
#:nt (patterns fifth second second second)
#:seq (list (λ _ 3))
@ -434,7 +432,7 @@
(let ()
(define-language lang
(e (hide-hole (in-hole ((hide-hole hole) hole) 1))))
(test (generate lang e 5 0) (term (hole 1))))
(test (generate lang e 5) (term (hole 1))))
(define (output-error-port thunk)
(let ([port (open-output-string)])
@ -448,7 +446,7 @@
(e x (e e) v)
(v (λ (x) e))
(x variable-not-otherwise-mentioned))
(test (generate lang (cross e) 3 0
(test (generate/decisions lang (cross e) 3 0
(decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))

94
collects/redex/private/rg.ss
View File

@ -114,7 +114,7 @@ To do a better job of not generating programs with free variables,
(error 'generate "unable to generate pattern ~s in ~s attempts"
(unparse-pattern pat) generation-retries))
(define (generate* lang pat size attempt [decisions@ random-decisions@])
(define (generate* lang pat size [decisions@ random-decisions@])
(define-values/invoke-unit decisions@
(import) (export decisions^))
@ -122,7 +122,7 @@ To do a better job of not generating programs with free variables,
(define lang-chars (unique-chars lang-lits))
(define base-table (find-base-cases lang))
(define (generate-nt name fvt-id bound-vars size in-hole state)
(define (generate-nt name fvt-id bound-vars size attempt in-hole state)
(let*-values
([(nt) (findf (λ (nt) (eq? name (nt-name nt)))
(append (compiled-lang-lang lang)
@ -136,7 +136,7 @@ To do a better job of not generating programs with free variables,
[(term _)
(generate/pred
(rhs-pattern rhs)
(λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state))
(λ (pat) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) pat in-hole) nt-state))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (extend-found-vars fvt-id term state))))
@ -211,8 +211,8 @@ To do a better job of not generating programs with free variables,
(define (fvt-entry binds)
(make-found-vars (binds-binds binds) (binds-source binds) '() #f))
(define (((generate-pat bound-vars size) pat in-hole) state)
(define recur (generate-pat bound-vars size))
(define (((generate-pat bound-vars size attempt) pat in-hole) state)
(define recur (generate-pat bound-vars size attempt))
(define (recur/pat pat) ((recur pat in-hole) state))
(match pat
@ -240,22 +240,22 @@ To do a better job of not generating programs with free variables,
[`(hide-hole ,pattern) ((recur pattern the-hole) state)]
[`any
(let*-values ([(lang nt) ((next-any-decision) lang)]
[(term _) (generate* lang nt size attempt decisions@)])
[(term _) ((generate* lang nt size decisions@) attempt)])
(values term state))]
[(? (is-nt? lang))
(generate-nt pat pat bound-vars size in-hole state)]
(generate-nt pat pat bound-vars size attempt in-hole state)]
[(struct binder ((and name (or (? (is-nt? lang) nt) (app (symbol-match named-nt-rx) (? (is-nt? lang) nt))))))
(generate/prior pat state (λ () (generate-nt nt name bound-vars size in-hole state)))]
(generate/prior pat state (λ () (generate-nt nt name bound-vars size attempt in-hole state)))]
[(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat state (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? lang) nt)))))
(let-values ([(term state) (generate-nt nt pat bound-vars size in-hole state)])
(let-values ([(term state) (generate-nt nt pat bound-vars size attempt in-hole state)])
(values term (set-env state pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(let-values ([(term state) (recur/pat b)])
(values term (set-env state pat term)))]
[`(cross ,(? symbol? cross-nt))
(generate-nt cross-nt #f bound-vars size in-hole state)]
(generate-nt cross-nt #f bound-vars size attempt in-hole state)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
@ -306,14 +306,15 @@ To do a better job of not generating programs with free variables,
(state-fvt state))
(state-env state)))
(let-values ([(term state)
(generate/pred
pat
(λ (pat)
(((generate-pat null size) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state)))))
(λ (attempt)
(let-values ([(term state)
(generate/pred
pat
(λ (pat)
(((generate-pat null size attempt) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state))))))
;; find-base-cases : compiled-language -> hash-table
(define (find-base-cases lang)
@ -559,41 +560,46 @@ To do a better job of not generating programs with free variables,
(with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses])
(syntax/loc stx
(let loop ([remaining attempts])
(if (zero? remaining)
#t
(let ([attempt (add1 (- attempts remaining))])
(let-values ([(term bindings) (generate/bindings lang pat size attempt)])
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
(if (with-handlers
([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))])
property)
(loop (sub1 remaining))
(fprintf (current-error-port)
"failed after ~s attempts: ~s"
attempt term))))))))))]))
(let ([generator (term-generator lang pat size random-decisions@)])
(let loop ([remaining attempts])
(if (zero? remaining)
#t
(let ([attempt (add1 (- attempts remaining))])
(let-values ([(term bindings) (generator attempt)])
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
(if (with-handlers
([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))])
property)
(loop (sub1 remaining))
(fprintf (current-error-port)
"failed after ~s attempts: ~s"
attempt term)))))))))))]))
(define-syntax (generate stx)
(syntax-case stx ()
[(_ . args)
(quasisyntax
(let-values ([(term bindings) (generate/bindings #,@#'args)])
term))]))
(define-syntax (generate/bindings stx)
(syntax-case stx ()
(define-syntax generate
(syntax-rules ()
[(_ lang pat size attempt)
(syntax (generate/bindings lang pat size attempt random-decisions@))]
(let-values ([(term _) ((term-generator lang pat size random-decisions@) attempt)])
term)]
[(_ lang pat size) (generate lang pat size 0)]))
(define-syntax generate/decisions
(syntax-rules ()
[(_ lang pat size attempt decisions@)
(let-values ([(term _) ((term-generator lang pat size decisions@) attempt)])
term)]))
(define-syntax (term-generator stx)
(syntax-case stx ()
[(_ lang pat size decisions@)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts #'lang 'generate)
'generate #t #'pat)])
(syntax
(syntax/loc stx
(generate*
(parse-language lang)
(reassign-classes (parse-pattern `pattern lang 'top-level))
size attempt decisions@)))]))
size decisions@)))]))
(define-signature decisions^
(next-variable-decision
@ -617,7 +623,7 @@ To do a better job of not generating programs with free variables,
pick-nt unique-chars pick-any sexp generate parse-pattern
class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
(struct-out binder))
(struct-out binder) generate/decisions)
(provide/contract
[find-base-cases (-> compiled-lang? hash?)])