gc: generate sweep_dirty_object

The `sweep_dirty_intersecting` function still had hand-implemented
sweep cases.

original commit: c51b46b3cc71ed0dbc523071dce3cc496965e0b6

c/gc.c

@@ -48,7 +48,7 @@ static void sweep_code_object PROTO((ptr tc, ptr co));
 static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si));
 static void sweep_dirty PROTO((void));
 static IGEN sweep_dirty_intersecting PROTO((ptr lst, ptr *pp, ptr *ppend, IGEN tg, IGEN youngest));
-static IGEN sweep_dirty_bytes PROTO((ptr *pp, ptr *ppend, ptr *pu, ptr *puend, IGEN tg, IGEN youngest));
+static IGEN sweep_dirty_object PROTO((ptr p, IGEN tg, IGEN youngest));
 static void resweep_dirty_weak_pairs PROTO((void));
 static void add_pending_guardian PROTO((ptr gdn, ptr tconc));
 static void add_trigger_guardians_to_recheck PROTO((ptr ls));
@@ -1542,66 +1542,8 @@ IGEN sweep_dirty_intersecting(ptr lst, ptr *pp, ptr *ppend, IGEN tg, IGEN younge
 
     if (((pu >= pp) && (pu < ppend))
         || ((puend >= pp) && (puend < ppend))
-        || ((pu <= pp) && (puend >= ppend))) {
+        || ((pu <= pp) && (puend >= ppend)))
-      /* Overlaps, so sweep */
+      youngest = sweep_dirty_object(p, tg, youngest);
-      ITYPE t = TYPEBITS(p);
-
-      if (t == type_pair) {
-        youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-      } else if (t == type_closure) {
-        ptr code;
-
-        code = CLOSCODE(p);
-        if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
-          youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-        }
-      } else if (t == type_symbol) {
-        youngest = sweep_dirty_symbol(p, tg, youngest);
-      } else if (t == type_flonum) {
-        /* nothing to sweep */
-      } else {
-        ptr tf = TYPEFIELD(p);
-        if (TYPEP(tf, mask_vector, type_vector)
-            || TYPEP(tf, mask_stencil_vector, type_stencil_vector)
-            || TYPEP(tf, mask_box, type_box)
-            || ((iptr)tf == type_tlc)) {
-          /* impure objects */
-          youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-        } else if (TYPEP(tf, mask_string, type_string)
-                   || TYPEP(tf, mask_bytevector, type_bytevector)
-                   || TYPEP(tf, mask_fxvector, type_fxvector)) {
-          /* nothing to sweep */;
-        } else if (TYPEP(tf, mask_record, type_record)) {
-          youngest = sweep_dirty_record(p, tg, youngest);
-        } else if (((iptr)tf == type_ratnum)
-                   || ((iptr)tf == type_exactnum)
-                   || TYPEP(tf, mask_bignum, type_bignum)) {
-          /* immutable */
-        } else if (TYPEP(tf, mask_port, type_port)) {
-          youngest = sweep_dirty_port(p, tg, youngest);
-        } else if (TYPEP(tf, mask_code, type_code)) {
-          /* immutable */
-        } else if (((iptr)tf == type_rtd_counts)
-                   || ((iptr)tf == type_phantom)) {
-          /* nothing to sweep */;
-        } else {
-          S_error_abort("sweep_dirty_intersection(gc): unexpected type");
-        }
-      }
-    }
-  }
-
-  return youngest;
-}
-
-IGEN sweep_dirty_bytes(ptr *pp, ptr *ppend, ptr *pu, ptr *puend, IGEN tg, IGEN youngest)
-{
-  if (pu < pp) pu = pp;
-  if (puend > ppend) puend = ppend;
-
-  while (pu < puend) {
-    relocate_dirty(pu,tg,youngest)
-    pu += 1;
   }
 
   return youngest;

s/mkgc.ss

@@ -170,8 +170,9 @@
     (define code : ptr (CLOSCODE _))
     (trace-code-early code)
     (cond
-      [(or-assume-continuation
+      [(and-not-as-dirty
-        (& (code-type code) (<< code-flag-continuation code-flags-offset)))
+        (or-assume-continuation
+         (& (code-type code) (<< code-flag-continuation code-flags-offset))))
        ;; continuation
        (space (cond
                 [(and-counts (is_counting_root si _)) space-count-pure]
@@ -228,8 +229,10 @@
           (vfasl-fail "mutable closure")))
        (define len : uptr (code-closure-length code))
        (size (size_closure len))
-       (copy-clos-code code)
+       (when (or-not-as-dirty
-       (trace-ptrs closure-data len)
+              (& (code-type code) (<< code-flag-mutable-closure code-flags-offset)))
+         (copy-clos-code code)
+         (trace-ptrs closure-data len))
        (pad (when (== (& len 1) 0)
               (set! (closure-data _copy_ len) (FIX 0))))
        (count countof-closure)])]
@@ -414,8 +417,8 @@
       (vspace vspace_impure) ; would be better if we had pure, but these are rare
       (size size-ratnum)
       (copy-type ratnum-type)
-      (trace-now ratnum-numerator)
+      (trace-immutable-now ratnum-numerator)
-      (trace-now ratnum-denominator)
+      (trace-immutable-now ratnum-denominator)
       (vfasl-pad-word)
       (count countof-ratnum)]
 
