cp0: reductions for $record-ref

original commit: 8a04158ef995388ffcdfb369d6cfaf4ec384408d

mats/record.ms

@@ -9044,3 +9044,114 @@
            (#2%list #t #t)
            (#2%list #f (#2%record-type-sealed? rtd))))))
  )
+
+(mat cp0-kar-kons-$record-ref-optimizations
+  (eq? (let ()
+         (define-record kons (kar kdr))
+         (#3%$record-ref (make-kons 'a 'b) 0))
+       'a)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+           (define-record kons (kar kdr))
+           (#3%$record-ref (make-kons 'a 'b) 0))))
+    ''a)
+  (eq? (let ()
+         (define-record kons (kar kdr))
+         (#3%$record-ref (make-kons 'a 'b) 1))
+       'b)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+           (define-record kons (kar kdr))
+           (#3%$record-ref (make-kons 'a 'b) 1))))
+    ''b)
+
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (define-record kons (kar kdr))
+        (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3)
+                                            (begin (display 4) (display 5) 6))
+                                 0))))
+    "45123") ;"12453" is also correct
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+          (define-record kons (kar kdr))
+          (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3)
+                                              (begin (display 4) (display 5) 6))
+                                   0)))))
+    '(#2%display 
+      (begin
+        (#2%display 4)
+        (#2%display 5)
+        (#2%display 1)
+        (#2%display 2)
+        3)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (define-record kons (kar kdr))
+        (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3)
+                                            (begin (display 4) (display 5) 6))
+                                 1))))
+    "45126") ;"12456" is also correct
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+          (define-record kons (kar kdr))
+          (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3)
+                                              (begin (display 4) (display 5) 6))
+                                   1)))))
+    '(#2%display
+      (begin
+        (#2%display 4)
+        (#2%display 5)
+        (#2%display 1)
+        (#2%display 2)
+        6)))
+
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (define-record kons (kar kdr))
+        (display (#3%$record-ref (begin (display 1) (make-kons 2 3))
+                                 (begin (display 4) 0)))))
+    "412") ;"142" is also correct
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+          (define-record kons (kar kdr))
+          (display (#3%$record-ref (begin (display 1) (make-kons 2 3))
+                                   (begin (display 4) 0))))))
+    '(#2%display
+      (begin
+        (#2%display 4)
+        (#2%display 1)
+        2)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (define-record kons (kar kdr))
+        (display (#3%$record-ref (begin (display 1) (make-kons 2 3))
+                                 (begin (display 4) 1)))))
+    "413") ;"143" is also correct
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+          (define-record kons (kar kdr))
+          (display (#3%$record-ref (begin (display 1) (make-kons 2 3))
+                                   (begin (display 4) 1))))))
+    '(#2%display
+      (begin
+        (#2%display 4)
+        (#2%display 1)
+        3)))
+)

s/cp0.ss

@@ -3828,6 +3828,32 @@
                 `(record ,rtd ,rtd-expr ,(map value-visit-operand! ?e*) ...))]
              [else #f]))])
 
+      (define-inline 3 $record-ref
+        [(?r ?i)
+         (let ([i-expr (value-visit-operand! ?i)])
+           (nanopass-case (Lsrc Expr) (result-exp i-expr)
+             [(quote ,d)
+              (guard (and (fixnum? d) (fx>= d 0)))
+              (let ([r-expr (value-visit-operand! ?r)])
+                (nanopass-case (Lsrc Expr) (result-exp r-expr)
+                  [(record ,rtd1 ,rtd-expr1 ,e* ...)
+                   (let loop ([e* e*] [re* '()] [index d])
+                     (and (not (null? e*))
+                          (if (fx= index 0)
+                              (let ([e (car e*)] [e* (rappend re* (cdr e*))])
+                                (define main (if (null? e*)
+                                                 (make-nontail ctxt e)
+                                                 (make-1seq ctxt
+                                                   (make-seq* 'ignored e*)
+                                                   (make-nontail ctxt e))))
+                                (residualize-seq (list ?r ?i) '() ctxt)
+                                (non-result-exp i-expr
+                                  (non-result-exp r-expr
+                                    main)))
+                              (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))]
+                  [else #f]))]
+              [else #f]))])
+
       (let ()
         (define null-rec?
           (lambda (?ls)

s/primdata.ss

@@ -2197,7 +2197,7 @@
   ($record-equal-procedure [flags discard])
   ($record-hash-procedure [flags discard])
   ($record-oops #;[sig [(who sub-ptr rtd) -> (bottom)]] [flags abort-op])
-  ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard])
+  ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard cp03])
   ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true])
   ($record-type-descriptor [flags pure mifoldable discard true])
   ($record-type-field-offsets [flags pure mifoldable discard true])