ChezScheme: use types to eliminate some dirty stores

2021-02-03 21:16:16 +08:00 · 2021-02-03 21:16:16 +08:00 · 5c6d7a3934
commit 5c6d7a3934
parent f968945e26
6 changed files with 170 additions and 65 deletions
--- 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)))))))
--- 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
--- 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!
--- 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)
--- 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])
--- 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)))