From e1c12699394295b2f6a109b33d590e0762013b1e Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 16 Feb 2020 16:27:51 -0700
Subject: [PATCH] cs: improve chaperoned structure-property access

Avoid looking up the property twice.
---
 racket/src/cs/rumble/impersonator.ss | 15 +++--
 racket/src/cs/rumble/struct.ss       | 85 +++++++++++++---------------
 2 files changed, 48 insertions(+), 52 deletions(-)

diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss
index e135b9e4e0..140ad71ef3 100644
--- a/racket/src/cs/rumble/impersonator.ss
+++ b/racket/src/cs/rumble/impersonator.ss
@@ -39,7 +39,9 @@
 (define (do-impersonate-ref acc rtd pos orig record-name field-name)
   (impersonate-struct-or-property-ref acc rtd rtd pos orig record-name field-name))
 
-(define (impersonate-struct-or-property-ref acc rtd key1 key2/pos orig record-name field-name)
+;; `val/acc` is an accessor if `rtd`, a value otherwise;
+;; `key2/pos` is a pos if `rtd`
+(define (impersonate-struct-or-property-ref val/acc rtd key1 key2/pos orig record-name field-name)
   (cond
    [(and (impersonator? orig)
          (or (not rtd)
@@ -52,7 +54,7 @@
         (let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
           (let ([r (unsafe-struct*-ref (impersonator-val v) abs-pos)])
             (when (eq? r unsafe-undefined)
-              (raise-unsafe-undefined 'struct-ref "undefined" "use" acc (impersonator-val v) abs-pos))
+              (raise-unsafe-undefined 'struct-ref "undefined" "use" val/acc (impersonator-val v) abs-pos))
             r))]
        [(or (struct-impersonator? v)
             (struct-chaperone? v))
@@ -77,10 +79,11 @@
        [(impersonator? v)
         (loop (impersonator-next v))]
        [else
-        (if rtd
-            (let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
-              (unsafe-struct*-ref v abs-pos))
-            (acc v))]))]
+        (cond
+         [rtd
+          (let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
+            (unsafe-struct*-ref v abs-pos))]
+         [else val/acc])]))]
    [else
     (raise-argument-error (string->symbol
                            (string-append (symbol->string (or record-name 'struct))
diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss
index 3a5d6b932d..adaf8c79d0 100644
--- a/racket/src/cs/rumble/struct.ss
+++ b/racket/src/cs/rumble/struct.ss
@@ -51,15 +51,6 @@
        (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers))
      (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)]
             [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)]
-            [pred (escapes-ok
-                    (lambda (v)
-                      (let* ([v (strip-impersonator v)]
-                             [rtd (if (record-type-descriptor? v)
-                                      v
-                                      (and (record? v)
-                                           (record-rtd v)))])
-                        (and rtd
-                             (not (eq? none (struct-property-ref st rtd none)))))))]
             [accessor-name (string->symbol (string-append
                                             (symbol->string name)
                                             "-ref"))]
@@ -67,49 +58,51 @@
                              (string-append
                               (symbol->string name)
                               "?"))]
-            [default-fail
-              (escapes-ok
-                (lambda (v)
-                  (raise-argument-error accessor-name
-                                        (symbol->string predicate-name)
-                                        v)))]
-            [do-fail (lambda (fail v)
-                       (cond
-                        [(eq? fail default-fail) (default-fail v)]
-                        [(procedure? fail) (|#%app| fail)]
-                        [else fail]))])
+            [pred (procedure-rename*
+                      (lambda (v)
+                        (let* ([v (strip-impersonator v)]
+                               [rtd (if (record-type-descriptor? v)
+                                        v
+                                        (and (record? v)
+                                             (record-rtd v)))])
+                          (and rtd
+                               (not (eq? none (struct-property-ref st rtd none))))))
+                      2
+                      predicate-name)])
        (letrec ([acc
                  (procedure-rename*
                   (case-lambda
                    [(v fail)
-                    (cond
-                     [(and (impersonator? v)
-                           (pred v))
-                      (impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)]
-                     [else
-                      (let* ([rtd (if (record-type-descriptor? v)
-                                      v
-                                      (and (record? v)
-                                           (record-rtd v)))])
-                        (if rtd
-                            (let ([pv (struct-property-ref st rtd none)])
-                              (if (eq? pv none)
-                                  (do-fail fail v)
-                                  pv))
-                            (do-fail fail v)))])]
-                   [(v) (acc v default-fail)])
+                    (let ([val (let ([v (strip-impersonator v)])
+                                 (if (record-type-descriptor? v)
+                                     (struct-property-ref st v none)
+                                     (if (record? v)
+                                         (struct-property-ref st (record-rtd v) none)
+                                         none)))])
+                      (cond
+                       [(eq? val none)
+                        (cond
+                         [(eq? fail none)
+                          (raise-argument-error accessor-name
+                                                (symbol->string predicate-name)
+                                                v)]
+                         [(procedure? fail) (|#%app| fail)]
+                         [else fail])]
+                       [(impersonator? v)
+                        (impersonate-struct-or-property-ref val #f #|key1:|# acc #|key2:|# #f v #f #f)]
+                       [else val]))]
+                   [(v) (acc v none)])
                   6
                   accessor-name)])
-         (let ([pred (procedure-rename* pred 2 predicate-name)])
-           (add-to-table! property-accessors
-                          acc
-                          (cons pred can-impersonate?))
-           (add-to-table! property-predicates
-                          pred
-                          st)
-           (values st
-                   pred
-                   acc))))]))
+         (add-to-table! property-accessors
+                        acc
+                        (cons pred can-impersonate?))
+         (add-to-table! property-predicates
+                        pred
+                        st)
+         (values st
+                 pred
+                 acc)))]))
 
 (define (struct-type-property-accessor-procedure? v)
   (let ([v (strip-impersonator v)])