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

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

Browse Source
This commit is contained in:
Robby Findler 2012-01-09 22:23:23 -06:00
parent e067a4415a
commit 11059e2b5c
1 changed files with 62 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
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] (union none sexp[hole])) ;; mtch = (make-mtch bindings sexp[context] (or/c (non-empty-listof (listof mtch)) #f))
;; 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 ())
(make-none))) #f))
(define (none? x) (eq? x none)) (define (none? x) (eq? x #f))
;; 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 #f)]) (let ([results ((compiled-pattern-cp compiled-pattern) exp '())])
(if (compiled-pattern-skip-dup-check? compiled-pattern) (if (compiled-pattern-skip-dup-check? compiled-pattern)
results results
(and results (and results
@ -781,24 +781,12 @@ 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
(if (or ctxt-has-hide-hole?
contractum-has-hole?
contractum-has-hide-hole?
(not (null? ctxt-names))
(not (null? contractum-names)))
(match-in-hole context (match-in-hole context
contractum contractum
exp exp
match-context match-context
(if (or contractum-has-hole? contractum-has-hide-hole? (not (null? contractum-names))) match-contractum)
match-contractum #t ; contractum-has-hole?
(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)
@ -807,11 +795,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 #f)]) (let ([matches (match-pat exp '())])
(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))
none)) #f))
matches))))] matches))))]
[else [else
(lambda (exp hole-info) (lambda (exp hole-info)
@ -819,7 +807,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)
none)))))]) #f)))))])
#f #f
#t #t
names)] names)]
@ -914,11 +902,6 @@ 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")]
@ -948,7 +931,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)
none))))) #f)))))
;; 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?)
@ -1278,19 +1261,29 @@ 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 hole-info (if (null? 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
none)))))) #f)))
(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) (define (match-in-hole context contractum exp match-context match-contractum)
(λ (exp old-hole-info) (λ (exp old-hole-info)
(let ([mtches (match-context exp #t)]) (let ([mtches (match-context exp (cons match-contractum old-hole-info))])
(and mtches (and mtches
(let loop ([mtches mtches] (let loop ([mtches mtches]
[acc null]) [acc null])
@ -1299,11 +1292,9 @@ See match-a-pattern.rkt for more details
[else [else
(let* ([mtch (car mtches)] (let* ([mtch (car mtches)]
[bindings (mtch-bindings mtch)] [bindings (mtch-bindings mtch)]
[hole-exp (mtch-hole mtch)] [contractum-mtches (mtch-hole mtch)])
[contractum-mtches (match-contractum hole-exp old-hole-info)]) (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"))
(if contractum-mtches
(let i-loop ([contractum-mtches contractum-mtches] (let i-loop ([contractum-mtches contractum-mtches]
[acc acc]) [acc acc])
(cond (cond
@ -1320,24 +1311,7 @@ See match-a-pattern.rkt for more details
(mtch-context mtch) (mtch-context mtch)
(mtch-context contractum-mtch)) (mtch-context contractum-mtch))
(mtch-hole contractum-mtch)) (mtch-hole contractum-mtch))
acc)))])) 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
(let loop ([mtches mtches])
(cond
[(null? mtches) #f]
[else
(let* ([mtch (car mtches)]
[hole-exp (mtch-hole mtch)]
[contractum-mtches (match-contractum hole-exp)])
(when (eq? none hole-exp)
(error 'matcher.rkt "found no hole when matching a decomposition"))
(or contractum-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)
@ -1399,7 +1373,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 '())
none)]) #f)])
(apply (apply
append append
(cons (let/ec k (cons (let/ec k
@ -1458,40 +1432,10 @@ See match-a-pattern.rkt for more details
(list null) (list null)
(fail))])))) (fail))]))))
(define null-match (list (make-mtch (make-bindings '()) '() none))) (define null-match (list (make-mtch (make-bindings '()) '() #f)))
(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]
@ -1536,9 +1480,7 @@ See match-a-pattern.rkt for more details
fst) fst)
mtchs)) mtchs))
;(match-list/raw/no-repeats/no-ambiguity patterns exp hole-info) (match-list/raw/no-repeats 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)
@ -1584,11 +1526,10 @@ 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
[(eq? none s1) s2] [(not s1) s2]
[(eq? none s2) s1] [(not 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])
@ -1670,7 +1611,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 #f)) #t))) (and (remove-bindings/filter (nt-proc exp '())) #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))
@ -1681,7 +1622,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)
none)))] #f)))]
[skip-dup? [skip-dup?
(define res (nt-proc exp hole-info)) (define res (nt-proc exp hole-info))
(and res (and res
@ -1809,7 +1750,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 '())
none))) #f)))
;; 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)