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

match: eliminate vector refs due to ``_ ddk''

Browse Source 
Currently, the pattern matcher always call `vector->list`
on the input vector if a ddk is detected.
However, when there is exactly one ddk and users wish not to
bind an identifier to the ddk, the whole conversion is not needed.
Instead, we can selectively `vector-ref` the prefix and the suffix
of the vector and match them directly against patterns.

Also strengthen an existing test.
This commit is contained in:
Sorawee Porncharoenwase 2020-11-28 16:58:35 -08:00 committed by Sam Tobin-Hochstadt
parent ea620f2a4a
commit ed6f990e87
2 changed files with 122 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,7 @@
#lang scheme/base
(require racket/match
(prefix-in s: racket/set)
scheme/mpair
scheme/control scheme/foreign
(only-in racket/list split-at)
@ -384,15 +385,92 @@
(comp
'ok
(let ()
(define impersonated? #f)
(define touched-indices (s:mutable-set))
(define v (vector 1 2 3))
(define b (impersonate-vector v
(lambda (self idx _)
(set! impersonated? #t)
(vector-ref self idx))
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match b
[(vector a _ _) (if impersonated? 'ok 'fail)])))
[(vector a _ _) (if (equal? (s:mutable-set 0) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match vec
[(vector _ ...) (if (equal? (s:mutable-set) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match vec
[(vector xs ...)
(if (equal? (s:mutable-set 0 1 2 3 4 5 6 7) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
;; further optimization could potentionally elide the access of 1 and 6
(match vec
[(vector a _ b _ ... c _ e)
(if (equal? (s:mutable-set 0 1 2 5 6 7) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match vec
[(vector a _ ... b _ ... c)
(if (equal? (s:mutable-set 0 1 2 3 4 5 6 7) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match vec
[(vector a _ ..8) 'fail]
[_ (if (equal? (s:mutable-set) touched-indices) 'ok 'fail)])))
(comp
'ok
(let ()
(define touched-indices (s:mutable-set))
(define vec (impersonate-vector (vector 12 14 16 18 20 22 24 26)
(λ (_ idx v)
(s:set-add! touched-indices idx)
v)
vector-set!))
(match vec
[(vector a _ ..7) (if (equal? (s:mutable-set 0) touched-indices) 'ok 'fail)])))
(comp 1
(match #&1

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

@ -2,6 +2,7 @@
(require racket/struct-info
racket/syntax
racket/list
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt"
@ -25,6 +26,31 @@
(parse-literal (syntax-e #'e))]
[_ (parse-literal (syntax-e p))]))
;; underscore? :: syntax? -> boolean?
(define (underscore? x) (eq? '_ (syntax-e x)))
;; one-wildcard-ddk? :: (listof syntax?) -> boolean?
;; return #t if there is exactly one ddk and the preceding pattern before
;; ddk is underscore
(define (one-wildcard-ddk? es)
(and (= 1 (count ddk? es))
;; the fact that count = 1 means that rest is always valid
(for/first ([be (in-list es)]
[e (in-list (rest es))]
#:when (ddk? e))
(underscore? be))))
;; split-one-wildcard-ddk :: (listof syntax?) ->
;; (listof syntax?) (listof syntax?) number?
;; precondition: es satisfies one-wildcard-ddk?
(define (split-one-wildcard-ddk es)
;; the prefix has underscore, the suffix has ddk
(define-values (prefix suffix) (splitf-at es (λ (e) (not (ddk? e)))))
(define ddk-size (ddk? (first suffix)))
(values (drop-right prefix 1)
(rest suffix)
(if (eq? ddk-size #t) 0 ddk-size)))
;; parse : syntax -> Pat
;; compile stx into a pattern, using the new syntax
(define (parse stx)
@ -75,6 +101,19 @@
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(rearm+parse #'p))]
[(box e) (Box (parse #'e))]
[(vector es ...)
(one-wildcard-ddk? (syntax->list #'(es ...)))
(let-values ([(prefix suffix ddk-size) (split-one-wildcard-ddk (syntax->list #'(es ...)))])
(define prefix-len (length prefix))
(define suffix-len (length suffix))
(trans-match
#`(λ (e) (and (vector? e) (>= (vector-length e) #,(+ prefix-len suffix-len ddk-size))))
#`(λ (e)
(define vec-len (vector-length e))
(for/list ([idx (in-sequences (in-range #,prefix-len)
(in-range (- vec-len #,suffix-len) vec-len))])
(vector-ref e idx)))
(rearm+parse (quasisyntax/loc stx (list #,@prefix #,@suffix)))))]
[(vector es ...)
(ormap ddk? (syntax->list #'(es ...)))
(trans-match #'vector?