From 684a1f1039af3281ecc2676f99a37600f646d366 Mon Sep 17 00:00:00 2001
From: Bogdan Popa <bogdan@defn.io>
Date: Fri, 6 Nov 2020 21:40:44 +0200
Subject: [PATCH] match: eliminate field refs due to _ in constructor patterns

Related to #3487.
---
 pkgs/racket-test/tests/match/examples.rkt | 24 +++++++++++++++++++++++
 racket/collects/racket/match/compiler.rkt | 23 +++++++++++++++++++++-
 2 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-test/tests/match/examples.rkt
index 45bba649dd..da96a74ae4 100644
--- a/pkgs/racket-test/tests/match/examples.rkt
+++ b/pkgs/racket-test/tests/match/examples.rkt
@@ -342,6 +342,30 @@
         [(struct tree (a (struct tree (b  _ _)) _)) (list a b)]
         [_ 'no])))
 
+   (comp
+    'ok
+    (let ()
+      (define-struct st ([x #:mutable])
+        #:transparent)
+      (define a (st 1))
+      (define b (impersonate-struct a st-x (lambda (_self _x)
+                                             (error "must not impersonate"))))
+      (match b
+        [(st _) 'ok])))
+
+   (comp
+    'ok
+    (let ()
+      (define impersonated? #f)
+      (define-struct st ([x #:mutable])
+        #:transparent)
+      (define a (st 1))
+      (define b (impersonate-struct a st-x (lambda (_self x)
+                                             (set! impersonated? #t)
+                                             x)))
+      (match b
+        [(st x) (if impersonated? 'ok 'fail)])))
+
    (comp 1
          (match #&1
            [(box a) a]
diff --git a/racket/collects/racket/match/compiler.rkt b/racket/collects/racket/match/compiler.rkt
index 15bd034060..706a4633b6 100644
--- a/racket/collects/racket/match/compiler.rkt
+++ b/racket/collects/racket/match/compiler.rkt
@@ -74,7 +74,11 @@
                                             (Row-vars-seen row)))
                                 rows)
                            esc)])
-      #`[question (let ([tmps (accs #,x)] ...) body)]))
+      (define-values (used-tmps used-accs)
+        (remove-unused-tmps #'(tmps ...) #'(accs ...) #'body))
+      (with-syntax ([(used-tmps ...) used-tmps]
+                    [(used-accs ...) used-accs])
+        #`[question (let ([used-tmps (used-accs #,x)] ...) body)])))
   (cond
     [(eq? 'box k)
      (compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))]
@@ -130,6 +134,23 @@
     [(procedure? k) (constant-pat k)]
     [else (error 'match-compile "bad key: ~a" k)]))
 
+;; Remove any `tmps' (and their associated `accs') that are not
+;; present in `body'.
+(define (remove-unused-tmps tmps accs body)
+  (define seen (make-hasheq))
+  (let loop ([stx body])
+    (cond
+      [(identifier? stx)
+       (for/first ([tmp (in-list (syntax-e tmps))] #:when (free-identifier=? tmp stx))
+         (hash-set! seen tmp #t))]
+      [(list? (syntax-e stx))
+       (for-each loop (syntax-e stx))]))
+  (for/lists (tmps accs)
+             ([tmp (in-list (syntax-e tmps))]
+              [acc (in-list (syntax-e accs))]
+              #:when (hash-has-key? seen tmp))
+    (values tmp acc)))
+
 
 ;; produces the syntax for a let clause
 (define (compile-one vars block esc)