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

Remove accidentally pushed commits

Browse Source 
For the curious, this was an attempt to change the way context
matching works.  Currently, when matching a pattern, if 'hole' is
encountered, the match succeeds and the result just includes the term
at that point. This means that when matching (in-hole p1 p2), p1
generally returns multiple results and then those results are thinned
out by matching p2 against the thing actually at the hole.

Instead, one could pass along the function that does the matching and
then, when matching a hole pattern, it could decide right at that
point whether or not the match works.

This seems like it would be a win overall, but it interferes with
caching. Specifically, most reduction systems have lots of rules
that all begin

  (--> (in-hole E ...) ...)

and, in the strategy first described above, that matching can be cached.

But in the second, it cannot. Overall, this turns out to be a slight
lose in the current version of Redex. Maybe if other things change, however,
this tradeoff will change.

Revert "IN PROGRESS: more context speedup attempt"

This reverts commit 0134b8753d.

Revert "IN PROGRESS: a possible speed up attempt; match the thing in the hole before returning the context matches instead of afterwards"

This reverts commit 11059e2b5c.
This commit is contained in:
Robby Findler 2012-01-15 20:45:47 -06:00
parent 4b17fe731a
commit b068d9583c
1 changed files with 142 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -87,7 +87,7 @@ See match-a-pattern.rkt for more details
(define-struct repeat (pat empty-bindings name mismatch) #:transparent) (define-struct repeat (pat empty-bindings name mismatch) #:transparent)
;; compiled-pattern : exp hole-info -> (union #f (listof mtch)) ;; compiled-pattern : exp hole-info -> (union #f (listof mtch))
;; mtch = (make-mtch bindings sexp[context] (or/c (non-empty-listof (listof mtch)) #f)) ;; mtch = (make-mtch bindings sexp[context] (union none sexp[hole]))
;; hole-info = boolean ;; hole-info = boolean
;; #f means we're not in a `in-hole' context ;; #f means we're not in a `in-hole' context
;; #t means we're looking for a hole ;; #t means we're looking for a hole
@ -106,8 +106,8 @@ See match-a-pattern.rkt for more details
(define none (define none
(let () (let ()
(define-struct none ()) (define-struct none ())
#f)) (make-none)))
(define (none? x) (eq? x #f)) (define (none? x) (eq? x none))
;; compiled-lang : (make-compiled-lang (listof nt) ;; compiled-lang : (make-compiled-lang (listof nt)
;; hash[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
@ -574,7 +574,7 @@ See match-a-pattern.rkt for more details
;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
(define (match-pattern compiled-pattern exp) (define (match-pattern compiled-pattern exp)
(let ([results ((compiled-pattern-cp compiled-pattern) exp '())]) (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)])
(if (compiled-pattern-skip-dup-check? compiled-pattern) (if (compiled-pattern-skip-dup-check? compiled-pattern)
results results
(and results (and results
@ -781,13 +781,24 @@ See match-a-pattern.rkt for more details
"found an in-hole pattern whose context position has no hole ~s" "found an in-hole pattern whose context position has no hole ~s"
pattern)) pattern))
(values (values
(match-in-hole context (if (or ctxt-has-hide-hole?
contractum contractum-has-hole?
exp contractum-has-hide-hole?
match-context (not (null? ctxt-names))
match-contractum (not (null? contractum-names)))
(or contractum-has-hole? contractum-has-hide-hole?)) (match-in-hole context
#t ; contractum-has-hole? contractum
exp
match-context
(if (or contractum-has-hole? contractum-has-hide-hole? (not (null? contractum-names)))
match-contractum
(convert-matcher match-contractum)))
(match-in-hole/contractum-boolean context
contractum
exp
match-context
match-contractum))
contractum-has-hole?
(or ctxt-has-hide-hole? contractum-has-hide-hole?) (or ctxt-has-hide-hole? contractum-has-hide-hole?)
(append ctxt-names contractum-names))] (append ctxt-names contractum-names))]
[`(hide-hole ,p) [`(hide-hole ,p)
@ -796,11 +807,11 @@ See match-a-pattern.rkt for more details
(cond (cond
[(or has-hole? has-hide-hole? (not (null? names))) [(or has-hole? has-hide-hole? (not (null? names)))
(lambda (exp hole-info) (lambda (exp hole-info)
(let ([matches (match-pat exp '())]) (let ([matches (match-pat exp #f)])
(and matches (and matches
(map (λ (match) (make-mtch (mtch-bindings match) (map (λ (match) (make-mtch (mtch-bindings match)
(hole->not-hole (mtch-context match)) (hole->not-hole (mtch-context match))
#f)) none))
matches))))] matches))))]
[else [else
(lambda (exp hole-info) (lambda (exp hole-info)
@ -808,7 +819,7 @@ See match-a-pattern.rkt for more details
(and matches (and matches
(list (make-mtch empty-bindings (list (make-mtch empty-bindings
(hole->not-hole exp) (hole->not-hole exp)
#f)))))]) none)))))])
#f #f
#t #t
names)] names)]
@ -903,6 +914,11 @@ See match-a-pattern.rkt for more details
[(? (compose not pair?)) [(? (compose not pair?))
(cond (cond
[(compiled-pattern? pattern) ;; can this really happen anymore?!
(values (compiled-pattern-cp pattern)
;; return #ts here as a failsafe; no way to check better.
#t
#t)]
[(eq? pattern '....) [(eq? pattern '....)
;; this should probably be checked at compile time, not here ;; this should probably be checked at compile time, not here
(error 'compile-language "the pattern .... can only be used in extend-language")] (error 'compile-language "the pattern .... can only be used in extend-language")]
@ -932,7 +948,7 @@ See match-a-pattern.rkt for more details
(and (boolean-based-matcher exp) (and (boolean-based-matcher exp)
(list (make-mtch empty-bindings (list (make-mtch empty-bindings
(build-flat-context exp) (build-flat-context exp)
#f))))) none)))))
;; 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?)
@ -995,9 +1011,6 @@ See match-a-pattern.rkt for more details
;(define memoize/1 (mk-memoize-key 1)) ;(define memoize/1 (mk-memoize-key 1))
;(define memoize/2 (mk-memoize-key 2)) ;(define memoize/2 (mk-memoize-key 2))
(define-syntax-rule (caching a ...) (begin a ...))
;(define-syntax-rule (caching a ...) (void))
(define-syntax (mk-memoize-vec stx) (define-syntax (mk-memoize-vec stx)
(syntax-case stx () (syntax-case stx ()
[(_ arity) [(_ arity)
@ -1005,33 +1018,30 @@ See match-a-pattern.rkt for more details
(with-syntax ([key-exp (if (= 1 (syntax-e #'arity)) (with-syntax ([key-exp (if (= 1 (syntax-e #'arity))
(car (syntax->list #'(args ...))) (car (syntax->list #'(args ...)))
#'(list args ...))]) #'(list args ...))])
#`(λ (f statsbox) #'(λ (f statsbox)
(let* ([uniq (gensym)] (let* ([uniq (gensym)]
[this-cache-size cache-size] [this-cache-size cache-size]
[ans-vec (make-vector this-cache-size uniq)] [ans-vec (make-vector this-cache-size uniq)]
[key-vec (make-vector this-cache-size uniq)]) [key-vec (make-vector this-cache-size uniq)])
#,(syntax/loc stx (lambda (args ...)
(lambda (args ...) (cond
(cond [(not (caching-enabled?)) (f args ...)]
[(not (caching-enabled?)) (f args ...)] [else
[else ;(record-cache-test! statsbox)
(caching ;(when (zero? (modulo (cache-stats-hits statsbox) 1000))
(record-cache-test! statsbox) ; (record-cache-size! statsbox (cons ans-vec key-vec)))
(when (zero? (modulo (cache-stats-hits statsbox) 1000)) (let* ([key key-exp]
(record-cache-size! statsbox (cons ans-vec key-vec)))) [index (modulo (equal-hash-code key) this-cache-size)])
(let* ([key key-exp] (cond
[index (modulo (equal-hash-code key) this-cache-size)]) [(equal? (vector-ref key-vec index) key)
(cond (vector-ref ans-vec index)]
[(equal? (vector-ref key-vec index) key) [else
(vector-ref ans-vec index)] ;(record-cache-miss! statsbox)
[else (unless (eq? uniq (vector-ref key-vec index)) (record-cache-clobber! statsbox))
(caching (let ([ans (f args ...)])
(record-cache-miss! statsbox) (vector-set! key-vec index key)
(unless (eq? uniq (vector-ref key-vec index)) (record-cache-clobber! statsbox))) (vector-set! ans-vec index ans)
(let ([ans (f args ...)]) ans)]))]))))))]))
(vector-set! key-vec index key)
(vector-set! ans-vec index ans)
ans)]))])))))))]))
(define memoize/1 (mk-memoize-vec 1)) (define memoize/1 (mk-memoize-vec 1))
(define memoize/2 (mk-memoize-vec 2)) (define memoize/2 (mk-memoize-vec 2))
@ -1268,61 +1278,66 @@ See match-a-pattern.rkt for more details
;; match-hole : compiled-pattern ;; match-hole : compiled-pattern
(define match-hole (define match-hole
(λ (exp hole-info) (λ (exp hole-info)
(if (null? hole-info) (if hole-info
(list (make-mtch empty-bindings
the-hole
exp))
(and (hole? exp) (and (hole? exp)
(list (make-mtch empty-bindings (list (make-mtch empty-bindings
the-hole the-hole
#f))) none))))))
(let ([fst (car hole-info)])
(if (procedure-arity-includes? fst 1)
(and (fst exp)
(list (make-mtch empty-bindings
the-hole
(list (make-mtch empty-bindings
exp
#f)))))
(let ([contractum-match (fst exp (cdr hole-info))])
(and contractum-match
(list (make-mtch empty-bindings
the-hole
contractum-match)))))))))
;; 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 must-use-plug?) (define (match-in-hole context contractum exp match-context match-contractum)
(λ (exp old-hole-info) (λ (exp old-hole-info)
(let ([mtches (match-context exp (cons match-contractum old-hole-info))]) (let ([mtches (match-context exp #t)])
;(printf (if must-use-plug? "/" "-")) (flush-output) (and mtches
; (when mtches (printf "mtchs ~s\n" (map (λ (x) (length (mtch-hole x))) mtches))) (let loop ([mtches mtches]
[acc null])
(cond
[(null? mtches) acc]
[else
(let* ([mtch (car mtches)]
[bindings (mtch-bindings mtch)]
[hole-exp (mtch-hole mtch)]
[contractum-mtches (match-contractum hole-exp old-hole-info)])
(when (eq? none hole-exp)
(error 'matcher.rkt "found no hole when matching a decomposition"))
(if contractum-mtches
(let i-loop ([contractum-mtches contractum-mtches]
[acc acc])
(cond
[(null? contractum-mtches) (loop (cdr mtches) acc)]
[else (let* ([contractum-mtch (car contractum-mtches)]
[contractum-bindings (mtch-bindings contractum-mtch)])
(i-loop
(cdr contractum-mtches)
(cons
(make-mtch (make-bindings
(append (bindings-table contractum-bindings)
(bindings-table bindings)))
(build-nested-context
(mtch-context mtch)
(mtch-context contractum-mtch))
(mtch-hole contractum-mtch))
acc)))]))
(loop (cdr mtches) acc)))]))))))
(define (match-in-hole/contractum-boolean context contractum exp match-context match-contractum)
(λ (exp)
(let ([mtches (match-context exp #t)])
(and mtches (and mtches
(let loop ([mtches mtches] (let loop ([mtches mtches])
[acc null])
(cond (cond
[(null? mtches) acc] [(null? mtches) #f]
[else [else
(let* ([mtch (car mtches)] (let* ([mtch (car mtches)]
[bindings (mtch-bindings mtch)] [hole-exp (mtch-hole mtch)]
[contractum-mtches (mtch-hole mtch)]) [contractum-mtches (match-contractum hole-exp)])
(unless contractum-mtches (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"))
(let i-loop ([contractum-mtches contractum-mtches] (or contractum-mtches
[acc acc]) (loop (cdr mtches))))]))))))
(cond
[(null? contractum-mtches) (loop (cdr mtches) acc)]
[else (let* ([contractum-mtch (car contractum-mtches)]
[contractum-bindings (mtch-bindings contractum-mtch)])
(i-loop
(cdr contractum-mtches)
(cons
(make-mtch (make-bindings
(append (bindings-table contractum-bindings)
(bindings-table bindings)))
(if must-use-plug?
(build-nested-context
(mtch-context mtch)
(mtch-context contractum-mtch))
(build-flat-context exp))
(mtch-hole contractum-mtch))
acc)))])))]))))))
;; 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)
@ -1384,7 +1399,7 @@ See match-a-pattern.rkt for more details
(let ([r-pat (repeat-pat fst-pat)] (let ([r-pat (repeat-pat fst-pat)]
[r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat)) [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat))
(build-flat-context '()) (build-flat-context '())
#f)]) none)])
(apply (apply
append append
(cons (let/ec k (cons (let/ec k
@ -1443,10 +1458,40 @@ See match-a-pattern.rkt for more details
(list null) (list null)
(fail))])))) (fail))]))))
(define null-match (list (make-mtch (make-bindings '()) '() #f))) (define null-match (list (make-mtch (make-bindings '()) '() none)))
(define (match-list/no-repeats patterns exp hole-info) (define (match-list/no-repeats patterns exp hole-info)
(define (match-list/raw/no-repeats/no-ambiguity patterns exp hole-info)
(let/ec k
(define-values (bindings lst hole)
(let loop ([patterns patterns]
[exp exp])
(cond
[(pair? patterns)
(let ([fst-pat (car patterns)])
(cond
[(pair? exp)
(let* ([fst-exp (car exp)]
[fst-mtchs (fst-pat fst-exp hole-info)])
(cond
[(not fst-mtchs) (k #f)]
[(null? (cdr fst-mtchs))
(define mtch1 (car fst-mtchs))
(define-values (bindings lst hole) (loop (cdr patterns) (cdr exp)))
(define new-bindings (bindings-table (mtch-bindings mtch1)))
(values (append new-bindings bindings)
(build-cons-context (mtch-context mtch1) lst)
(pick-hole (mtch-hole mtch1) hole))]
[else
(error 'ack)]))]
[else (k #f)]))]
[else
(if (null? exp)
(values '() '() none)
(k #f))])))
(list (make-mtch (make-bindings bindings) lst hole))))
(define (match-list/raw/no-repeats patterns exp hole-info) (define (match-list/raw/no-repeats patterns exp hole-info)
(let/ec k (let/ec k
(let loop ([patterns patterns] (let loop ([patterns patterns]
@ -1491,7 +1536,9 @@ See match-a-pattern.rkt for more details
fst) fst)
mtchs)) mtchs))
(match-list/raw/no-repeats patterns exp hole-info)) ;(match-list/raw/no-repeats/no-ambiguity patterns exp hole-info)
(match-list/raw/no-repeats patterns exp hole-info)
)
;; add-ellipses-index : (listof mtch) (or/c sym #f) (or/c sym #f) number -> (listof mtch) ;; add-ellipses-index : (listof mtch) (or/c sym #f) (or/c sym #f) number -> (listof mtch)
(define (add-ellipses-index mtchs name mismatch-name i) (define (add-ellipses-index mtchs name mismatch-name i)
@ -1537,10 +1584,11 @@ See match-a-pattern.rkt for more details
bindingss))) bindingss)))
multiple-bindingss))) multiple-bindingss)))
;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp)
(define (pick-hole s1 s2) (define (pick-hole s1 s2)
(cond (cond
[(not s1) s2] [(eq? none s1) s2]
[(not s2) s1] [(eq? none s2) s1]
[(error 'matcher.rkt "found two holes")])) [(error 'matcher.rkt "found two holes")]))
;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists]) ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists])
@ -1622,7 +1670,7 @@ 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 '())) #t))) (and (remove-bindings/filter (nt-proc exp #f)) #t)))
(define (call-nt-proc/bindings compiled-pattern exp hole-info) (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))
@ -1633,7 +1681,7 @@ See match-a-pattern.rkt for more details
(and (nt-proc exp) (and (nt-proc exp)
(list (make-mtch empty-bindings (list (make-mtch empty-bindings
(build-flat-context exp) (build-flat-context exp)
#f)))] none)))]
[skip-dup? [skip-dup?
(define res (nt-proc exp hole-info)) (define res (nt-proc exp hole-info))
(and res (and res
@ -1761,7 +1809,7 @@ See match-a-pattern.rkt for more details
;; this 'inlines' build-flat-context so that the definition can remain here, near where it is used. ;; this 'inlines' build-flat-context so that the definition can remain here, near where it is used.
(define combine-matches-base-case (list (make-mtch empty-bindings (define combine-matches-base-case (list (make-mtch empty-bindings
'() #;(build-flat-context '()) '() #;(build-flat-context '())
#f))) none)))
;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
(define (combine-pair fst snd) (define (combine-pair fst snd)