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

remove (broken) attempt at optimization Jay suggested

Browse Source 
also clean up some test cases that I wasn't sure about earlier
This commit is contained in:
Robby Findler 2012-01-08 11:52:57 -06:00
parent 0459e4fbcd
commit fbed2d5af7
5 changed files with 113 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/redex/examples/r6rs/r6rs-tests.rkt
View File

@ -2,7 +2,6 @@
(require racket/match (require racket/match
redex/reduction-semantics redex/reduction-semantics
(for-syntax racket/base) (for-syntax racket/base)
(only-in redex/private/matcher strip-nt-match)
"test.rkt" "test.rkt"
"r6rs.rkt") "r6rs.rkt")
@ -39,7 +38,7 @@
t t
(or verbose? 'dots) (or verbose? 'dots)
(verify-p* t))]) (verify-p* t))])
(let ([rewritten-results (remove-duplicates (map (λ (x) (rewrite-actual (strip-nt-match x))) results))]) (let ([rewritten-results (remove-duplicates (map rewrite-actual results))])
(for-each (verify-a* t) results) (for-each (verify-a* t) results)
(unless (set-same? expected rewritten-results equal?) (unless (set-same? expected rewritten-results equal?)
(set! failed-tests (+ failed-tests 1)) (set! failed-tests (+ failed-tests 1))
@ -144,7 +143,7 @@
(define (appears-in-set? x e) (define (appears-in-set? x e)
(let loop ([e e]) (let loop ([e e])
(match (strip-nt-match e) (match e
[`(set! ,x2 ,e2) (or (eq? x x2) [`(set! ,x2 ,e2) (or (eq? x x2)
(loop e2))] (loop e2))]
[else [else
@ -165,7 +164,7 @@
(term (r6rs-subst-many (sub-vars ... body))))) (term (r6rs-subst-many (sub-vars ... body)))))
(define (do-one-subst sub-vars term) (define (do-one-subst sub-vars term)
(match (strip-nt-match term) (match term
[`(store ,str ,exps ...) [`(store ,str ,exps ...)
(let* ([keep-vars (let* ([keep-vars
(map (λ (pr) (map (λ (pr)
@ -2041,7 +2040,7 @@ of digits with deconv-base
[i (in-naturals)]) [i (in-naturals)])
(for ([test (in-list (cadr set))] (for ([test (in-list (cadr set))]
[j (in-naturals)]) [j (in-naturals)])
(match (strip-nt-match (r6test-test test)) (match (r6test-test test)
[(and `(store () ,exp) [(and `(store () ,exp)
(? no-bads?)) (? no-bads?))
(set! r6-module-bodies (cons exp r6-module-bodies)) (set! r6-module-bodies (cons exp r6-module-bodies))

285
collects/redex/private/matcher.rkt
View File

@ -662,45 +662,6 @@ See match-a-pattern.rkt for more details
(not (for/or ([name (in-list names)]) (not (for/or ([name (in-list names)])
(pair? name)))))) (pair? name))))))
;; name-to-key/binding : hash[symbol -o> key-wrap]
(define name-to-key/binding (make-hasheq))
(define-struct key-wrap (sym) #:inspector (make-inspector))
(define-struct nt-match (exp nt clang-ht) #:transparent)
(define-syntax (nt-match/try-again stx)
(syntax-case stx ()
[(_ (λ (exp hole-info) body ...))
(with-syntax ([(try-again) (generate-temporaries (list (string->symbol
(format "try-again:~a.~a"
(syntax-line stx)
(syntax-column stx)))))])
#'(letrec ([try-again (λ (exp hole-info)
(if (nt-match? exp)
(try-again (nt-match-exp exp) hole-info)
(begin body ...)))])
try-again))]))
(define-syntax (nt-match/try-again1 stx)
(syntax-case stx ()
[(_ (λ (exp) body ...))
(with-syntax ([(try-again) (generate-temporaries (list (string->symbol
(format "try-again:~a.~a"
(syntax-line stx)
(syntax-column stx)))))])
#'(letrec ([try-again (λ (exp)
(if (nt-match? exp)
(try-again (nt-match-exp exp))
(begin body ...)))])
try-again))]))
(define (strip-nt-match exp)
(let loop ([exp exp])
(cond
[(pair? exp) (cons (loop (car exp))
(loop (cdr exp)))]
[(nt-match? exp) (loop (nt-match-exp exp))]
[else exp])))
;; compile-pattern/cross? : compiled-lang pattern boolean -> (values compiled-pattern boolean) ;; compile-pattern/cross? : compiled-lang pattern boolean -> (values compiled-pattern boolean)
(define (compile-pattern/cross? clang pattern bind-names?) (define (compile-pattern/cross? clang pattern bind-names?)
(define clang-ht (compiled-lang-ht clang)) (define clang-ht (compiled-lang-ht clang))
@ -778,35 +739,15 @@ See match-a-pattern.rkt for more details
(define has-hole? (hash-ref has-hole-or-hide-hole-ht nt)) (define has-hole? (hash-ref has-hole-or-hide-hole-ht nt))
(values (values
(if has-hole? (if has-hole?
(letrec ([try-again (λ (exp hole-info)
(λ (exp hole-info) (match-nt (hash-ref clang-list-ht nt)
(cond (hash-ref clang-ht nt)
[(nt-match? exp) nt exp hole-info))
(if (and (eq? nt (nt-match-nt exp)) (λ (exp)
(eq? clang-ht (nt-match-clang-ht exp)) (match-nt/boolean
(not hole-info)) (hash-ref clang-list-ht nt)
(list (hash-ref clang-ht nt)
(make-mtch empty-bindings exp none)) nt exp)))
(try-again (nt-match-exp exp) hole-info))]
[else
(match-nt (hash-ref clang-list-ht nt)
(hash-ref clang-ht nt)
nt exp hole-info (and #f in-name?) clang-ht)]))])
try-again)
(letrec ([try-again
(λ (exp)
(cond
[(nt-match? exp)
(if (and (eq? nt (nt-match-nt exp))
(eq? clang-ht (nt-match-clang-ht exp)))
#t
(try-again (nt-match-exp exp)))]
[else
(match-nt/boolean
(hash-ref clang-list-ht nt)
(hash-ref clang-ht nt)
nt exp)]))])
try-again))
has-hole? has-hole?
#f #f
'())] '())]
@ -865,20 +806,18 @@ See match-a-pattern.rkt for more details
(values (values
(cond (cond
[(or has-hole? has-hide-hole? (not (null? names))) [(or has-hole? has-hide-hole? (not (null? names)))
(nt-match/try-again (lambda (exp hole-info)
(lambda (exp hole-info) (let ([matches (match-pat exp #f)])
(let ([matches (match-pat exp #f)]) (and matches
(and matches (map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none))
(map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none)) matches))))]
matches)))))]
[else [else
(nt-match/try-again (lambda (exp hole-info)
(lambda (exp hole-info) (let ([matches (match-pat exp)])
(let ([matches (match-pat exp)]) (and matches
(and matches (list (make-mtch empty-bindings
(list (make-mtch empty-bindings (hole->not-hole exp)
(hole->not-hole exp) none)))))])
none))))))])
#f #f
#t #t
names)] names)]
@ -886,19 +825,17 @@ See match-a-pattern.rkt for more details
(define-values (match-pat has-hole? has-hide-hole? names) (compile-pattern/default-cache pat)) (define-values (match-pat has-hole? has-hide-hole? names) (compile-pattern/default-cache pat))
(values (values
(if (or has-hole? has-hide-hole? (not (null? names))) (if (or has-hole? has-hide-hole? (not (null? names)))
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (let ([matches (match-pat exp hole-info)])
(let ([matches (match-pat exp hole-info)]) (and matches
(and matches (let ([filtered (filter (λ (m) (condition (mtch-bindings m)))
(let ([filtered (filter (λ (m) (condition (mtch-bindings m))) (filter-multiples matches))])
(filter-multiples matches))]) (if (null? filtered)
(if (null? filtered) #f
#f filtered)))))
filtered)))))) (λ (exp)
(nt-match/try-again1 (and (match-pat exp)
(λ (exp) (condition empty-bindings))))
(and (match-pat exp)
(condition empty-bindings)))))
has-hole? has-hole?
has-hide-hole? has-hide-hole?
names)] names)]
@ -908,11 +845,10 @@ See match-a-pattern.rkt for more details
(cond (cond
[(hash-maps? across-ht id) [(hash-maps? across-ht id)
(values (values
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (match-nt (hash-ref across-list-ht id)
(match-nt (hash-ref across-list-ht id) (hash-ref across-ht id)
(hash-ref across-ht id) id exp hole-info))
id exp hole-info #f clang-ht)))
#t #t
#f #f
'())] '())]
@ -947,32 +883,29 @@ See match-a-pattern.rkt for more details
(values (values
(cond (cond
[(not (or any-has-hole? any-has-hide-hole? (not (null? names)))) [(not (or any-has-hole? any-has-hide-hole? (not (null? names))))
(nt-match/try-again1 (λ (exp)
(λ (exp) (cond
(cond [(list? exp) (match-list/boolean rewritten exp)]
[(list? exp) (match-list/boolean rewritten exp)] [else #f]))]
[else #f])))]
[(= 0 repeats) [(= 0 repeats)
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (cond
(cond [(list? exp)
[(list? exp) ;; shortcircuit: if the list isn't the right length, give up immediately.
;; shortcircuit: if the list isn't the right length, give up immediately. (if (= (length exp) non-repeats)
(if (= (length exp) non-repeats) (match-list/no-repeats rewritten/coerced exp hole-info)
(match-list/no-repeats rewritten/coerced exp hole-info) #f)]
#f)] [else #f]))]
[else #f])))]
[else [else
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (cond
(cond [(list? exp)
[(list? exp) ;; shortcircuit: if the list doesn't have the right number of
;; shortcircuit: if the list doesn't have the right number of ;; fixed parts, give up immediately
;; fixed parts, give up immediately (if (>= (length exp) non-repeats)
(if (>= (length exp) non-repeats) (match-list rewritten/coerced exp hole-info)
(match-list rewritten/coerced exp hole-info) #f)]
#f)] [else #f]))])
[else #f])))])
any-has-hole? any-has-hole?
any-has-hide-hole? any-has-hide-hole?
names)] names)]
@ -995,8 +928,7 @@ See match-a-pattern.rkt for more details
;; simple-match : (any -> bool) -> (values <compiled-pattern> boolean boolean) ;; simple-match : (any -> bool) -> (values <compiled-pattern> boolean boolean)
;; does a match based on a built-in Scheme predicate ;; does a match based on a built-in Scheme predicate
(define (simple-match pred) (define (simple-match pred)
(values (nt-match/try-again1 (values (lambda (exp) (pred exp))
(lambda (exp) (pred exp)))
#f #f
#f #f
'())) '()))
@ -1018,19 +950,18 @@ See match-a-pattern.rkt for more details
;; match-named-pat : symbol <compiled-pattern> -> <compiled-pattern> ;; match-named-pat : symbol <compiled-pattern> -> <compiled-pattern>
(define (match-named-pat name match-pat mismatch-bind?) (define (match-named-pat name match-pat mismatch-bind?)
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (let ([matches (match-pat exp hole-info)])
(let ([matches (match-pat exp hole-info)]) (and matches
(and matches (map (lambda (match)
(map (lambda (match) (make-mtch
(make-mtch (make-bindings (cons (if mismatch-bind?
(make-bindings (cons (if mismatch-bind? (make-mismatch-bind name (mtch-context match))
(make-mismatch-bind name (mtch-context match)) (make-bind name (mtch-context match)))
(make-bind name (mtch-context match))) (bindings-table (mtch-bindings match))))
(bindings-table (mtch-bindings match)))) (mtch-context match)
(mtch-context match) (mtch-hole match)))
(mtch-hole match))) matches)))))
matches))))))
;; has-underscore? : symbol -> boolean ;; has-underscore? : symbol -> boolean
(define (has-underscore? sym) (define (has-underscore? sym)
@ -1323,20 +1254,18 @@ See match-a-pattern.rkt for more details
;; match-hole : compiled-pattern ;; match-hole : compiled-pattern
(define match-hole (define match-hole
(nt-match/try-again (λ (exp hole-info)
(λ (exp hole-info) (if hole-info
(if hole-info (list (make-mtch empty-bindings
(list (make-mtch empty-bindings the-hole
the-hole exp))
exp)) (and (hole? exp)
(and (hole? exp) (list (make-mtch empty-bindings
(list (make-mtch empty-bindings the-hole
the-hole none))))))
none)))))))
;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern -> compiled-pattern ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern -> compiled-pattern
(define (match-in-hole context contractum exp match-context match-contractum) (define (match-in-hole context contractum exp match-context match-contractum)
(nt-match/try-again
(λ (exp old-hole-info) (λ (exp old-hole-info)
(let ([mtches (match-context exp #t)]) (let ([mtches (match-context exp #t)])
(and mtches (and mtches
@ -1369,24 +1298,23 @@ See match-a-pattern.rkt for more details
(mtch-context contractum-mtch)) (mtch-context contractum-mtch))
(mtch-hole contractum-mtch)) (mtch-hole contractum-mtch))
acc)))])) acc)))]))
(loop (cdr mtches) acc)))]))))))) (loop (cdr mtches) acc)))]))))))
(define (match-in-hole/contractum-boolean context contractum exp match-context match-contractum) (define (match-in-hole/contractum-boolean context contractum exp match-context match-contractum)
(nt-match/try-again1 (λ (exp)
(λ (exp) (let ([mtches (match-context exp #t)])
(let ([mtches (match-context exp #t)]) (and mtches
(and mtches (let loop ([mtches mtches])
(let loop ([mtches mtches]) (cond
(cond [(null? mtches) #f]
[(null? mtches) #f] [else
[else (let* ([mtch (car mtches)]
(let* ([mtch (car mtches)] [hole-exp (mtch-hole mtch)]
[hole-exp (mtch-hole mtch)] [contractum-mtches (match-contractum hole-exp)])
[contractum-mtches (match-contractum hole-exp)]) (when (eq? none hole-exp)
(when (eq? none hole-exp) (error 'matcher.rkt "found no hole when matching a decomposition"))
(error 'matcher.rkt "found no hole when matching a decomposition")) (or contractum-mtches
(or contractum-mtches (loop (cdr mtches))))]))))))
(loop (cdr mtches))))])))))))
;; match-list/boolean : (listof (union repeat (any hole-info -> boolean))) sexp hole-info -> boolean ;; match-list/boolean : (listof (union repeat (any hole-info -> boolean))) sexp hole-info -> boolean
(define (match-list/boolean patterns exp) (define (match-list/boolean patterns exp)
@ -1660,9 +1588,9 @@ See match-a-pattern.rkt for more details
(mtch-hole match)))) (mtch-hole match))))
matches)) matches))
;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info boolean clang ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info
;; -> (union #f (listof bindings)) ;; -> (union #f (listof bindings))
(define (match-nt list-rhs non-list-rhs nt term hole-info use-nt-match? clang-ht) (define (match-nt list-rhs non-list-rhs nt term hole-info)
(if hole-info (if hole-info
(let loop ([rhss (if (or (null? term) (pair? term)) (let loop ([rhss (if (or (null? term) (pair? term))
@ -1675,7 +1603,7 @@ See match-a-pattern.rkt for more details
#f #f
ans)] ans)]
[else [else
(let ([mth (call-nt-proc/bindings (car rhss) term hole-info #f #f #f)]) (let ([mth (call-nt-proc/bindings (car rhss) term hole-info)])
(cond (cond
[mth [mth
(loop (cdr rhss) (append mth ans))] (loop (cdr rhss) (append mth ans))]
@ -1690,7 +1618,7 @@ See match-a-pattern.rkt for more details
(cond (cond
[(null? rhss) #f] [(null? rhss) #f]
[else [else
(or (call-nt-proc/bindings (car rhss) term hole-info use-nt-match? nt clang-ht) (or (call-nt-proc/bindings (car rhss) term hole-info)
(loop (cdr rhss)))])))) (loop (cdr rhss)))]))))
(define (match-nt/boolean list-rhs non-list-rhs nt term) (define (match-nt/boolean list-rhs non-list-rhs nt term)
@ -1706,9 +1634,9 @@ See match-a-pattern.rkt for more details
(define (call-nt-proc/bool nt-proc exp) (define (call-nt-proc/bool nt-proc exp)
(if (procedure-arity-includes? nt-proc 1) (if (procedure-arity-includes? nt-proc 1)
(nt-proc exp) (nt-proc exp)
(and (remove-bindings/filter (nt-proc exp #f) #f #f #f) #t))) (and (remove-bindings/filter (nt-proc exp #f)) #t)))
(define (call-nt-proc/bindings compiled-pattern exp hole-info use-nt-match? nt clang-ht) (define (call-nt-proc/bindings compiled-pattern exp hole-info)
(define nt-proc (compiled-pattern-cp compiled-pattern)) (define nt-proc (compiled-pattern-cp compiled-pattern))
(define skip-dup? (compiled-pattern-skip-dup-check? compiled-pattern)) (define skip-dup? (compiled-pattern-skip-dup-check? compiled-pattern))
(define has-names? (compiled-pattern-binds-names? compiled-pattern)) (define has-names? (compiled-pattern-binds-names? compiled-pattern))
@ -1725,26 +1653,22 @@ See match-a-pattern.rkt for more details
(if has-names? (if has-names?
(map (λ (match) (map (λ (match)
(make-mtch empty-bindings (make-mtch empty-bindings
(if use-nt-match? (mtch-context match)
(make-nt-match (mtch-context match) nt clang-ht)
(mtch-context match))
(mtch-hole match))) (mtch-hole match)))
res) res)
res))] res))]
[else [else
(remove-bindings/filter (nt-proc exp hole-info) use-nt-match? nt clang-ht)])) (remove-bindings/filter (nt-proc exp hole-info))]))
;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
(define (remove-bindings/filter matches use-nt-match? nt clang-ht) (define (remove-bindings/filter matches)
(and matches (and matches
(let ([filtered (filter-multiples matches)]) (let ([filtered (filter-multiples matches)])
;(printf ">> ~s\n=> ~s\n\n" matches filtered) ;(printf ">> ~s\n=> ~s\n\n" matches filtered)
(and (not (null? filtered)) (and (not (null? filtered))
(map (λ (match) (map (λ (match)
(make-mtch empty-bindings (make-mtch empty-bindings
(if use-nt-match? (mtch-context match)
(make-nt-match (mtch-context match) nt clang-ht)
(mtch-context match))
(mtch-hole match))) (mtch-hole match)))
matches))))) matches)))))
@ -1996,5 +1920,4 @@ See match-a-pattern.rkt for more details
the-not-hole the-hole hole? the-not-hole the-hole hole?
rewrite-ellipses rewrite-ellipses
build-compatible-context-language build-compatible-context-language
caching-enabled? caching-enabled?)
strip-nt-match)

2
collects/redex/private/term.rkt
View File

@ -22,7 +22,7 @@
[(_ (a b ...) e) (syntax (with-syntax (a) (with-syntax* (b ...) e)))])) [(_ (a b ...) e) (syntax (with-syntax (a) (with-syntax* (b ...) e)))]))
(define-syntax-rule (term t) (define-syntax-rule (term t)
(#%expression (strip-nt-match (term/private t)))) (#%expression (term/private t)))
(define-syntax (term/private orig-stx) (define-syntax (term/private orig-stx)
(define outer-bindings '()) (define outer-bindings '())

1
collects/redex/tests/matcher-test.rkt
View File

@ -415,7 +415,6 @@
(test-empty '(hide-hole a) 'b #f) (test-empty '(hide-hole a) 'b #f)
(test-empty '(hide-hole a) 'a (list (make-test-mtch (make-bindings '()) 'a none))) (test-empty '(hide-hole a) 'a (list (make-test-mtch (make-bindings '()) 'a none)))
(test-empty '(hide-hole a) '(block-in-hole a) #f) (test-empty '(hide-hole a) '(block-in-hole a) #f)
(eprintf "skipping test ~s\n" '(test-empty '(in-hole (list x (hide-hole hole)) 1) '(x 1) #f))
(test-empty '(in-hole (list x hole) 1) '(x 1) (list (make-test-mtch (make-bindings '()) '(x 1) none))) (test-empty '(in-hole (list x hole) 1) '(x 1) (list (make-test-mtch (make-bindings '()) '(x 1) none)))
(test-empty '(in-hole (list hole (hide-hole hole)) junk) (test-empty '(in-hole (list hole (hide-hole hole)) junk)
'(junk junk2) '(junk junk2)

8
collects/redex/tests/tl-test.rkt
View File

@ -1,7 +1,7 @@
#lang racket #lang racket
(require "../reduction-semantics.rkt" (require "../reduction-semantics.rkt"
"test-util.rkt" "test-util.rkt"
(only-in "../private/matcher.rkt" make-bindings make-bind) (only-in "../private/matcher.rkt" make-bindings make-bind the-not-hole)
racket/match racket/match
racket/trace racket/trace
"../private/struct.rkt") "../private/struct.rkt")
@ -313,7 +313,7 @@
L L
(in-hole (cross e) e) (in-hole (cross e) e)
(term (cont (1 hole)))) (term (cont (1 hole))))
(((e (cont (1 hole)))) (((e (cont (1 ,the-not-hole))))
((e 1))))) ((e 1)))))
(let () (let ()
(define-language L (define-language L
@ -338,10 +338,10 @@
(in-hole (cross e) e) (in-hole (cross e) e)
(term ((cont ((λ (x) x) hole)) (λ (y) y)))) (term ((cont ((λ (x) x) hole)) (λ (y) y))))
(((e x)) (((e x))
((e ((cont ((λ (x) x) hole)) (λ (y) y)))) ((e ((cont ((λ (x) x) ,the-not-hole)) (λ (y) y))))
((e y)) ((e y))
((e (λ (y) y))) ((e (λ (y) y)))
((e (cont ((λ (x) x) hole))))))) ((e (cont ((λ (x) x) ,the-not-hole)))))))
;; test caching ;; test caching
(let () (let ()