From 5c6d7a39346e80d8cb808cee36fe39760791f109 Mon Sep 17 00:00:00 2001
From: yjqww6 <343519265@qq.com>
Date: Wed, 3 Feb 2021 21:16:16 +0800
Subject: [PATCH] ChezScheme: use types to eliminate some dirty stores

---
 racket/src/ChezScheme/mats/cptypes.ms |  16 ++++
 racket/src/ChezScheme/s/cp0.ss        |   9 ++
 racket/src/ChezScheme/s/cpnanopass.ss | 130 +++++++++++++++-----------
 racket/src/ChezScheme/s/cptypes.ss    |  57 ++++++++++-
 racket/src/ChezScheme/s/primdata.ss   |  17 ++--
 racket/src/ChezScheme/s/prims.ss      |   6 ++
 6 files changed, 170 insertions(+), 65 deletions(-)

diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms
index 0b6fad861f..9465cee774 100644
--- a/racket/src/ChezScheme/mats/cptypes.ms
+++ b/racket/src/ChezScheme/mats/cptypes.ms
@@ -1128,3 +1128,19 @@
     '(lambda (f) (box? (box (f))))
     '(lambda (f) (#3%$value (f)) #t))
 )
+
+(mat cptypes-store-immediate
+  (cptypes-equivalent-expansion?
+   '(lambda (v)
+      (let loop ([i 0])
+        (when (fx< i (vector-length v))
+          (vector-set! v i i)
+          (loop (fx+ i 1)))))
+   '(lambda (v)
+      (let loop ([i 0])
+        (when (fx< i (vector-length v))
+          (vector-set! v i (#3%$immediate i))
+          (loop (fx+ i 1))))))
+  (cptypes-equivalent-expansion?
+   '(lambda (x y) (set-box! x (if (vector? y) #t (error 't))))
+   '(lambda (x y) (set-box! x (#3%$immediate (if (vector? y) #t (error 't)))))))
diff --git a/racket/src/ChezScheme/s/cp0.ss b/racket/src/ChezScheme/s/cp0.ss
index ad4548e885..10623b79d6 100644
--- a/racket/src/ChezScheme/s/cp0.ss
+++ b/racket/src/ChezScheme/s/cp0.ss
@@ -5233,6 +5233,15 @@
             (make-1seq* 'ignored (list e1 e3))]
            [else
             `(call ,preinfo ,pr ,e1 ,e2 ,e3)]))]
+      [(call ,preinfo ,pr ,e)
+       (guard (eq? (primref-name pr) '$immediate))
+       (context-case ctxt
+         [(ignored) (cp0 e ctxt env sc wd name moi)]
+         [else
+          (let ([e (cp0 e 'value env sc wd name moi)])
+            (nanopass-case (Lsrc Expr) e
+              [(quote ,d) e]
+              [else `(call ,preinfo ,pr ,e)]))])]
       [(call ,preinfo ,e ,e* ...)
        (let ()
          (define lift-let
diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss
index 754acb9e46..bc56b2a278 100644
--- a/racket/src/ChezScheme/s/cpnanopass.ss
+++ b/racket/src/ChezScheme/s/cpnanopass.ss
@@ -3842,6 +3842,15 @@
                   (values (cons e e*)
                     (lambda (body)
                       (dobind (dobind* body))))))))
