From b068d9583c9f5d9c7416207e90ac480f362e8dc5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 15 Jan 2012 20:45:47 -0600 Subject: [PATCH] Remove accidentally pushed commits 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 0134b8753d733b072f9b9100f02391cf43f563f9. 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 11059e2b5c3bfe9d685353771fa1208631fdc056. --- collects/redex/private/matcher.rkt | 236 +++++++++++++++++------------ 1 file changed, 142 insertions(+), 94 deletions(-) diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt index 3e7c19cb59..a2be03894e 100644 --- a/collects/redex/private/matcher.rkt +++ b/collects/redex/private/matcher.rkt @@ -87,7 +87,7 @@ See match-a-pattern.rkt for more details (define-struct repeat (pat empty-bindings name mismatch) #:transparent) ;; 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 ;; #f means we're not in a `in-hole' context ;; #t means we're looking for a hole @@ -106,8 +106,8 @@ See match-a-pattern.rkt for more details (define none (let () (define-struct none ()) - #f)) -(define (none? x) (eq? x #f)) + (make-none))) +(define (none? x) (eq? x none)) ;; compiled-lang : (make-compiled-lang (listof nt) ;; 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)) (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) 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" pattern)) (values - (match-in-hole context - contractum - exp - match-context - match-contractum - (or contractum-has-hole? contractum-has-hide-hole?)) - #t ; contractum-has-hole? + (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 + 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?) (append ctxt-names contractum-names))] [`(hide-hole ,p) @@ -796,11 +807,11 @@ See match-a-pattern.rkt for more details (cond [(or has-hole? has-hide-hole? (not (null? names))) (lambda (exp hole-info) - (let ([matches (match-pat exp '())]) + (let ([matches (match-pat exp #f)]) (and matches (map (λ (match) (make-mtch (mtch-bindings match) (hole->not-hole (mtch-context match)) - #f)) + none)) matches))))] [else (lambda (exp hole-info) @@ -808,7 +819,7 @@ See match-a-pattern.rkt for more details (and matches (list (make-mtch empty-bindings (hole->not-hole exp) - #f)))))]) + none)))))]) #f #t names)] @@ -903,6 +914,11 @@ See match-a-pattern.rkt for more details [(? (compose not pair?)) (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 '....) ;; this should probably be checked at compile time, not here (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) (list (make-mtch empty-bindings (build-flat-context exp) - #f))))) + none))))) ;; match-named-pat : symbol -> (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/2 (mk-memoize-key 2)) -(define-syntax-rule (caching a ...) (begin a ...)) -;(define-syntax-rule (caching a ...) (void)) - (define-syntax (mk-memoize-vec stx) (syntax-case stx () [(_ arity) @@ -1005,33 +1018,30 @@ See match-a-pattern.rkt for more details (with-syntax ([key-exp (if (= 1 (syntax-e #'arity)) (car (syntax->list #'(args ...))) #'(list args ...))]) - #`(λ (f statsbox) + #'(λ (f statsbox) (let* ([uniq (gensym)] [this-cache-size cache-size] [ans-vec (make-vector this-cache-size uniq)] [key-vec (make-vector this-cache-size uniq)]) - #,(syntax/loc stx - (lambda (args ...) - (cond - [(not (caching-enabled?)) (f args ...)] - [else - (caching - (record-cache-test! statsbox) - (when (zero? (modulo (cache-stats-hits statsbox) 1000)) - (record-cache-size! statsbox (cons ans-vec key-vec)))) - (let* ([key key-exp] - [index (modulo (equal-hash-code key) this-cache-size)]) - (cond - [(equal? (vector-ref key-vec index) key) - (vector-ref ans-vec index)] - [else - (caching - (record-cache-miss! statsbox) - (unless (eq? uniq (vector-ref key-vec index)) (record-cache-clobber! statsbox))) - (let ([ans (f args ...)]) - (vector-set! key-vec index key) - (vector-set! ans-vec index ans) - ans)]))])))))))])) + (lambda (args ...) + (cond + [(not (caching-enabled?)) (f args ...)] + [else + ;(record-cache-test! statsbox) + ;(when (zero? (modulo (cache-stats-hits statsbox) 1000)) + ; (record-cache-size! statsbox (cons ans-vec key-vec))) + (let* ([key key-exp] + [index (modulo (equal-hash-code key) this-cache-size)]) + (cond + [(equal? (vector-ref key-vec index) key) + (vector-ref ans-vec index)] + [else + ;(record-cache-miss! statsbox) + (unless (eq? uniq (vector-ref key-vec index)) (record-cache-clobber! statsbox)) + (let ([ans (f args ...)]) + (vector-set! key-vec index key) + (vector-set! ans-vec index ans) + ans)]))]))))))])) (define memoize/1 (mk-memoize-vec 1)) (define memoize/2 (mk-memoize-vec 2)) @@ -1268,61 +1278,66 @@ See match-a-pattern.rkt for more details ;; match-hole : compiled-pattern (define match-hole (λ (exp hole-info) - (if (null? hole-info) + (if hole-info + (list (make-mtch empty-bindings + the-hole + exp)) (and (hole? exp) (list (make-mtch empty-bindings the-hole - #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))))))))) + none)))))) ;; 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?) - (λ (exp old-hole-info) - (let ([mtches (match-context exp (cons match-contractum old-hole-info))]) - ;(printf (if must-use-plug? "/" "-")) (flush-output) - ; (when mtches (printf "mtchs ~s\n" (map (λ (x) (length (mtch-hole x))) mtches))) +(define (match-in-hole context contractum exp match-context match-contractum) + (λ (exp old-hole-info) + (let ([mtches (match-context exp #t)]) + (and 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 - (let loop ([mtches mtches] - [acc null]) + (let loop ([mtches mtches]) (cond - [(null? mtches) acc] + [(null? mtches) #f] [else (let* ([mtch (car mtches)] - [bindings (mtch-bindings mtch)] - [contractum-mtches (mtch-hole mtch)]) - (unless contractum-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")) - (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))) - (if must-use-plug? - (build-nested-context - (mtch-context mtch) - (mtch-context contractum-mtch)) - (build-flat-context exp)) - (mtch-hole contractum-mtch)) - acc)))])))])))))) + (or contractum-mtches + (loop (cdr mtches))))])))))) ;; match-list/boolean : (listof (union repeat (any hole-info -> boolean))) sexp hole-info -> boolean (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)] [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat)) (build-flat-context '()) - #f)]) + none)]) (apply append (cons (let/ec k @@ -1443,10 +1458,40 @@ See match-a-pattern.rkt for more details (list null) (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/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) (let/ec k (let loop ([patterns patterns] @@ -1491,7 +1536,9 @@ See match-a-pattern.rkt for more details fst) 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) (define (add-ellipses-index mtchs name mismatch-name i) @@ -1537,10 +1584,11 @@ See match-a-pattern.rkt for more details bindingss))) multiple-bindingss))) +;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp) (define (pick-hole s1 s2) (cond - [(not s1) s2] - [(not s2) s1] + [(eq? none s1) s2] + [(eq? none s2) s1] [(error 'matcher.rkt "found two holes")])) ;; 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) (if (procedure-arity-includes? nt-proc 1) (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 nt-proc (compiled-pattern-cp compiled-pattern)) @@ -1633,7 +1681,7 @@ See match-a-pattern.rkt for more details (and (nt-proc exp) (list (make-mtch empty-bindings (build-flat-context exp) - #f)))] + none)))] [skip-dup? (define res (nt-proc exp hole-info)) (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. (define combine-matches-base-case (list (make-mtch empty-bindings '() #;(build-flat-context '()) - #f))) + none))) ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) (define (combine-pair fst snd)