Using unsafe operations in racket/match

collects/racket/match/compiler.rkt

@@ -116,6 +116,9 @@
      ;; all the rows are structures with the same predicate
      (let* ([s (Row-first-pat (car rows))]
             [accs (Struct-accessors s)]
+            [accs (if (Struct-complete? s)
+                      (build-list (length accs) (λ (i) #`(λ (x) (unsafe-struct*-ref x #,i))))
+                      accs)]
             [pred (Struct-pred s)])
        (compile-con-pat accs pred Struct-ps))]
     [else (error 'match-compile "bad key: ~a" k)]))

collects/racket/match/parse-helper.rkt

@@ -85,13 +85,17 @@
         (let ([super (list-ref (extract-struct-info (syntax-local-value
                                                      struct-name))
                                5)])
-          (cond [(equal? super #t) '()] ;; no super type exists
+          (cond [(equal? super #t) (values #t '())] ;; no super type exists
-                [(equal? super #f) '()] ;; super type is unknown
+                [(equal? super #f) (values #f '())] ;; super type is unknown
-                [else (cons super (get-lineage super))])))
+                [else 
+                 (let-values ([(complete? lineage) (get-lineage super)])
+                   (values complete?
+                           (cons super lineage)))])))
       (unless pred
         (raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
                                            (syntax->datum struct-name))
                             stx struct-name))
+      (let-values ([(complete? lineage) (get-lineage (cert struct-name))])
         (let* (;; the accessors come in reverse order
                [acc (reverse acc)]
                ;; remove the first element, if it's #f
@@ -102,7 +106,7 @@
                        (syntax-property 
                         pred 
                         'disappeared-use (list struct-name))
-                     (get-lineage (cert struct-name))
+                       lineage complete?
                        acc
                        (cond [(eq? '_ (syntax-e pats))                            
                               (map make-Dummy acc)]
@@ -121,7 +125,7 @@
                              [else (raise-syntax-error
                                     'match
                                     "improper syntax for struct pattern"
-                                  stx pats)]))))))
+                                    stx pats)])))))))
 
 (define (trans-match pred transformer pat)
   (make-And (list (make-Pred pred) (make-App transformer pat))))

collects/racket/match/patterns.rkt

@@ -55,9 +55,10 @@
 
 ;; pred is an identifier
 ;; super is an identifier, or #f
+;; complete? is a boolean
 ;; accessors is a listof identifiers (NB in reverse order from the struct info)
 ;; ps is a listof patterns
-(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
+(define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
 
 ;; both fields are lists of pats
 (define-struct (HashTable CPat) (key-pats val-pats) #:transparent)

collects/tests/match/plt-match-tests.rkt

@@ -179,6 +179,18 @@
                     (else #f)))
                 (check-true (origin? (make-point 0 0)))
                 (check-false (origin? (make-point 1 1)))))
+   ; This test ensures that the unsafe struct optimization is correct
+   (test-case "struct patterns (with opaque parent)"
+              (let ()
+                (define-struct opq (any))
+                (parameterize ([current-inspector (make-sibling-inspector)])
+                  (define-struct point (x y) #:super struct:opq)
+                  (define (origin? pt)
+                    (match pt
+                      ((struct point (0 0)) #t)
+                      (else #f)))
+                  (check-true (origin? (make-point 'a 0 0)))
+                  (check-false (origin? (make-point 'a 1 1))))))
    ))
 
 (define nonlinear-tests