+        (define dirty-store-binder
+          (lambda (multiple-ref? type e)
+            (nanopass-case (L7 Expr) e
+              [(call ,info ,mdcl ,pr ,e)
+               (guard (eq? (primref-name pr) '$immediate))
+               (let-values ([(t dobind) (binder multiple-ref? type e)])
+                 (values `(call ,info ,mdcl ,pr ,t) dobind))]
+              [else
+               (binder multiple-ref? type e)])))
         (define-syntax $bind
           (lambda (x)
             (syntax-case x ()
@@ -3872,6 +3881,10 @@
              ($bind list-binder multiple-ref? type (b ...) e)]
             [(_ multiple-ref? (b ...) e)
              ($bind list-binder multiple-ref? ptr (b ...) e)]))
+        (define-syntax dirty-store-bind
+          (syntax-rules ()
+            [(_ multiple-ref? (b ...) e)
+             ($bind dirty-store-binder multiple-ref? ptr (b ...) e)]))
         (define lift-fp-unboxed
           (lambda (k)
             (lambda (e)
@@ -4100,34 +4113,39 @@
                                      (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e))
                                      (lambda (s r) (add-store-fence `(seq ,s ,r))))]
             [(base index offset e build-assign build-barrier-seq)
-             (if (nanopass-case (L7 Expr) e
-                   [(quote ,d) (ptr->imm d)]
-                   [(call ,info ,mdcl ,pr ,e* ...)
-                    (eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))]
-                   [else #f])
-                 (build-assign base index offset e)
-                 (let ([a (if (eq? index %zero)
-                              (%lea ,base offset)
-                              (%lea ,base ,index offset))])
-                   ; NB: should work harder to determine cases where x can't be a fixnum
-                   (if (nanopass-case (L7 Expr) e
-                         [(quote ,d) #t]
-                         [(literal ,info) #t]
-                         [else #f])
-                       (bind #f ([e e])
-                         ; eval a second so the address is not live across any calls
-                         (bind #t ([a a])
-                           (build-barrier-seq
-                             (build-assign a %zero 0 e)
-                             (%inline remember ,a))))
-                       (bind #t ([e e])
-                         ; eval a second so the address is not live across any calls
-                         (bind #t ([a a])
-			   (build-barrier-seq
-                             (build-assign a %zero 0 e)
-                             `(if ,(%type-check mask-fixnum type-fixnum ,e)
-                                  ,(%constant svoid)
-                                  ,(%inline remember ,a))))))))]))
+             (nanopass-case (L7 Expr) e
+               [(call ,info ,mdcl ,pr ,e)
+                (guard (eq? (primref-name pr) '$immediate))
+                (build-assign base index offset e)]
+               [else
+                (if (nanopass-case (L7 Expr) e
+                      [(quote ,d) (ptr->imm d)]
+                      [(call ,info ,mdcl ,pr ,e* ...)
+                       (eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))]
+                      [else #f])
+                    (build-assign base index offset e)
+                    (let ([a (if (eq? index %zero)
+                                 (%lea ,base offset)
+                                 (%lea ,base ,index offset))])
+                      ; NB: should work harder to determine cases where x can't be a fixnum
+                      (if (nanopass-case (L7 Expr) e
+                            [(quote ,d) #t]
+                            [(literal ,info) #t]
+                            [else #f])
+                          (bind #f ([e e])
+                            ; eval a second so the address is not live across any calls
+                            (bind #t ([a a])
+                              (build-barrier-seq
+                               (build-assign a %zero 0 e)
+                               (%inline remember ,a))))
+                          (bind #t ([e e])
+                            ; eval a second so the address is not live across any calls
+                            (bind #t ([a a])
+			      (build-barrier-seq
+                               (build-assign a %zero 0 e)
+                               `(if ,(%type-check mask-fixnum type-fixnum ,e)
+                                    ,(%constant svoid)
+                                    ,(%inline remember ,a))))))))])]))
         (define make-build-cas
           (lambda (old-v)
             (lambda (base index offset v)
@@ -6063,6 +6081,8 @@
                  `(if ,(%type-check mask-fixnum type-fixnum ,e)
                       ,(%constant strue)
                       ,(%type-check mask-immediate type-immediate ,e)))])
+        (define-inline 3 $immediate
+          [(e) e])
 
         (define-inline 3 $inexactnum-real-part
           [(e) (build-$inexactnum-real-part e)])
@@ -6552,28 +6572,32 @@
           [(e1 e2) (build-dirty-store e1 (constant port-name-disp) e2)])
         (define-inline 2 set-box!
           [(e-box e-new)
-           (bind #t (e-box e-new)
-             `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
-                  ,(build-dirty-store e-box (constant box-ref-disp) e-new)
-                  ,(build-libcall #t src sexpr set-box! e-box e-new)))])
+           (bind #t (e-box)
+             (dirty-store-bind #t (e-new)
+               `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
+                    ,(build-dirty-store e-box (constant box-ref-disp) e-new)
+                    ,(build-libcall #t src sexpr set-box! e-box e-new))))])
         (define-inline 2 box-cas!
           [(e-box e-old e-new)
-           (bind #t (e-box e-old e-new)
-             `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
-                  ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq)
-                  ,(build-libcall #t src sexpr box-cas! e-box e-old e-new)))])
+           (bind #t (e-box e-old)
+             (dirty-store-bind #t (e-new)
+               `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
+                    ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq)
+                    ,(build-libcall #t src sexpr box-cas! e-box e-old e-new))))])
         (define-inline 2 set-car!
           [(e-pair e-new)
-           (bind #t (e-pair e-new)
-             `(if ,(%type-check mask-pair type-pair ,e-pair)
-                  ,(build-dirty-store e-pair (constant pair-car-disp) e-new)
-                  ,(build-libcall #t src sexpr set-car! e-pair e-new)))])
+           (bind #t (e-pair)
+             (dirty-store-bind #t (e-new)
+               `(if ,(%type-check mask-pair type-pair ,e-pair)
+                    ,(build-dirty-store e-pair (constant pair-car-disp) e-new)
+                    ,(build-libcall #t src sexpr set-car! e-pair e-new))))])
         (define-inline 2 set-cdr!
           [(e-pair e-new)
-           (bind #t (e-pair e-new)
-             `(if ,(%type-check mask-pair type-pair ,e-pair)
-                  ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new)
-                  ,(build-libcall #t src sexpr set-cdr! e-pair e-new)))])
+           (bind #t (e-pair)
+             (dirty-store-bind #t (e-new)
+               `(if ,(%type-check mask-pair type-pair ,e-pair)
+                    ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new)
+                    ,(build-libcall #t src sexpr set-cdr! e-pair e-new))))])
         (define-inline 3 $set-symbol-hash!
           ; no need for dirty store---e2 should be a fixnum
           [(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)])
@@ -9746,10 +9770,11 @@
               [(e-v e-i e-new) (go e-v e-i e-new)])
             (define-inline 2 vector-set!
               [(e-v e-i e-new)
-               (bind #t (e-v e-i e-new)
-                 `(if ,(build-vector-set!-check e-v e-i #f)
-                      ,(go e-v e-i e-new)
-                      ,(build-libcall #t src sexpr vector-set! e-v e-i e-new)))])
+               (bind #t (e-v e-i)
+                 (dirty-store-bind #t (e-new)
+                   `(if ,(build-vector-set!-check e-v e-i #f)
+                        ,(go e-v e-i e-new)
+                        ,(build-libcall #t src sexpr vector-set! e-v e-i e-new))))])
             (define-inline 3 $vector-set-immutable!
               [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)]))
           (let ()
@@ -9763,10 +9788,11 @@
               [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])
             (define-inline 2 vector-cas!
               [(e-v e-i e-old e-new)
-               (bind #t (e-v e-i e-old e-new)
-                 `(if ,(build-vector-set!-check e-v e-i #f)
-                      ,(go e-v e-i e-old e-new)
-                      ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new)))]))
+               (bind #t (e-v e-i e-old)
+                 (dirty-store-bind #t (e-new)
+                   `(if ,(build-vector-set!-check e-v e-i #f)
+                        ,(go e-v e-i e-old e-new)
+                        ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new))))]))
           (let ()
             (define (go e-v e-i e-new)
               `(set!
diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss
index d2aec57c6a..17eeecffd3 100644
--- a/racket/src/ChezScheme/s/cptypes.ss
+++ b/racket/src/ChezScheme/s/cptypes.ss
@@ -649,9 +649,10 @@ Notes:
     (primref-name->predicate (primref-name pr) extend?))
 
   (define (check-constant-is? x pred?)
-    (nanopass-case (Lsrc Expr) x
-      [(quote ,d) (pred? d)]
-      [else #f]))
+    (and (Lsrc? x)
+         (nanopass-case (Lsrc Expr) x
+           [(quote ,d) (pred? d)]
+           [else #f])))
 
   (define (primref->result-predicate pr arity)
     (define parameterlike? box?)
@@ -694,6 +695,18 @@ Notes:
   (define (primref->unsafe-primref pr)
     (lookup-primref 3 (primref-name pr)))
 
+  (define (predicate-implies-immediate? x)
+    (and (not (eq? x 'ptr)) ;fast path to avoid duplicated computation
+         (or (check-constant-is? x (lambda (x) (and ($immediate? x)
+                                                    (not (fixnum? x)))))
+             (predicate-implies? x 'fixnum)
+             (predicate-implies? x 'boolean)
+             (predicate-implies? x 'char))))
+
+  (define (non-literal-immediate? e x)
+    (and (not (check-constant-is? e (lambda (e) #t)))
+         (predicate-implies-immediate? x)))
+
 
   (module ()
     (with-output-language (Lsrc Expr)
@@ -892,6 +905,30 @@ Notes:
       (define-specialize 2 $record
         [(rtd . e*) (values `(call ,preinfo ,pr ,rtd ,e* ...) (rtd->record-predicate rtd #t) ntypes #f #f)])
 
+      (let ()
+        (define-syntax define-set-immediate
+          (syntax-rules ()
+            [(_ set (args ... val))
+             (define-set-immediate set (args ... val) void-rec)]
+            [(_ set (args ... val) ret)
+             (define-specialize 2 set
+               [(args ... val) (values `(call ,preinfo ,pr
+                                              ,args ...
+                                              ,(if (non-literal-immediate? val (get-type val))
+                                                   `(call ,(make-preinfo-call)
+                                                          ,(lookup-primref 3 '$immediate)
+                                                          ,val)
+                                                   val))
+                                       ret ntypes #f #f)])]))
+        (define-set-immediate $record-set! (rec i val))
+        (define-set-immediate $record-cas! (rec i old new) 'boolean)
+        (define-set-immediate vector-set! (vec i val))
+        (define-set-immediate vector-cas! (vec i old new) 'boolean)
+        (define-set-immediate set-box! (b val))
+        (define-set-immediate box-cas! (b old new) 'boolean)
+        (define-set-immediate set-car! (p val))
+        (define-set-immediate set-cdr! (p val)))
+
       (define-specialize 2 (record? $sealed-record?)
         [(val rtd) (let* ([val-type (get-type val)]
                           [to-unsafe (and (fx= level 2) 
@@ -1500,7 +1537,10 @@ Notes:
                                                          types1
                                                          new-types)])))])))])]
       [(set! ,maybe-src ,x ,[e 'value types plxc -> e ret types t-types f-types])
-       (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)]
+       (values `(set! ,maybe-src ,x ,(if (non-literal-immediate? e ret)
+                                         `(call ,(make-preinfo-call) ,(lookup-primref 3 '$immediate) ,e)
+                                         e))
+               void-rec types #f #f)]
       [(call ,preinfo ,pr ,e* ...)
        (fold-call/primref preinfo pr e* ctxt types plxc)]
       [(case-lambda ,preinfo ,cl* ...)
@@ -1566,7 +1606,14 @@ Notes:
                #f #f)]
       [(record-set! ,rtd ,type ,index ,[e1 'value types plxc -> e1 ret1 types1 t-types1 f-types1]
                     ,[e2 'value types plxc -> e2 ret2 types2 t-types2 f-types2])
-       (values `(record-set! ,rtd ,type ,index ,e1 ,e2)
+       (values `(record-set! ,rtd ,type ,index ,e1
+                             ,(cond
+                               [(and (eq? type 'scheme-object)
+                                     (non-literal-immediate? e2 ret2))
+                                `(call ,(make-preinfo-call)
+                                       ,(lookup-primref 3 '$immediate)
+                                       ,e2)]
+                               [else e2]))
                void-rec
                (pred-env-add/ref (pred-env-intersect/base types1 types2 types)
                                  e1 '$record plxc)
diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss
index 3605056374..d83e7442b4 100644
--- a/racket/src/ChezScheme/s/primdata.ss
+++ b/racket/src/ChezScheme/s/primdata.ss
@@ -329,7 +329,7 @@
   (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02])
   (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs])
   (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02])
-  (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs])
+  (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs cptypes2])
   (vector->list [sig [(vector) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
   (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs])
   (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs])
@@ -710,8 +710,8 @@
 )
 
 (define-symbol-flags* ([libraries (rnrs mutable-pairs)] [flags primitive proc])
-  (set-car! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs])
-  (set-cdr! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs])
+  (set-car! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs cptypes2])
+  (set-cdr! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs cptypes2])
 )
 
 (define-symbol-flags* ([libraries (rnrs mutable-strings)] [flags primitive proc])
@@ -1163,7 +1163,7 @@
   (block-write [sig [(textual-output-port string) (textual-output-port string length) -> (void)]] [flags true])
   (box [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags])
+  (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags cptypes2])
   (box-immobile [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (break [sig [(ptr ...) -> (ptr ...)]] [flags])
@@ -1652,7 +1652,7 @@
   (set-binary-port-output-buffer! [sig [(binary-output-port bytevector) -> (void)]] [flags true])
   (set-binary-port-output-index! [sig [(binary-output-port sub-index) -> (void)]] [flags true])
   (set-binary-port-output-size! [sig [(binary-output-port sub-length) -> (void)]] [flags true])
-  (set-box! [sig [(box ptr) -> (void)]] [flags true])
+  (set-box! [sig [(box ptr) -> (void)]] [flags true cptypes2])
   (set-phantom-bytevector-length! [sig [(phantom-bytevector uptr) -> (void)]] [flags true])
   (set-port-bol! [sig [(textual-output-port ptr) -> (void)]] [flags true])
   (set-port-eof! [sig [(input-port ptr) -> (void)]] [flags true])
@@ -1804,7 +1804,7 @@
   (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument
   (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
   (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
-  (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags])
+  (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags cptypes2])
   (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
   (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
   (vector->pseudo-random-generator [sig [(vector) -> (pseudo-random-generator)]] [flags])
@@ -2164,6 +2164,7 @@
   ($hashtable-veclen [flags discard])
   ($ht-minlen [flags single-valued discard])
   ($ht-veclen [flags single-valued discard])
+  ($immediate [sig [(ptr) -> (ptr)]] [flags pure discard])
   ($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted]) ; no mifoldable due to fixnum
   ($impoops [flags abort-op])
   ($import-library [flags single-valued])
@@ -2311,12 +2312,12 @@
   ($recompile-importer-path [flags single-valued])
   ($record [flags single-valued cp02 cptypes2 unrestricted alloc]) ; first arg should be an rtd, but we don't check
   ($record? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
-  ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags single-valued])
+  ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags single-valued cptypes2])
   ($record-equal-procedure [flags single-valued discard])
   ($record-hash-procedure [flags single-valued discard])
   ($record-oops [sig [(maybe-who sub-ptr rtd) -> (bottom)]] [flags abort-op])
   ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags single-valued discard cp03])
-  ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true])
+  ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true cptypes2])
   ($record-type-descriptor [flags single-valued pure mifoldable discard true])
   ($record-type-field-offsets [flags single-valued pure mifoldable discard true])
   ($record-type-field-count [sig [(ptr) -> (fixnum)]] [flags single-valued pure mifoldable discard true])
diff --git a/racket/src/ChezScheme/s/prims.ss b/racket/src/ChezScheme/s/prims.ss
index bfde6f4ed7..2be34e334c 100644
--- a/racket/src/ChezScheme/s/prims.ss
+++ b/racket/src/ChezScheme/s/prims.ss
@@ -1412,6 +1412,12 @@
   (lambda (b) 
     (#3%immutable-box? b)))
 
+(define-who $immediate
+  (lambda (x)
+    (if ($immediate? x)
+        x
+        ($oops who "~s is not an immediate value" x))))
+
 (define pair? (lambda (x) (pair? x)))
 
 (define box? (lambda (x) (box? x)))