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

Optimize match patterns of the form (list x ...).

Browse Source 
This also applies to `(mlist x ...)`, even though
that involves two traversals when only one is
required by the old method. Timing suggests that
the new code is nonetheless faster.
This commit is contained in:
Sam Tobin-Hochstadt 2014-06-23 10:29:17 -04:00
parent 133d7a3c41
commit dcb5b09a14
7 changed files with 65 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
racket/collects/racket/match/gen-match.rkt
View File

@ -42,7 +42,8 @@
(define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
(define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
(define parsed-clauses
(for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))]

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

@ -8,7 +8,9 @@
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
match-expander-transform trans-match parse-struct
dd-parse parse-quote parse-id)
dd-parse parse-quote parse-id in-splicing?)
(define in-splicing? (make-parameter #f))
;; parse x as a match variable
;; x : identifier
@ -46,19 +48,27 @@
;; p : the repeated pattern
;; dd : the ... stx
;; rest : the syntax for the rest
(define (dd-parse parse p dd rest #:mutable [mutable? #f])
(let* ([count (ddk? dd)]
[min (and (number? count) count)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse rest)
mutable?)))
;; 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 count (ddk? dd))
(define min (and (number? count) count))
(define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
(parse p)))
(define rest-pat (parse rest))
(cond [(and (not (in-splicing?)) ;; when we're inside splicing, rest-pat isn't the rest
(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))))]
[else (make-GSeq (list (list pat))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
rest-pat
mutable?)]))
;; stx : the syntax object for the whole pattern
;; parse : the pattern parser

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

@ -64,7 +64,7 @@
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(p .. . rest)
(ddk? #'..)
(dd-parse parse #'p #'.. #'rest)]
(dd-parse parse #'p #'.. #'rest #'list?)]
[(e . es)
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
[x

9
racket/collects/racket/match/parse-quasi.rkt
View File

@ -32,14 +32,15 @@
(syntax-case stx (quasiquote unquote quote unquote-splicing)
[(unquote p) (parse #'p)]
[((unquote-splicing p) . rest)
(let ([pat (parse #'p)]
(let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
[rpat (pq #'rest)])
(if (null-terminated? pat)
(append-pats pat rpat)
(raise-syntax-error 'match "non-list pattern inside unquote-splicing"
stx #'p)))]
(append-pats pat rpat)
(raise-syntax-error 'match "non-list pattern inside unquote-splicing"
stx #'p)))]
[(p dd . rest)
(ddk? #'dd)
;; FIXME: parameterize dd-parse so that it can be used here
(let* ([count (ddk? #'dd)]
[min (and (number? count) count)])
(make-GSeq

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

@ -4,7 +4,7 @@
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt"
(for-template (only-in "runtime.rkt" matchable?)
(for-template (only-in "runtime.rkt" matchable? mlist? mlist->list)
racket/base))
(provide parse)
@ -136,10 +136,10 @@
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(list p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)))]
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'list?)]
[(mlist p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'mlist? #:to-list #'mlist->list #:mutable #t)]
[(list e es ...)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
[(mlist e es ...)
@ -150,7 +150,7 @@
(rearm+parse #'e)]
[(list-rest p dd . rest)
(ddk? #'dd)
(dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
(dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)) #'list?)]
[(list-rest e . es)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]

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

@ -50,7 +50,7 @@
(define-struct (Null Atom) () #:transparent)
;; expr is an expression
;; p is a pattern
;; ps is a list of patterns
(define-struct (App Pat) (expr ps) #:transparent)
;; pred is an expression

30
racket/collects/racket/match/runtime.rkt
View File

@ -8,9 +8,10 @@
match:error
fail
matchable?
match-prompt-tag)
match-prompt-tag
mlist? mlist->list)
(define match-prompt-tag (make-continuation-prompt-tag 'match))
(define match-prompt-tag (make-continuation-prompt-tag 'match))
(define match-equality-test (make-parameter equal?))
@ -32,3 +33,28 @@
;; can we pass this value to regexp-match?
(define (matchable? e)
(or (string? e) (bytes? e)))
;; duplicated because we can't depend on `compatibility` here
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))