From 2c5c3916523cabac276cf3d59356ed225a7ac03f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 7 Apr 2019 19:29:27 +0200
Subject: [PATCH] add `$record-{ref,set!,cas!}`

original commit: 01b029b11be3bbe165752294f26617d036ba4b49
---
 s/cpnanopass.ss | 27 +++++++++++++++++++++++++++
 s/primdata.ss   |  3 +++
 s/prims.ss      | 15 +++++++++++++++
 3 files changed, 45 insertions(+)

diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index b05cff4993..d76f35636d 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -7952,6 +7952,33 @@
                  `(if ,(build-vector-set!-check e-v e-i e-new)
                       ,(go e-v e-i e-new)
                       ,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))])))
+          (let ()
+            (define (go e-v e-i)
+              (nanopass-case (L7 Expr) e-i
+                [(quote ,d)
+                 (guard (target-fixnum? d))
+                 (%mref ,e-v ,(+ (fix d) (constant record-data-disp)))]
+                [else (%mref ,e-v ,e-i ,(constant record-data-disp))]))
+            (define-inline 3 $record-ref
+              [(e-v e-i) (go e-v e-i)]))
+          (let ()
+            (define (go e-v e-i e-new)
+              (nanopass-case (L7 Expr) e-i
+                [(quote ,d)
+                 (guard (target-fixnum? d))
+                 (build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)]
+                [else (build-dirty-store e-v e-i (constant record-data-disp) e-new)]))
+            (define-inline 3 $record-set!
+              [(e-v e-i e-new) (go e-v e-i e-new)]))
+          (let ()
+            (define (go e-v e-i e-old e-new)
+              (nanopass-case (L7 Expr) e-i
+                [(quote ,d)
+                 (guard (target-fixnum? d))
+                 (build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)]
+                [else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)]))
+            (define-inline 3 $record-cas!
+              [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]))
           (let ()
             (define build-bytevector-ref-check
               (lambda (e-bits e-bv e-i check-mutable?)
diff --git a/s/primdata.ss b/s/primdata.ss
index 1e3e57b004..9e2a946115 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -2157,9 +2157,12 @@
   ($recompile-importer-path [flags])
   ($record [flags cp02 unrestricted alloc]) ; first arg should be an rtd, but we don't check
   ($record? [flags pure mifoldable discard])
+  ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags])
   ($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-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])
   ($reloc [flags])
diff --git a/s/prims.ss b/s/prims.ss
index 03c97ded01..e5cc770f49 100644
--- a/s/prims.ss
+++ b/s/prims.ss
@@ -1118,6 +1118,21 @@
   (lambda (s)
     (#3%immutable-fxvector? s)))
 
+; not safe
+(define $record-ref
+   (lambda (v i)
+      (#3%$record-ref v i)))
+
+; not safe
+(define $record-set!
+   (lambda (v i x)
+      (#3%$record-set! v i x)))
+
+; not safe
+(define $record-cas!
+   (lambda (v i old-x new-x)
+      (#3%$record-cas! v i old-x new-x)))
+
 (define cons (lambda (x y) (cons x y)))
 
 (define car