Another generator optimization
svn: r17902
This commit is contained in:
Casey Klein
parent
aa67a279ab
commit
d9e5d3aa98
|
|
@ -158,22 +158,16 @@
|
||||||
([(productions)
|
([(productions)
|
||||||
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)]
|
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)]
|
||||||
[(term _)
|
[(term _)
|
||||||
(generate/pred
|
(let ([gen (pick-from-list
|
||||||
name
|
(if (zero? size)
|
||||||
(λ (size attempt)
|
(min-prods name productions
|
||||||
(let ([gen (pick-from-list
|
((if cross? base-cases-cross base-cases-non-cross)
|
||||||
(if (zero? size)
|
(rg-lang-base-cases lang)))
|
||||||
(min-prods name productions
|
((next-non-terminal-decision) productions)))])
|
||||||
((if cross? base-cases-cross base-cases-non-cross)
|
(gen retries (max 0 (sub1 size)) attempt empty-env in-hole))])
|
||||||
(rg-lang-base-cases lang)))
|
|
||||||
((next-non-terminal-decision) productions)))])
|
|
||||||
(gen retries (max 0 (sub1 size)) attempt empty-env in-hole)))
|
|
||||||
(λ (_ env) (mismatches-satisfied? env))
|
|
||||||
size attempt retries)])
|
|
||||||
term))
|
term))
|
||||||
|
|
||||||
(define (generate/pred name gen pred init-sz init-att retries)
|
(define (generate/pred name gen pred init-sz init-att retries)
|
||||||
#;(gen init-sz init-att)
|
|
||||||
(let ([pre-threshold-incr
|
(let ([pre-threshold-incr
|
||||||
(ceiling
|
(ceiling
|
||||||
(/ (- retry-threshold init-att)
|
(/ (- retry-threshold init-att)
|
||||||
|
|
@ -258,106 +252,117 @@
|
||||||
(letrec-values
|
(letrec-values
|
||||||
([(compile)
|
([(compile)
|
||||||
(λ (pat any?)
|
(λ (pat any?)
|
||||||
(let ([nt? (is-nt? (if any? sexpp langp))])
|
(let* ([nt? (is-nt? (if any? sexpp langp))]
|
||||||
; retries size attempt env in-hole -> (values term env)
|
[mismatches? #f]
|
||||||
(match pat
|
[generator ; retries size attempt env in-hole -> (values term env)
|
||||||
[`number (λ (r s a e h) (values ((next-number-decision) a) e))]
|
(let recur ([pat pat])
|
||||||
[`natural (λ (r s a e h) (values ((next-natural-decision) a) e))]
|
(match pat
|
||||||
[`integer (λ (r s a e h) (values ((next-integer-decision) a) e))]
|
[`number (λ (r s a e h) (values ((next-number-decision) a) e))]
|
||||||
[`real (λ (r s a e h) (values ((next-real-decision) a) e))]
|
[`natural (λ (r s a e h) (values ((next-natural-decision) a) e))]
|
||||||
[`(variable-except ,vars ...)
|
[`integer (λ (r s a e h) (values ((next-integer-decision) a) e))]
|
||||||
(let ([g (compile 'variable any?)])
|
[`real (λ (r s a e h) (values ((next-real-decision) a) e))]
|
||||||
(λ (r s a e h)
|
[`(variable-except ,vars ...)
|
||||||
(generate/pred pat
|
(let ([g (recur 'variable)])
|
||||||
(λ (s a) (g r s a e h))
|
(λ (r s a e h)
|
||||||
(λ (var _) (not (memq var vars)))
|
(generate/pred pat
|
||||||
s a r)))]
|
(λ (s a) (g r s a e h))
|
||||||
[`variable
|
(λ (var _) (not (memq var vars)))
|
||||||
(λ (r s a e h)
|
s a r)))]
|
||||||
(values ((next-variable-decision) lits a) e))]
|
[`variable
|
||||||
[`variable-not-otherwise-mentioned
|
(λ (r s a e h)
|
||||||
(let ([g (compile 'variable any?)])
|
(values ((next-variable-decision) lits a) e))]
|
||||||
(λ (r s a e h)
|
[`variable-not-otherwise-mentioned
|
||||||
(generate/pred pat
|
(let ([g (recur 'variable)])
|
||||||
(λ (s a) (g r s a e h))
|
(λ (r s a e h)
|
||||||
(λ (var _) (not (memq var lit-syms)))
|
(generate/pred pat
|
||||||
s a r)))]
|
(λ (s a) (g r s a e h))
|
||||||
[`(variable-prefix ,prefix)
|
(λ (var _) (not (memq var lit-syms)))
|
||||||
(define (symbol-append prefix suffix)
|
s a r)))]
|
||||||
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
[`(variable-prefix ,prefix)
|
||||||
(let ([g (compile 'variable any?)])
|
(define (symbol-append prefix suffix)
|
||||||
(λ (r s a e h)
|
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
||||||
(let-values ([(term _) (g r s a e h)])
|
(let ([g (recur 'variable)])
|
||||||
(values (symbol-append prefix term) e))))]
|
(λ (r s a e h)
|
||||||
[`string
|
(let-values ([(term _) (g r s a e h)])
|
||||||
(λ (r s a e h)
|
(values (symbol-append prefix term) e))))]
|
||||||
(values ((next-string-decision) lits a) e))]
|
[`string
|
||||||
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
(λ (r s a e h)
|
||||||
(let ([g (compile pat any?)])
|
(values ((next-string-decision) lits a) e))]
|
||||||
(λ (r s a e h)
|
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
||||||
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
(let ([g (recur pat)])
|
||||||
(λ (s a) (g r s a e h))
|
(λ (r s a e h)
|
||||||
(λ (_ env) (condition (bindings env)))
|
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
||||||
s a r)))]
|
(λ (s a) (g r s a e h))
|
||||||
[`(name ,(? symbol? id) ,p)
|
(λ (_ env) (condition (bindings env)))
|
||||||
(let ([g (compile p any?)])
|
s a r)))]
|
||||||
(λ (r s a e h)
|
[`(name ,(? symbol? id) ,p)
|
||||||
(let-values ([(term env) (g r s a e h)])
|
(let ([g (recur p)])
|
||||||
(values term (hash-set env (make-binder id) term)))))]
|
(λ (r s a e h)
|
||||||
[`hole (λ (r s a e h) (values h e))]
|
(let-values ([(term env) (g r s a e h)])
|
||||||
[`(in-hole ,context ,contractum)
|
(values term (hash-set env (make-binder id) term)))))]
|
||||||
(let ([ctx (compile context any?)]
|
[`hole (λ (r s a e h) (values h e))]
|
||||||
[ctm (compile contractum any?)])
|
[`(in-hole ,context ,contractum)
|
||||||
(λ (r s a e h)
|
(let ([ctx (recur context)]
|
||||||
(let-values ([(term env) (ctm r s a e h)])
|
[ctm (recur contractum)])
|
||||||
(ctx r s a env term))))]
|
(λ (r s a e h)
|
||||||
[`(hide-hole ,pattern)
|
(let-values ([(term env) (ctm r s a e h)])
|
||||||
(let ([g (compile pattern any?)])
|
(ctx r s a env term))))]
|
||||||
(λ (r s a e h)
|
[`(hide-hole ,pattern)
|
||||||
(g r s a e the-hole)))]
|
(let ([g (recur pattern)])
|
||||||
[`any
|
(λ (r s a e h)
|
||||||
(λ (r s a e h)
|
(g r s a e the-hole)))]
|
||||||
(let*-values ([(lang nt) ((next-any-decision) langc sexpc)]
|
[`any
|
||||||
[(term) (gen-nt lang nt #f r s a the-hole)])
|
(λ (r s a e h)
|
||||||
(values term e)))]
|
(let*-values ([(lang nt) ((next-any-decision) langc sexpc)]
|
||||||
[(or (? symbol? (? nt? p)) `(cross ,(? symbol? p)))
|
[(term) (gen-nt lang nt #f r s a the-hole)])
|
||||||
(let ([cross? (not (symbol? pat))])
|
(values term e)))]
|
||||||
(λ (r s a e h)
|
[(or (? symbol? (? nt? p)) `(cross ,(? symbol? p)))
|
||||||
(values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))]
|
(let ([cross? (not (symbol? pat))])
|
||||||
[(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p)))
|
(λ (r s a e h)
|
||||||
(let ([g (compile p any?)])
|
(values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))]
|
||||||
(λ (r s a e h)
|
[(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p)))
|
||||||
(generate/prior pat e (λ () (g r s a e h)))))]
|
(let ([g (recur p)])
|
||||||
[(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p)))
|
(λ (r s a e h)
|
||||||
(let ([g (compile p any?)])
|
(generate/prior pat e (λ () (g r s a e h)))))]
|
||||||
(λ (r s a e h)
|
[(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p)))
|
||||||
(let-values ([(term _) (g r s a e h)])
|
(let ([g (recur p)])
|
||||||
(values term (hash-set e pat term)))))]
|
(set! mismatches? #t)
|
||||||
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?))
|
(λ (r s a e h)
|
||||||
(λ (r s a e h) (values pat e))]
|
(let-values ([(term _) (g r s a e h)])
|
||||||
[(list-rest (struct ellipsis (name sub-pat class vars)) rest)
|
(values term (hash-set e pat term)))))]
|
||||||
(let ([elemg (compile sub-pat any?)]
|
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?))
|
||||||
[tailg (compile rest any?)])
|
(λ (r s a e h) (values pat e))]
|
||||||
(λ (r s a e h)
|
[(list-rest (struct ellipsis (name sub-pat class vars)) rest)
|
||||||
(let*-values ([(len)
|
(let ([elemg (recur sub-pat)]
|
||||||
(let ([prior (hash-ref e class #f)])
|
[tailg (recur rest)])
|
||||||
(if prior prior ((next-sequence-decision) a)))]
|
(when (mismatch? name)
|
||||||
[(seq env)
|
(set! mismatches? #t))
|
||||||
(generate-sequence (λ (e h) (elemg r s a e h)) e vars len)]
|
(λ (r s a e h)
|
||||||
[(tail env)
|
(let*-values ([(len)
|
||||||
(let ([e (hash-set (hash-set env class len) name len)])
|
(let ([prior (hash-ref e class #f)])
|
||||||
(tailg r s a e h))])
|
(if prior prior ((next-sequence-decision) a)))]
|
||||||
(values (append seq tail) env))))]
|
[(seq env)
|
||||||
[(list-rest hdp tlp)
|
(generate-sequence (λ (e h) (elemg r s a e h)) e vars len)]
|
||||||
(let ([hdg (compile hdp any?)]
|
[(tail env)
|
||||||
[tlg (compile tlp any?)])
|
(let ([e (hash-set (hash-set env class len) name len)])
|
||||||
(λ (r s a e h)
|
(tailg r s a e h))])
|
||||||
(let*-values
|
(values (append seq tail) env))))]
|
||||||
([(hd env) (hdg r s a e h)]
|
[(list-rest hdp tlp)
|
||||||
[(tl env) (tlg r s a env h)])
|
(let ([hdg (recur hdp)]
|
||||||
(values (cons hd tl) env))))]
|
[tlg (recur tlp)])
|
||||||
[else
|
(λ (r s a e h)
|
||||||
(error what "unknown pattern ~s\n" pat)])))]
|
(let*-values
|
||||||
|
([(hd env) (hdg r s a e h)]
|
||||||
|
[(tl env) (tlg r s a env h)])
|
||||||
|
(values (cons hd tl) env))))]
|
||||||
|
[else
|
||||||
|
(error what "unknown pattern ~s\n" pat)]))])
|
||||||
|
(if mismatches?
|
||||||
|
(λ (r s a e h)
|
||||||
|
(let ([g (λ (s a) (generator r s a e h))]
|
||||||
|
[p? (λ (_ e) (mismatches-satisfied? e))])
|
||||||
|
(generate/pred (unparse-pattern pat) g p? s a r)))
|
||||||
|
generator)))]
|
||||||
[(compile-non-terminals)
|
[(compile-non-terminals)
|
||||||
(λ (nts any?)
|
(λ (nts any?)
|
||||||
(make-immutable-hash
|
(make-immutable-hash
|
||||||
|
|
@ -377,11 +382,9 @@
|
||||||
(compile-language sexpp sexp-bases #t)
|
(compile-language sexpp sexp-bases #t)
|
||||||
(λ (pat) (compile pat #f)))])
|
(λ (pat) (compile pat #f)))])
|
||||||
(λ (pat)
|
(λ (pat)
|
||||||
(let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))]
|
(let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))])
|
||||||
[mm-ok? (λ (_ env) (mismatches-satisfied? env))])
|
|
||||||
(λ (size attempt retries)
|
(λ (size attempt retries)
|
||||||
(let*-values ([(gen) (λ (s a) (g retries s a empty-env the-hole))]
|
(let-values ([(term env) (g retries size attempt empty-env the-hole)])
|
||||||
[(term env) (generate/pred pat gen mm-ok? size attempt retries)])
|
|
||||||
(values term (bindings env)))))))))
|
(values term (bindings env)))))))))
|
||||||
|
|
||||||
(define-struct base-cases (cross non-cross))
|
(define-struct base-cases (cross non-cross))
|
||||||
|
|
|
||||||
|
|
@ -252,7 +252,7 @@
|
||||||
(test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
|
(test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
|
||||||
'(4 4 4 4 (4 4) (4 4)))
|
'(4 4 4 4 (4 4) (4 4)))
|
||||||
(test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42))
|
(test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42))
|
||||||
#rx"generate-term: unable to generate pattern e in 42")
|
#rx"generate-term: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\) in 42")
|
||||||
(test (raised-exn-msg
|
(test (raised-exn-msg
|
||||||
exn:fail:redex:generation-failure?
|
exn:fail:redex:generation-failure?
|
||||||
(parameterize ([generation-decisions
|
(parameterize ([generation-decisions
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user