From d24cbd43442abdf52219fe0b428f1dd6d516ef2a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 22 Sep 2020 07:30:20 -0600
Subject: [PATCH] Chez Scheme GC: faster record type handling

When the GC needs to copy/mark a record, it previously forced a
copy/mark on the record's type descriptor, since the copy/mark needs
information from the descriptor. But the needed information is not in
danger of being overwritten for forwading (since it's after the first
two words of the type descriptor), so it's ok to use the old reference
as-is --- at least in non-counting mode. Simplifying record-type
handling and deferring the record-type update to the sweep phase, the
same as for other components of the record type, makes the GC slightly
faster.
---
 racket/src/ChezScheme/s/mkgc.ss | 48 ++++++++++++++++-----------------
 1 file changed, 24 insertions(+), 24 deletions(-)

diff --git a/racket/src/ChezScheme/s/mkgc.ss b/racket/src/ChezScheme/s/mkgc.ss
index de2f5e49d7..20d3408da9 100644
--- a/racket/src/ChezScheme/s/mkgc.ss
+++ b/racket/src/ChezScheme/s/mkgc.ss
@@ -307,11 +307,10 @@
 
      [record
       (trace-early-rtd record-type)
-      ;; If the rtd is the only pointer and is immutable, put the record
-      ;; into space-data. If the record contains only pointers, put it
-      ;; into space-pure or space-impure. Otherwise, put it into
-      ;; space-pure-typed-object or space-impure-record. We could put all
-      ;; records into space-{pure,impure}-record or even into
+      ;; If the record contains only pointers, put it into space-pure
+      ;; or space-impure. Otherwise, put it into
+      ;; space-pure-typed-object or space-impure-record. We could put
+      ;; all records into space-{pure,impure}-record or even into
       ;; space-impure-record, but by picking the target space more
       ;; carefully, we may reduce fragmentation and sweeping cost.
       (define rtd : ptr (record-type _))
@@ -319,10 +318,6 @@
        (cond
          [(and-counts (is_counting_root si _))
           space-count-impure]
-         [(&& (== (record-type-pm rtd) (FIX 1))
-              (== (record-type-mpm rtd) (FIX 0)))
-          ;; No pointers except for type
-          space-data]
          [(== (record-type-pm rtd) (FIX -1))
           ;; All pointers
           (cond
@@ -1568,18 +1563,23 @@
               (statements (append body (cdr l)) config))]
            [`(trace-early-rtd ,field)
             (code (case (and (not (lookup 'as-dirty? config #f))
-                             (not (lookup 'rtd-relocated? config #f))
                              (lookup 'mode config))
-                    [(copy sweep sweep-in-old mark)
-                     (code
-                      "/* Relocate to make sure we aren't using an oldspace descriptor"
-                      "   that has been overwritten by a forwarding marker, but don't loop"
-                      "   on tag-reflexive base descriptor */"
-                      (format "if (p != ~a)"
-                              (lookup 'tf config (format "TYPEFIELD(p)")))
-                      (code-block
-                       (statements `((trace-early ,field)) config)))]
-                    [(measure)
+                    [(copy mark)
+                     (cond
+                       [(lookup 'counts? config #f)
+                        (code
+                         "/* Relocate to make sure we aren't using an oldspace descriptor"
+                         "   that has been overwritten by a forwarding marker, but don't loop"
+                         "   on tag-reflexive base descriptor */"
+                         (format "if (p != ~a)"
+                                 (lookup 'tf config (format "TYPEFIELD(p)")))
+                         (code-block
+                          (statements `((trace-early ,field)) config)))]
+                       [else
+                        (code
+                         "/* Do not inspect the type or first field of the rtd, because"
+                         "   it may have been overwritten for forwarding. */")])]
+                    [(measure sweep sweep-in-old)
                      (statements `((trace-early ,field)) config)]
                     [else #f])
                   (statements (cdr l) (cons `(copy-extra-rtd ,field) config)))]
@@ -1782,7 +1782,8 @@
                                                                   (lookup 'copy-extra-rtd config #f))])
                                                  (if extra
                                                      (cons `(set! (,extra _copy_)
-                                                                  ,(case mode
+                                                                  ,(case (and (lookup 'counts? config #f)
+                                                                              mode)
                                                                      [(copy)
                                                                       `(cond
                                                                          [(== tf _) _copy_]
@@ -2565,9 +2566,8 @@
                                             (known-types (,type))
                                             (maybe-backreferences? ,count?)
                                             (counts? ,count?)))))])])
-         (sweep1 'record "sweep_record" '((rtd-relocated? #t)))
-         (sweep1 'record "sweep_dirty_record" '((rtd-relocated? #t)
-                                                (as-dirty? #t)))
+         (sweep1 'record "sweep_record" '())
+         (sweep1 'record "sweep_dirty_record" '((as-dirty? #t)))
          (sweep1 'symbol)
          (sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t)))
          (sweep1 'thread "sweep_thread" '((no-from-g? #t)))