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))

303
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
(and (symbol? exp) (λ (exp hole-info)
(not (memq exp vars)) (and (symbol? exp)
(list (make-mtch (make-bindings null) (not (memq exp vars))
(build-flat-context exp) (list (make-mtch (make-bindings null)
none)))) (build-flat-context exp)
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
(and (symbol? exp) (λ (exp hole-info)
(let ([str (symbol->string exp)]) (and (symbol? exp)
(and ((string-length str) . >= . prefix-len) (let ([str (symbol->string exp)])
(string=? (substring str 0 prefix-len) prefix-str) (and ((string-length str) . >= . prefix-len)
(list (make-mtch (make-bindings null) (string=? (substring str 0 prefix-len) prefix-str)
(build-flat-context exp) (list (make-mtch (make-bindings null)
none))))))) (build-flat-context exp)
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)
(values (let ([in-name? (in-name-parameter)])
(lambda (exp hole-info) (values
(match-nt (hash-ref clang-list-ht nt) (letrec ([try-again
(hash-ref clang-ht nt) (λ (exp hole-info)
nt exp hole-info)) (cond
(hash-ref has-hole-ht nt))] [(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)
(hash-ref clang-ht nt)
nt exp hole-info in-name? clang-ht)]))])
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
(lambda (exp hole-info) (nt-match/try-again
(let ([matches (match-pat exp #f)]) (lambda (exp hole-info)
(and matches (let ([matches (match-pat exp #f)])
(map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none)) (and matches
matches)))) (map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) none))
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
(let ([matches (match-pat exp hole-info)]) (λ (exp hole-info)
(and matches (let ([matches (match-pat exp hole-info)])
(let ([filtered (filter (λ (m) (condition (mtch-bindings m))) (and matches
(filter-multiples matches))]) (let ([filtered (filter (λ (m) (condition (mtch-bindings m)))
(if (null? filtered) (filter-multiples matches))])
#f (if (null? filtered)
filtered))))) #f
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
(match-nt (hash-ref across-list-ht id) (λ (exp hole-info)
(hash-ref across-ht id) (match-nt (hash-ref across-list-ht id)
id exp hole-info)) (hash-ref across-ht id)
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,24 +836,26 @@ See match-a-pattern.rkt for more details
(values (values
(cond (cond
[(= 0 repeats) [(= 0 repeats)
(lambda (exp hole-info) (nt-match/try-again
(cond (λ (exp hole-info)
[(list? exp) (cond
;; shortcircuit: if the list isn't the right length, give up immediately. [(list? exp)
(if (= (length exp) non-repeats) ;; shortcircuit: if the list isn't the right length, give up immediately.
(match-list rewritten exp hole-info) (if (= (length exp) non-repeats)
#f)] (match-list rewritten exp hole-info)
[else #f]))] #f)]
[else #f])))]
[else [else
(lambda (exp hole-info) (nt-match/try-again
(cond (λ (exp hole-info)
[(list? exp) (cond
;; shortcircuit: if the list doesn't have the right number of [(list? exp)
;; fixed parts, give up immediately ;; shortcircuit: if the list doesn't have the right number of
(if (>= (length exp) non-repeats) ;; fixed parts, give up immediately
(match-list rewritten exp hole-info) (if (>= (length exp) non-repeats)
#f)] (match-list rewritten exp hole-info)
[else #f]))]) #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,30 +913,32 @@ 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
(and (pred exp) (lambda (exp hole-info)
(list (make-mtch (and (pred exp)
(make-bindings null) (list (make-mtch
(build-flat-context exp) (make-bindings null)
none)))) (build-flat-context exp)
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
(let ([matches (match-pat exp hole-info)]) (λ (exp hole-info)
(and matches (let ([matches (match-pat exp hole-info)])
(map (lambda (match) (and matches
(make-mtch (map (lambda (match)
(make-bindings (cons (if mismatch-bind? (make-mtch
(make-mismatch-bind name (mtch-context match)) (make-bindings (cons (if mismatch-bind?
(make-bind name (mtch-context match))) (make-mismatch-bind name (mtch-context match))
(bindings-table (mtch-bindings match)))) (make-bind name (mtch-context match)))
(mtch-context match) (bindings-table (mtch-bindings match))))
(mtch-hole match))) (mtch-context match)
matches))))) (mtch-hole match)))
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,51 +1187,54 @@ 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
(if hole-info (nt-match/try-again
(list (make-mtch (make-bindings '()) (λ (exp hole-info)
the-hole (if hole-info
exp)) (list (make-mtch (make-bindings '())
(and (hole? exp) the-hole
(list (make-mtch (make-bindings '()) exp))
the-hole (and (hole? exp)
none))))) (list (make-mtch (make-bindings '())
the-hole
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
(let ([mtches (match-context exp #t)]) (λ (exp old-hole-info)
(and mtches (let ([mtches (match-context exp #t)])
(let loop ([mtches mtches] (and mtches
[acc null]) (let loop ([mtches mtches]
(cond [acc null])
[(null? mtches) acc] (cond
[else [(null? mtches) acc]
(let* ([mtch (car mtches)] [else
[bindings (mtch-bindings mtch)] (let* ([mtch (car mtches)]
[hole-exp (mtch-hole mtch)] [bindings (mtch-bindings mtch)]
[contractum-mtches (match-contractum hole-exp old-hole-info)]) [hole-exp (mtch-hole mtch)]
(when (eq? none hole-exp) [contractum-mtches (match-contractum hole-exp old-hole-info)])
(error 'matcher.rkt "found zero holes when matching a decomposition")) (when (eq? none hole-exp)
(if contractum-mtches (error 'matcher.rkt "found zero holes when matching a decomposition"))
(let i-loop ([contractum-mtches contractum-mtches] (if contractum-mtches
[acc acc]) (let i-loop ([contractum-mtches contractum-mtches]
(cond [acc acc])
[(null? contractum-mtches) (loop (cdr mtches) acc)] (cond
[else (let* ([contractum-mtch (car contractum-mtches)] [(null? contractum-mtches) (loop (cdr mtches) acc)]
[contractum-bindings (mtch-bindings contractum-mtch)]) [else (let* ([contractum-mtch (car contractum-mtches)]
(i-loop [contractum-bindings (mtch-bindings contractum-mtch)])
(cdr contractum-mtches) (i-loop
(cons (cdr contractum-mtches)
(make-mtch (make-bindings (cons
(append (bindings-table contractum-bindings) (make-mtch (make-bindings
(bindings-table bindings))) (append (bindings-table contractum-bindings)
(build-nested-context (bindings-table bindings)))
(mtch-context mtch) (build-nested-context
(mtch-context contractum-mtch)) (mtch-context mtch)
(mtch-hole contractum-mtch)) (mtch-context contractum-mtch))
acc)))])) (mtch-hole contractum-mtch))
(loop (cdr mtches) acc)))])))))) 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)
@ -1200,7 +1246,7 @@ See match-a-pattern.rkt for more details
(cond (cond
[(null? raw-match) '()] [(null? raw-match) '()]
[else (append (combine-matches (car raw-match)) [else (append (combine-matches (car raw-match))
(loop (cdr raw-match)))]))))) (loop (cdr raw-match)))])))))
;; match-list/raw : (listof (union repeat compiled-pattern)) ;; match-list/raw : (listof (union repeat compiled-pattern))
;; sexp ;; sexp
@ -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 '())