From ed6f990e87f9378d871ebd5a94996ac5955ff7a6 Mon Sep 17 00:00:00 2001 From: Sorawee Porncharoenwase Date: Sat, 28 Nov 2020 16:58:35 -0800 Subject: [PATCH] match: eliminate vector refs due to ``_ ddk'' 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. --- pkgs/racket-test/tests/match/examples.rkt | 88 +++++++++++++++++++++-- racket/collects/racket/match/parse.rkt | 39 ++++++++++ 2 files changed, 122 insertions(+), 5 deletions(-) diff --git a/pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-test/tests/match/examples.rkt index e4f3bb69b3..b7e5709579 100644 --- a/pkgs/racket-test/tests/match/examples.rkt +++ b/pkgs/racket-test/tests/match/examples.rkt @@ -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 diff --git a/racket/collects/racket/match/parse.rkt b/racket/collects/racket/match/parse.rkt index 1667450c92..941701a602 100644 --- a/racket/collects/racket/match/parse.rkt +++ b/racket/collects/racket/match/parse.rkt @@ -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?