@@ -424,8 +427,8 @@
       (vspace vspace_impure) ; same rationale as ratnum
       (size size-exactnum)
       (copy-type exactnum-type)
-      (trace-now exactnum-real)
+      (trace-immutable-now exactnum-real)
-      (trace-now exactnum-imag)
+      (trace-immutable-now exactnum-imag)
       (vfasl-pad-word)
       (count countof-exactnum)]
 
@@ -465,15 +468,16 @@
       (vspace vspace_code)
       (define len : uptr (code-length _)) ; in bytes
       (size (size_code len))
-      (copy-type code-type)
+      (when (and-not-as-dirty 1)
-      (copy code-length)
+       (copy-type code-type)
-      (copy code-reloc)
+       (copy code-length)
-      (trace-nonself code-name)
+       (copy code-reloc)
-      (trace-nonself code-arity-mask)
+       (trace-nonself code-name)
-      (copy code-closure-length)
+       (trace-nonself code-arity-mask)
-      (trace-nonself code-info)
+       (copy code-closure-length)
-      (trace-nonself code-pinfo*)
+       (trace-nonself code-info)
-      (trace-code len)
+       (trace-nonself code-pinfo*)
+       (trace-code len))
       (count countof-code)]
 
      [thread
@@ -486,7 +490,8 @@
        [self-test]
        [else
         (copy-type thread-type)
-        (trace-tc thread-tc)
+        (when (and-not-as-dirty 1)
+          (trace-tc thread-tc))
         (count countof-thread)])]
 
      [rtd-counts
@@ -569,6 +574,10 @@
     (add_ephemeron_to_pending_measure _)]
    [else]))
 
+(define-trace-macro (trace-immutable-now ref)
+  (when (and-not-as-dirty 1)
+    (trace-now ref)))
+
 (define-trace-macro (trace-code-early code)
   (unless-code-relocated
    (case-mode
@@ -1023,7 +1032,10 @@
 (define-trace-macro (unless-code-relocated stmt)
   (case-flag code-relocated?
    [on]
-   [off stmt]))
+   [off
+    (case-flag as-dirty?
+     [on]
+     [off stmt])]))
 
 (define-trace-macro (or-assume-continuation e)
   (case-flag assume-continuation?
@@ -1035,6 +1047,16 @@
    [on e]
    [off 0]))
 
+(define-trace-macro (and-not-as-dirty e)
+  (case-flag as-dirty?
+   [on 0]
+   [off e]))
+
+(define-trace-macro (or-not-as-dirty e)
+  (case-flag as-dirty?
+   [on e]
+   [off 1]))
+
 (define-trace-macro (or-vfasl e)
   (case-mode
    [vfasl-copy 1]
@@ -1228,7 +1250,8 @@
              name
              (case (lookup 'mode config)
                [(sweep)
-                (if (type-included? 'code config)
+                (if (and (type-included? 'code config)
+                         (not (lookup 'as-dirty? config #f)))
                     "ptr tc_in, "
                     "")]
                [(vfasl-copy vfasl-sweep)
@@ -1405,7 +1428,7 @@
                             off)])
               (statements (append body (cdr l)) config))]
            [`(trace-early-rtd ,field)
-            (code (case (and (not (lookup 'only-dirty? config #f))
+            (code (case (and (not (lookup 'as-dirty? config #f))
                              (not (lookup 'rtd-relocated? config #f))
                              (lookup 'mode config))
                     [(copy sweep)
@@ -2127,6 +2150,11 @@
                              `((mode sweep)
                                (maybe-backreferences? ,count?)
                                (counts? ,count?))))
+       (print-code (generate "sweep_dirty_object"
+                             `((mode sweep)
+                               (maybe-backreferences? ,count?)
+                               (counts? ,count?)
+                               (as-dirty? #t))))
        (letrec ([sweep1
                  (case-lambda
                   [(type) (sweep1 type (format "sweep_~a" type) '())]