From 4110761f945c46251de5a2332438235d60f00d2e Mon Sep 17 00:00:00 2001
From: yjqww6 <343519265@qq.com>
Date: Thu, 18 Feb 2021 14:04:17 +0800
Subject: [PATCH] cs: optimize pattern matching on authentic structs

---
 racket/src/ChezScheme/mats/cptypes.ms      | 12 +++++++++
 racket/src/ChezScheme/s/cptypes-lattice.ss | 30 +++++++++++++++++++---
 racket/src/ChezScheme/s/cptypes.ss         |  5 +++-
 3 files changed, 43 insertions(+), 4 deletions(-)

diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms
index d7d6b39386..91a48ccdc8 100644
--- a/racket/src/ChezScheme/mats/cptypes.ms
+++ b/racket/src/ChezScheme/mats/cptypes.ms
@@ -696,6 +696,18 @@
       (define-record-type ,my-rec (fields a))
       (define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t))
       (lambda (x) (and (my-rec? x) (list 'ok (#3%$sealed-record-instance? x (record-type-descriptor ,my-sub-rec)))))))
+
+  ;; obviously incompatible rtds
+  ;; the third pass is needed to eliminate #3%$value
+  (parameterize ([run-cp0 (lambda (cp0 x) (cp0 (cp0 (cp0 x))))])
+    (cptypes-equivalent-expansion?
+     `(let ()
+        (define-record I (a))
+        (define A (make-record-type-descriptor* 'a #f #f #f #f 1 0))
+        (lambda (x) (and ((record-predicate A) x) (I? x))))
+     `(begin
+        (make-record-type-descriptor* 'a #f #f #f #f 1 0)
+        (lambda (x) #f))))
 )
 
 (mat cptypes-unsafe
diff --git a/racket/src/ChezScheme/s/cptypes-lattice.ss b/racket/src/ChezScheme/s/cptypes-lattice.ss
index 5503ebcc87..c05038764e 100644
--- a/racket/src/ChezScheme/s/cptypes-lattice.ss
+++ b/racket/src/ChezScheme/s/cptypes-lattice.ss
@@ -42,6 +42,7 @@
   ; don't use rtd-* as defined in record.ss in case we're building a patch
   ; file for cross compilation, because the offsets may be incorrect
   (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors))
+  (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
 
   (define-record-type pred-$record/rtd
     (fields rtd)
@@ -49,10 +50,23 @@
     (sealed #t))
 
   (define-record-type pred-$record/ref
-    (fields ref)
-    (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
+    (fields ref maybe-rtd)
+    (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-1})
     (sealed #t))
 
+  ;could be a ctrtd
+  (define (pred-$record-maybe-rtd x)
+    (cond
+     [(pred-$record/rtd? x) (pred-$record/rtd-rtd x)]
+     [(pred-$record/ref? x) (pred-$record/ref-maybe-rtd x)]
+     [else #f]))
+
+  (define (rtd-obviously-incompatible? x y)
+    (let ([x-flds (rtd-flds x)]
+          [y-flds (rtd-flds y)])
+      (or (and (fixnum? x-flds) (not (fixnum? y-flds)))
+          (and (not (fixnum? x-flds)) (fixnum? y-flds)))))
+
   (define (check-constant-is? x pred?)
     (and (Lsrc? x)
          (nanopass-case (Lsrc Expr) x
@@ -592,10 +606,20 @@
                  [(rtd-ancestor*? y-rtd x-rtd) x]
                  [(rtd-ancestor*? x-rtd y-rtd) y]
                  [else 'bottom])]))]
+         [(pred-$record/ref? x)
+          (let ([x-rtd (pred-$record/ref-maybe-rtd x)]
+                [y-rtd (pred-$record/rtd-rtd y)])
+            (if (and x-rtd (rtd-obviously-incompatible? x-rtd y-rtd))
+                'bottom
+                (intersect/record x y)))]
          [else
           (intersect/record x y)])]
       [(pred-$record/ref? y)
-       (intersect/record x y)]
+       (let ([y-rtd (pred-$record/ref-maybe-rtd y)]
+             [x-rtd (pred-$record-maybe-rtd x)])
+         (if (and x-rtd y-rtd (rtd-obviously-incompatible? x-rtd y-rtd))
+             'bottom
+             (intersect/record x y)))]
       [else
        (case y
          [($record)
diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss
index b26374633b..4f7a01c85a 100644
--- a/racket/src/ChezScheme/s/cptypes.ss
+++ b/racket/src/ChezScheme/s/cptypes.ss
@@ -528,7 +528,10 @@ Notes:
           (make-pred-$record/rtd d)]
          [(ref ,maybe-src ,x)
           (guard (not (prelex-assigned x)))
-          (make-pred-$record/ref x)]
+          (make-pred-$record/ref x #f)]
+         [(record-type ,rtd (ref ,maybe-src ,x))
+          (guard (not (prelex-assigned x)))
+          (make-pred-$record/ref x rtd)]
          [(record-type ,rtd ,e)
           (rtd->record-predicate e extend?)]
          [else (if (not extend?) 'bottom '$record)])]