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

Improve match compilation of ? and fix bugs.

Browse Source 
- Coalesce repeated use of the same predicate.
- Fix scoring of Exact patterns, and scoring generally.
- Use `OrderedAnd` where needed.
- Guarantee that `and` patterns match in order.
- Thread bound variable information properly in GSeq compilation.
- Warn when variables are used non-linearly with `...`
  (making this behave properly was not backwards compatible).

Closes #952, which now runs in <1ms and make it a test case.

Also add margin note about `?` patterns and multiple calls.
This commit is contained in:
Sam Tobin-Hochstadt 2015-06-04 09:47:37 -04:00
parent e1e89adf62
commit fc6ead4ac2
9 changed files with 183 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/scribblings/reference/match.scrbl
View File

@ -290,7 +290,8 @@ In more detail, patterns match as follows:
@item{@racket[(#,(racketidfont "and") _pat ...)] --- matches if all
of the @racket[_pat]s match. This pattern is often used as
@racket[(#,(racketidfont "and") _id _pat)] to bind @racket[_id]
to the entire value that matches @racket[pat].
to the entire value that matches @racket[pat]. The @racket[_pat]s are
matched in the order that they appear.
@examples[
#:eval match-eval
@ -345,6 +346,11 @@ In more detail, patterns match as follows:
@racketidfont{?}, unlike @racketidfont{and}, guarantees that
@racket[_expr] is matched before any of the @racket[_pat]s.
@margin-note{The @racket[_expr] procedure may be called more than once
on identical input (although this happens only rarely),
and the order in which calls to @racket[_expr] are
made should not be relied upon.}
@examples[
#:eval match-eval
(match '(1 3 5)

48
pkgs/racket-test/tests/match/examples.rkt
View File

@ -727,6 +727,54 @@
(match (cons 1 1)
[(cons a b) #:when (= a b) 1]
[_ 0]))
(test-case
"robby's slow example"
(define v
(let ()
(define ht (make-hash))
(define (L4e? e-exp)
(hash-set! ht e-exp (+ (hash-ref ht e-exp 0) 1))
(match e-exp
[`(,(? is-biop?) ,(? L4e?) ,(? L4e?)) #t]
[`(,_ ,(? L4e?)) #t]
[`(new-array ,(? L4e?) ,(? L4e?)) #t]
[`(new-tuple ,(? L4e?) ...) #t]
[`(aref ,(? L4e?) ,(? L4e?)) #t]
[`(aset ,(? L4e?) ,(? L4e?) ,(? L4e?)) #t]
[`(alen ,(? L4e?)) #t]
[`(print ,(? L4e?)) #t]
[`(make-closure ,(? symbol?) ,(? L4e?)) #t]
[`(closure-proc ,(? L4e?)) #t]
[`(begin ,(? L4e?) ,(? L4e?)) #t]
[`(closure-vars ,(? L4e?)) #t]
[`(let ((,(? symbol?) ,(? L4e?))) ,(? L4e?)) #t]
[`(if ,(? L4e?) ,(? L4e?) ,(? L4e?)) #t]
[`(,(? L4e?) ...) #t]
[(? L3v?) #t]
[_ #f]))
(define (is-biop? sym) (or (is-aop? sym) (is-cmp? sym)))
(define (is-aop? sym) (memq sym '(+ - *)))
(define (is-cmp? sym) (memq sym '(< <= =)))
(define (L3v? v) (or (number? v) (symbol? v)))
(list
(L4e? '(let ((less_than (make-closure :lambda_0 (new-tuple))))
(let ((L5_swap (make-closure :lambda_1 (new-tuple))))
(let ((L5_sort_helper (new-tuple 0)))
(begin
(aset L5_sort_helper 0 (make-closure :lambda_2 (new-tuple L5_sort_helper L5_swap)))
(let ((L5_sort (new-tuple 0)))
(begin
(aset L5_sort 0 (make-closure :lambda_3 (new-tuple L5_sort_helper L5_sort)))
(print (let ((f (aref L5_sort 0)))
((closure-proc f)
(closure-vars f)
(new-tuple 3 1 9 4 5 6 2 8 7 10)
less_than))))))))))
(apply max (hash-values ht)))))
(check-true (car v))
(check < (cadr v) 50))
(test-case "syntax-local-match-introduce"
(define-match-expander foo

106
racket/collects/racket/match/compiler.rkt
View File

@ -15,13 +15,16 @@
(define vars-seen (make-parameter null))
(define (hash-on f elems #:equal? [eql #t])
(define ht (if eql (make-hash) (make-hasheq)))
(define-values (ht ref set!)
(case eql
[(#t) (values (make-hash) hash-ref hash-set!)]
[(#f) (values (make-hasheq) hash-ref hash-set!)]))
;; put all the elements e in the ht, indexed by (f e)
(for ([r
;; they need to be in the original order when they come out
(reverse elems)])
(define k (f r))
(hash-set! ht k (cons r (hash-ref ht k (lambda () null)))))
(set! ht k (cons r (ref ht k (lambda () null)))))
ht)
;; generate a clause of kind k
@ -33,8 +36,7 @@
(map (lambda (row)
(define-values (p ps)
(Row-split-pats row))
(define p* (Atom-p p))
(make-Row (cons p* ps)
(make-Row (cons (make-Dummy #f) ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
@ -63,22 +65,13 @@
(compile-con-pat (list #'unsafe-car #'unsafe-cdr) #'pair?
(lambda (p) (list (Pair-a p) (Pair-d p))))]
[(eq? 'mpair k)
; XXX These should be unsafe-mcar* when mpairs have chaperones
(compile-con-pat (list #'unsafe-mcar #'unsafe-mcdr) #'mpair?
(lambda (p) (list (MPair-a p) (MPair-d p))))]
[(eq? 'string k) (constant-pat #'string?)]
[(eq? 'number k) (constant-pat #'number?)]
[(eq? 'symbol k) (constant-pat #'symbol?)]
[(eq? 'keyword k) (constant-pat #'keyword?)]
[(eq? 'char k) (constant-pat #'char?)]
[(eq? 'bytes k) (constant-pat #'bytes?)]
[(eq? 'regexp k) (constant-pat #'regexp?)]
[(eq? 'boolean k) (constant-pat #'boolean?)]
[(eq? 'null k) (constant-pat #'null?)]
;; vectors are handled specially
;; because each arity is like a different constructor
[(eq? 'vector k)
(let ([ht (hash-on (lambda (r)
(let ([ht (hash-on (lambda (r)
(length (Vector-ps (Row-first-pat r)))) rows)])
(with-syntax ([(clauses ...)
(hash-map
@ -116,6 +109,7 @@
accs)]
[pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))]
[(syntax? k) (constant-pat k)]
[else (error 'match-compile "bad key: ~a" k)]))
@ -148,7 +142,7 @@
(lambda (row)
(define-values (p ps) (Row-split-pats row))
(define v (Var-v p))
(define seen (Row-vars-seen row))
(define seen (Row-vars-seen row))
;; a new row with the rest of the patterns
(cond
;; if this was a wild-card variable, don't bind
@ -158,17 +152,27 @@
(Row-vars-seen row))]
;; if we've seen this variable before, check that it's equal to
;; the one we saw
[(for/or ([e seen])
(let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) id)))
[(for/or ([e (in-list seen)])
(let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) (or id (list v v*)))))
=>
(lambda (id)
(make-Row ps
#`(if ((match-equality-test) #,x #,id)
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen))]
(if (identifier? id)
(make-Row ps
#`(if ((match-equality-test) #,x #,id)
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen)
(begin
(log-error "non-linear pattern used in `match` with ... at ~a and ~a"
(car id) (cadr id))
(let ([v* (free-identifier-mapping-get
(current-renaming) v (lambda () v))])
(make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(cons (cons v x) (Row-vars-seen row)))))))]
;; otherwise, bind the matched variable to x, and add it to the
;; list of vars we've seen
[else (let ([v* (free-identifier-mapping-get
@ -200,7 +204,7 @@
[qs (Or-ps (car pats))]
;; the variables bound by this pattern - they're the same for the
;; whole list
[vars
[vars
(for/list ([bv (bound-vars (car qs))]
#:when (for/and ([seen-var seen])
(not (free-identifier=? bv (car seen-var)))))
@ -246,7 +250,7 @@
esc))))]
;; the And rule
[(And? first)
;; we only handle 1-row Ands
;; we only handle 1-row Ands
;; this is all the mixture rule should give us
(unless (null? (cdr block))
(error 'compile-one "And block with multiple rows: ~a" block))
@ -290,21 +294,18 @@
(Row-vars-seen row)))
#'f))))]
[(Pred? first)
;; multiple preds iff they have the identical predicate
(with-syntax ([pred? (Pred-pred first)]
[body (compile* xs
(map (lambda (row)
(define-values (_1 ps)
(Row-split-pats row))
(make-Row ps
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
block)
esc)])
#`(cond [(pred? #,x) body] [else (#,esc)]))]
;; Generalized sequences... slightly tested
;; put all the rows in the hash, indexed by their Pred pattern
;; we use the pattern so that it can have a custom equal+hash
(define ht (hash-on (lambda (r) (Row-first-pat r)) block #:equal? #t))
(with-syntax ([(clauses ...)
(hash-map
ht (lambda (k v)
(gen-clause (Pred-pred k) v x xs esc)))])
#`(cond clauses ... [else (#,esc)]))]
;; Generalized sequences... slightly tested
[(GSeq? first)
(unless (null? (cdr block))
(error 'compile-one "GSeq block with multiple rows: ~a" block))
(let* ([headss (GSeq-headss first)]
[mins (GSeq-mins first)]
[maxs (GSeq-maxs first)]
@ -327,6 +328,12 @@
[head-idss
(for/list ([heads headss])
(apply append (map bound-vars heads)))]
[heads-seen
(map (lambda (x) (cons x #f))
(apply append (map bound-vars heads)))]
[tail-seen
(map (lambda (x) (cons x x))
(bound-vars tail))]
[hid-argss (map generate-temporaries head-idss)]
[head-idss* (map generate-temporaries head-idss)]
[hid-args (apply append hid-argss)]
@ -368,8 +375,11 @@
(cdr vars)
(list (make-Row rest-pats k
(Row-unmatch (car block))
(Row-vars-seen
(car block))))
(append
heads-seen
tail-seen
(Row-vars-seen
(car block)))))
#'fail-tail))])])
(parameterize ([current-renaming
(for/fold ([ht (copy-mapping (current-renaming))])
@ -399,8 +409,10 @@
(list (make-Row (list tail)
#`tail-rhs
(Row-unmatch (car block))
(Row-vars-seen
(car block)))))
(append
heads-seen
(Row-vars-seen
(car block))))))
#'failkv))))))]
[else (error 'compile "unsupported pattern: ~a\n" first)]))
@ -409,7 +421,7 @@
(if (stx-null? clauses)
body
(quasisyntax (let* #,clauses #,body))))
(cond
(cond
;; if there are no rows, then just call the esc continuation
[(null? rows) #`(#,esc)]
;; if we have no variables, there are no more patterns to match
@ -461,8 +473,8 @@
;; esc
[c (compile-one vars (car blocks) esc)])
;; then compile the rest, with our name as the esc
(loop (cdr blocks)
#'f
(loop (cdr blocks)
#'f
(cons #`[f #,(syntax-property
#'(lambda () c)
'typechecker:called-in-tail-position #t)]

25
racket/collects/racket/match/parse-helper.rkt
View File

@ -37,8 +37,8 @@
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(box? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc
stx
(make-Box (parse (quasisyntax/loc
stx
(quote #,(unbox (syntax-e #'bx))))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
@ -51,7 +51,7 @@
;; rest : the syntax for the rest
;; pred? : recognizer for the parsed data structure (such as list?)
;; to-list: function to convert the value to a list
(define (dd-parse parse p dd rest pred? #:to-list [to-list #'values] #:mutable [mutable? #f])
(define (dd-parse parse p dd rest pred? #:to-list [to-list #f] #:mutable [mutable? #f])
(define count (ddk? dd))
(define min (and (number? count) count))
(define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
@ -61,7 +61,10 @@
(not min) ;; if we have a count, better generate general code
(Null? rest-pat)
(or (Var? pat) (Dummy? pat)))
(make-And (list (make-Pred pred?) (make-App to-list (list pat))))]
(make-OrderedAnd (list (make-Pred pred?)
(if to-list
(make-App to-list (list pat))
pat)))]
[else (make-GSeq (list (list pat))
(list min)
;; no upper bound
@ -95,7 +98,7 @@
5)])
(cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) (values #f '())] ;; super type is unknown
[else
[else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
@ -111,12 +114,12 @@
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
(syntax-property
pred
'disappeared-use (list struct-name))
lineage (and (checked-struct-info? v) complete?)
acc
(cond [(eq? '_ (syntax-e pats))
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
@ -136,7 +139,7 @@
stx pats)])))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer (list pat)))))
(make-OrderedAnd (list (make-Pred pred) (make-App transformer (list pat)))))
;; transform a match-expander application
;; parse : stx -> pattern
@ -157,7 +160,7 @@
(define introducer (make-syntax-introducer))
(parameterize ([current-match-introducer introducer])
(let* ([mstx (introducer (syntax-local-introduce stx))]
[mresult (if (procedure-arity-includes? transformer 2)
[mresult (if (procedure-arity-includes? transformer 2)
(transformer expander* mstx)
(transformer mstx))]
[result (syntax-local-introduce (introducer mresult))])
@ -205,7 +208,7 @@
;; (listof pat) syntax -> void
;; ps is never null
;; check that all the ps bind the same set of variables
(define (all-vars ps stx)
(define (all-vars ps stx)
(let* ([first-vars (bound-vars (car ps))]
[l (length ps)]
[ht (make-free-identifier-mapping)])

7
racket/collects/racket/match/parse-legacy.rkt
View File

@ -40,7 +40,7 @@
(make-Box (parse (unbox (syntax-e #'bx))))]
[#(es ...)
(ormap ddk? (syntax->list #'(es ...)))
(make-And (list (make-Pred #'vector?)
(make-OrderedAnd (list (make-Pred #'vector?)
(make-App #'vector->list
(list (parse (syntax/loc stx (es ...)))))))]
[#(es ...)
@ -48,8 +48,9 @@
[($ s . pats)
(parse-struct disarmed-stx parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred #'p)
(map parse (syntax->list #'(q1 qs ...)))))]
(make-OrderedAnd (cons (make-Pred #'p)
(list (make-And
(map parse (syntax->list #'(q1 qs ...)))))))]
[(? p)
(make-Pred (rearm #'p))]
[(= f p)

6
racket/collects/racket/match/parse.rkt
View File

@ -38,7 +38,7 @@
(identifier? #'v)
(Var (rearm #'v))]
[(and p ...)
(And (map rearm+parse (syntax->list #'(p ...))))]
(OrderedAnd (map rearm+parse (syntax->list #'(p ...))))]
[(or)
(Not (Dummy stx))]
[(or p ps ...)
@ -48,7 +48,7 @@
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
(And ps))]
(OrderedAnd ps))]
[(regexp r)
(trans-match #'matchable?
(rearm #'(lambda (e) (regexp-match r e)))
@ -163,7 +163,7 @@
[(? p q1 qs ...)
(OrderedAnd
(list (Pred (rearm #'p))
(And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
(OrderedAnd (map rearm+parse (syntax->list #'(q1 qs ...))))))]
[(? p)
(Pred (rearm #'p))]
[(app f ps ...) ;; only make a list for more than one pattern

46
racket/collects/racket/match/patterns.rkt
View File

@ -38,23 +38,35 @@
(define-struct (Box CPat) (p) #:transparent)
;; p is a pattern to match against the literal
(define-struct (Atom CPat) (p) #:transparent)
(define-struct (String Atom) () #:transparent)
(define-struct (Number Atom) () #:transparent)
(define-struct (Symbol Atom) () #:transparent)
(define-struct (Keyword Atom) () #:transparent)
(define-struct (Char Atom) () #:transparent)
(define-struct (Bytes Atom) () #:transparent)
(define-struct (Regexp Atom) () #:transparent)
(define-struct (Boolean Atom) () #:transparent)
(define-struct (Null Atom) () #:transparent)
;;(define-struct (Atom CPat) (p) #:transparent)
;(define-struct (String Atom) () #:transparent)
;; (define-struct (Number Atom) () #:transparent)
;; (define-struct (Symbol Atom) () #:transparent)
;; (define-struct (Keyword Atom) () #:transparent)
;; (define-struct (Char Atom) () #:transparent)
;; (define-struct (Bytes Atom) () #:transparent)
;; (define-struct (Regexp Atom) () #:transparent)
;; (define-struct (Boolean Atom) () #:transparent)
(define-struct (Null CPat) (p) #:transparent)
;; expr is an expression
;; ps is a list of patterns
(define-struct (App Pat) (expr ps) #:transparent)
;; pred is an expression
(define-struct (Pred Pat) (pred) #:transparent)
(define-struct (Pred Pat) (pred) #:transparent
#:property prop:equal+hash
(list (lambda (a b e?)
(and (identifier? (Pred-pred a)) (identifier? (Pred-pred b))
(free-identifier=? (Pred-pred a) (Pred-pred b))))
(lambda (v r)
(if (identifier? (Pred-pred v))
(r (syntax-e (Pred-pred v)))
(r (Pred-pred v))))
(lambda (v r)
(if (identifier? (Pred-pred v))
(r (syntax-e (Pred-pred v)))
(r (Pred-pred v))))))
;; pred is an identifier
;; super is an identifier, or #f
@ -114,14 +126,6 @@
[(Vector? p) 'vector]
[(Pair? p) 'pair]
[(MPair? p) 'mpair]
[(String? p) 'string]
[(Symbol? p) 'symbol]
[(Number? p) 'number]
[(Bytes? p) 'bytes]
[(Char? p) 'char]
[(Regexp? p) 'regexp]
[(Keyword? p) 'keyword]
[(Boolean? p) 'boolean]
[(Null? p) 'null]
[else #f]))
@ -158,7 +162,7 @@
(bound-vars (car (Or-ps p)))]
[(Box? p)
(bound-vars (Box-p p))]
[(Atom? p) null]
[(Null? p) null]
[(Pair? p)
(merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
[(MPair? p)
@ -213,5 +217,5 @@
[rhs syntax?]
[unmatch (or/c identifier? false/c)]
[vars-seen (listof (cons/c identifier?
identifier?))])))
(or/c #f identifier?)))])))

12
racket/collects/racket/match/reorder.rkt
View File

@ -56,25 +56,25 @@
(define (score col)
(define n (length col))
(define c (car col))
(define preds (list Var? Pair? Null?))
(define preds (list Var? Pair? Null? Exact?))
(cond [(or-all? preds col) (add1 n)]
[(andmap CPat? col) n]
[(Var? c) (count-while Var? col)]
[(Pair? c) (count-while Pair? col)]
[(Vector? c) (count-while Vector? col)]
[(Box? c) (count-while Box? col)]
[(Exact? c) (count-while Exact? col)]
[(Null? c) (count-while Null? col)]
[else 0]))
(define (reorder-by ps scores*)
(for/fold
([pats null])
([score-ref scores*])
(cons (list-ref ps score-ref) pats)))
(for/list ([score-ref (in-list scores*)])
(list-ref ps score-ref)))
(define (reorder-columns rows vars)
(define scores (for/list ([i (in-naturals)]
[column (in-par (map (compose Row-pats) rows))])
[column (in-par (map Row-pats rows))])
(cons i (score column))))
(define scores* (reverse (map car (sort scores > #:key cdr))))
(values

17
racket/collects/racket/match/split-rows.rkt
View File

@ -21,6 +21,21 @@
(loop/var (cons r matched-rows) prev-mats rs)]
[else
(split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(define (loop/pred matched-rows prev-mats rows orig)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(and (Pred? p) (equal? p orig))
;; use the custom equality on Pred structs
(loop/pred (cons r matched-rows) prev-mats rs orig)]
[else
(split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(define (loop/con matched-rows prev-mats struct-key rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
@ -63,6 +78,8 @@
(loop/var (list r) acc rs)]
[(Exact? p)
(loop/exact (list r) acc rs)]
[(Pred? p)
(loop/pred (list r) acc rs p)]
[(CPat? p)
(if (Struct? p)
(begin