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

first attempt at Jay's optimization for redex

Browse Source 
(only did enough to get the r6rs tests running)
This commit is contained in:
Robby Findler 2011-12-30 22:52:52 -06:00
parent 2b2c44774f
commit 424a535cf4
3 changed files with 182 additions and 132 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,6 +2,7 @@
(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")
@ -38,7 +39,7 @@
t t
(or verbose? 'dots) (or verbose? 'dots)
(verify-p* t))]) (verify-p* t))])
(let ([rewritten-results (remove-duplicates (map rewrite-actual results))]) (let ([rewritten-results (remove-duplicates (map (λ (x) (rewrite-actual (strip-nt-match x))) 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))
@ -143,7 +144,7 @@
(define (appears-in-set? x e) (define (appears-in-set? x e)
(let loop ([e e]) (let loop ([e e])
(match e (match (strip-nt-match e)
[`(set! ,x2 ,e2) (or (eq? x x2) [`(set! ,x2 ,e2) (or (eq? x x2)
(loop e2))] (loop e2))]
[else [else
@ -164,7 +165,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 term (match (strip-nt-match term)
[`(store ,str ,exps ...) [`(store ,str ,exps ...)
(let* ([keep-vars (let* ([keep-vars
(map (λ (pr) (map (λ (pr)
@ -2040,7 +2041,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 (r6test-test test) (match (strip-nt-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))

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

@ -668,6 +668,22 @@ See match-a-pattern.rkt for more details
(define name-to-key/binding (make-hasheq)) (define name-to-key/binding (make-hasheq))
(define-struct key-wrap (sym) #:inspector (make-inspector)) (define-struct key-wrap (sym) #:inspector (make-inspector))
(define-struct nt-match (exp nt clang-ht) #:transparent)
(define-syntax-rule
(nt-match/try-again (λ (exp hole-info) body))
(letrec ([try-again (λ (exp hole-info)
(if (nt-match? exp)
(try-again (nt-match-exp exp) hole-info)
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))
@ -680,6 +696,8 @@ See match-a-pattern.rkt for more details
(compiled-lang-bind-names-cache clang) (compiled-lang-bind-names-cache clang)
(compiled-lang-cache clang)))) (compiled-lang-cache clang))))
(define in-name-parameter (make-parameter #f))
(define (compile-pattern/cache pattern compiled-pattern-cache) (define (compile-pattern/cache pattern compiled-pattern-cache)
(let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)]) (let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)])
(cond (cond
@ -707,25 +725,27 @@ See match-a-pattern.rkt for more details
[`variable (simple-match symbol?)] [`variable (simple-match symbol?)]
[`(variable-except ,vars ...) [`(variable-except ,vars ...)
(values (values
(lambda (exp hole-info) (nt-match/try-again
(λ (exp hole-info)
(and (symbol? exp) (and (symbol? exp)
(not (memq exp vars)) (not (memq exp vars))
(list (make-mtch (make-bindings null) (list (make-mtch (make-bindings null)
(build-flat-context exp) (build-flat-context exp)
none)))) none)))))
#f)] #f)]
[`(variable-prefix ,var) [`(variable-prefix ,var)
(values (values
(let* ([prefix-str (symbol->string var)] (let* ([prefix-str (symbol->string var)]
[prefix-len (string-length prefix-str)]) [prefix-len (string-length prefix-str)])
(lambda (exp hole-info) (nt-match/try-again
(λ (exp hole-info)
(and (symbol? exp) (and (symbol? exp)
(let ([str (symbol->string exp)]) (let ([str (symbol->string exp)])
(and ((string-length str) . >= . prefix-len) (and ((string-length str) . >= . prefix-len)
(string=? (substring str 0 prefix-len) prefix-str) (string=? (substring str 0 prefix-len) prefix-str)
(list (make-mtch (make-bindings null) (list (make-mtch (make-bindings null)
(build-flat-context exp) (build-flat-context exp)
none))))))) none))))))))
#f)] #f)]
[`variable-not-otherwise-mentioned [`variable-not-otherwise-mentioned
(let ([literals (compiled-lang-literals clang)]) (let ([literals (compiled-lang-literals clang)])
@ -736,14 +756,30 @@ See match-a-pattern.rkt for more details
[`hole [`hole
(values match-hole #t)] (values match-hole #t)]
[`(nt ,nt) [`(nt ,nt)
(let ([in-name? (in-name-parameter)])
(values (values
(lambda (exp hole-info) (letrec ([try-again
(λ (exp hole-info)
(cond
[(nt-match? exp)
(if (and (eq? nt (nt-match-nt exp))
(eq? clang-ht (nt-match-clang-ht exp))
(not hole-info))
(list
(make-mtch (make-bindings '())
exp
none))
(try-again (nt-match-exp exp) hole-info))]
[else
(match-nt (hash-ref clang-list-ht nt) (match-nt (hash-ref clang-list-ht nt)
(hash-ref clang-ht nt) (hash-ref clang-ht nt)
nt exp hole-info)) nt exp hole-info in-name? clang-ht)]))])
(hash-ref has-hole-ht nt))] try-again)
(hash-ref has-hole-ht nt)))]
[`(name ,name ,pat) [`(name ,name ,pat)
(let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) (let-values ([(match-pat has-hole?)
(parameterize ([in-name-parameter #t])
(compile-pattern/default-cache pat))])
(values (match-named-pat name match-pat #f) (values (match-named-pat name match-pat #f)
has-hole?))] has-hole?))]
[`(mismatch-name ,name ,pat) [`(mismatch-name ,name ,pat)
@ -759,23 +795,25 @@ See match-a-pattern.rkt for more details
[`(hide-hole ,p) [`(hide-hole ,p)
(let-values ([(match-pat has-hole?) (compile-pattern/default-cache p)]) (let-values ([(match-pat has-hole?) (compile-pattern/default-cache p)])
(values (values
(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)))))
#f))] #f))]
[`(side-condition ,pat ,condition ,expr) [`(side-condition ,pat ,condition ,expr)
(let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)])
(values (values
(lambda (exp hole-info) (nt-match/try-again
(λ (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))))))
has-hole?))] has-hole?))]
[`(cross ,(? symbol? id)) [`(cross ,(? symbol? id))
(define across-ht (compiled-lang-across-ht clang)) (define across-ht (compiled-lang-across-ht clang))
@ -783,10 +821,11 @@ See match-a-pattern.rkt for more details
(cond (cond
[(hash-maps? across-ht id) [(hash-maps? across-ht id)
(values (values
(lambda (exp hole-info) (nt-match/try-again
(λ (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)))
#t)] #t)]
[else [else
(error 'compile-pattern "unknown cross reference ~a" id)])] (error 'compile-pattern "unknown cross reference ~a" id)])]
@ -797,16 +836,18 @@ See match-a-pattern.rkt for more details
(values (values
(cond (cond
[(= 0 repeats) [(= 0 repeats)
(lambda (exp hole-info) (nt-match/try-again
(λ (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 rewritten exp hole-info) (match-list rewritten exp hole-info)
#f)] #f)]
[else #f]))] [else #f])))]
[else [else
(lambda (exp hole-info) (nt-match/try-again
(λ (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
@ -814,7 +855,7 @@ See match-a-pattern.rkt for more details
(if (>= (length exp) non-repeats) (if (>= (length exp) non-repeats)
(match-list rewritten exp hole-info) (match-list rewritten exp hole-info)
#f)] #f)]
[else #f]))]) [else #f])))])
has-hole?)))] has-hole?)))]
[(? (compose not pair?)) [(? (compose not pair?))
@ -828,11 +869,12 @@ See match-a-pattern.rkt for more details
(error 'compile-language "the pattern .... can only be used in extend-language")] (error 'compile-language "the pattern .... can only be used in extend-language")]
[else [else
(values (values
(lambda (exp hole-info) (nt-match/try-again
(λ (exp hole-info)
(and (equal? pattern exp) (and (equal? pattern exp)
(list (make-mtch (make-bindings null) (list (make-mtch (make-bindings null)
(build-flat-context exp) (build-flat-context exp)
none)))) none)))))
#f)])])) #f)])]))
(define (has-name? pattern) (define (has-name? pattern)
@ -871,19 +913,21 @@ See match-a-pattern.rkt for more details
;; simple-match : (any -> bool) -> (values <compiled-pattern> boolean) ;; simple-match : (any -> bool) -> (values <compiled-pattern> 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 (lambda (exp hole-info) (values (nt-match/try-again
(lambda (exp hole-info)
(and (pred exp) (and (pred exp)
(list (make-mtch (list (make-mtch
(make-bindings null) (make-bindings null)
(build-flat-context exp) (build-flat-context exp)
none)))) none)))))
#f)) #f))
(compile-pattern/default-cache pattern)) (compile-pattern/default-cache pattern))
;; 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?)
(lambda (exp hole-info) (nt-match/try-again
(λ (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)
@ -894,7 +938,7 @@ See match-a-pattern.rkt for more details
(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)
@ -935,8 +979,7 @@ See match-a-pattern.rkt for more details
(let ([res (f x y)]) (let ([res (f x y)])
(hash-set! ht key res) (hash-set! ht key res)
res)] res)]
[else [else ans])))]))))
ans])))]))))
;; hash version, but with an extra hash that tells when to evict cache entries ;; hash version, but with an extra hash that tells when to evict cache entries
#; #;
@ -1144,7 +1187,9 @@ See match-a-pattern.rkt for more details
(floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))))) (floor (* 100 (/ overall-miss (+ overall-hits overall-miss)))))))))
;; match-hole : compiled-pattern ;; match-hole : compiled-pattern
(define (match-hole exp hole-info) (define match-hole
(nt-match/try-again
(λ (exp hole-info)
(if hole-info (if hole-info
(list (make-mtch (make-bindings '()) (list (make-mtch (make-bindings '())
the-hole the-hole
@ -1152,11 +1197,12 @@ See match-a-pattern.rkt for more details
(and (hole? exp) (and (hole? exp)
(list (make-mtch (make-bindings '()) (list (make-mtch (make-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)
(lambda (exp old-hole-info) (nt-match/try-again
(λ (exp old-hole-info)
(let ([mtches (match-context exp #t)]) (let ([mtches (match-context exp #t)])
(and mtches (and mtches
(let loop ([mtches mtches] (let loop ([mtches mtches]
@ -1188,7 +1234,7 @@ 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)))])))))))
;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings)) ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
(define (match-list patterns exp hole-info) (define (match-list patterns exp hole-info)
@ -1361,9 +1407,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 ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info boolean clang
;; -> (union #f (listof bindings)) ;; -> (union #f (listof bindings))
(define (match-nt list-rhs non-list-rhs nt term hole-info) (define (match-nt list-rhs non-list-rhs nt term hole-info use-nt-match? clang-ht)
(if hole-info (if hole-info
(let loop ([rhss (if (or (null? term) (pair? term)) (let loop ([rhss (if (or (null? term) (pair? term))
@ -1376,7 +1422,7 @@ See match-a-pattern.rkt for more details
(hash-map ht (λ (k v) k)) (hash-map ht (λ (k v) k))
#f)] #f)]
[else [else
(let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) (let ([mth (remove-bindings/filter ((car rhss) term hole-info) #f #f #f)])
(cond (cond
[mth [mth
(let ([ht (or ht (make-hash))]) (let ([ht (or ht (make-hash))])
@ -1393,17 +1439,19 @@ See match-a-pattern.rkt for more details
(cond (cond
[(null? rhss) #f] [(null? rhss) #f]
[else [else
(or (remove-bindings/filter ((car rhss) term hole-info)) (or (remove-bindings/filter ((car rhss) term hole-info) use-nt-match? nt clang-ht)
(loop (cdr rhss)))])))) (loop (cdr rhss)))]))))
;; 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) (define (remove-bindings/filter matches use-nt-match? nt clang-ht)
(and matches (and matches
(let ([filtered (filter-multiples matches)]) (let ([filtered (filter-multiples matches)])
(and (not (null? filtered)) (and (not (null? filtered))
(map (λ (match) (map (λ (match)
(make-mtch (make-bindings '()) (make-mtch (make-bindings '())
(mtch-context match) (if use-nt-match?
(make-nt-match (mtch-context match) nt clang-ht)
(mtch-context match))
(mtch-hole match))) (mtch-hole match)))
matches))))) matches)))))
@ -1642,4 +1690,5 @@ 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 (term/private t))) (#%expression (strip-nt-match (term/private t))))
(define-syntax (term/private orig-stx) (define-syntax (term/private orig-stx)
(define outer-bindings '()) (define outer-bindings '())