fix leak related to object counts

When collecting to the maximum generation with object counts enabled,
a structure type would effectively become permanently reachable.

Also, add `bytes-finalized` to report how many bytes were associated
with guardian-based finalization by the most recent collection.

original commit: 852f5e2de95a26d3500321c4d4d732407945a57a

c/alloc.c

@@ -168,6 +168,10 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
   return Sunsigned(n);
 }
 
+ptr S_bytes_finalized() {
+  return Sunsigned(S_G.bytes_finalized);
+}
+
 static void maybe_fire_collector() {
   ISPC s;
   uptr bytes, fudge;

c/externs.h

@@ -64,6 +64,7 @@ extern void S_protect PROTO((ptr *p));
 extern void S_reset_scheme_stack PROTO((ptr tc, iptr n));
 extern void S_reset_allocation_pointer PROTO((ptr tc));
 extern ptr S_compute_bytes_allocated PROTO((ptr xg, ptr xs));
+extern ptr S_bytes_finalized PROTO(());
 extern ptr S_find_more_room PROTO((ISPC s, IGEN g, iptr n, ptr old));
 extern void S_dirty_set PROTO((ptr *loc, ptr x));
 extern void S_scan_dirty PROTO((ptr **p, ptr **endp));

c/gc.c

@@ -21,8 +21,6 @@
 #endif /* WIN32 */
 #include "popcount.h"
 
-#define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead
-
 /* locally defined functions */
 static uptr list_length PROTO((ptr ls));
 static ptr copy_list PROTO((ptr ls, IGEN tg));
@@ -66,6 +64,7 @@ static void sanitize_locked_segment PROTO((seginfo *si));
 #ifdef ENABLE_OBJECT_COUNTS
 static uptr total_size_so_far();
 #endif
+static uptr target_generation_space_so_far();
 
 #ifdef ENABLE_MEASURE
 static void init_measure(IGEN min_gen, IGEN max_gen);
@@ -360,6 +359,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     seginfo *oldspacesegments, *si, *nextsi;
     ptr ls, younger_locked_objects;
     bucket_pointer_list *buckets_to_rebuild;
+    uptr pre_finalization_size;
 #ifdef ENABLE_OBJECT_COUNTS
     ptr count_roots_counts = Snil;
     iptr count_roots_len;
@@ -633,6 +633,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
     sweep_generation(tc, tg);
 
+    pre_finalization_size = target_generation_space_so_far();
+
   /* handle guardians */
     {   ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls, maybe_final_ordered_ls;
         ptr obj, rep, tconc, next;
@@ -843,6 +845,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
         S_G.guardians[tg] = hold_ls;
     }
 
+    S_G.bytes_finalized = target_generation_space_so_far() - pre_finalization_size;
+
   /* handle weak pairs */
     resweep_dirty_weak_pairs();
     resweep_weak_pairs(tg);
@@ -898,8 +902,10 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
   /* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */
     { IGEN g; ptr ls, p, newls = tg == mcg ? Snil : S_G.rtds_with_counts[tg]; seginfo *si;
+      int count = 0;
       for (g = 0; g <= mcg; g += 1) {
         for (ls = S_G.rtds_with_counts[g], S_G.rtds_with_counts[g] = Snil; ls != Snil; ls = Scdr(ls)) {
+          count++;
           p = Scar(ls);
           si = SegInfo(ptr_get_segment(p));
           if (!(si->space & space_old) || locked(si, p)) {
@@ -1855,6 +1861,20 @@ static uptr total_size_so_far() {
 }
 #endif
 
+static uptr target_generation_space_so_far() {
+  IGEN g = target_generation;
+  ISPC s;
+  uptr sz = S_G.phantom_sizes[g];
+
+  for (s = 0; s <= max_real_space; s++) {
+    sz += S_G.bytes_of_space[s][g];
+    if (S_G.next_loc[s][g] != FIX(0))
+      sz += (char *)S_G.next_loc[s][g] - (char *)S_G.base_loc[s][g];
+  }
+
+  return sz;
+}
+
 /* **************************************** */
 
 #ifdef ENABLE_MEASURE

c/gcwrapper.c

@@ -411,8 +411,11 @@ ptr S_object_backreferences(void) {
  */
 void Scompact_heap() {
   ptr tc = get_thread_context();
+  IBOOL eoc = S_G.enable_object_counts;
   S_pants_down += 1;
+  S_G.enable_object_counts = 1;
   S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, Sfalse);
+  S_G.enable_object_counts = eoc;
   S_pants_down -= 1;
 }
 

c/globals.h

@@ -137,6 +137,7 @@ EXTERN struct S_G_struct {
     ptr gcbackreference[static_generation+1];
     uptr phantom_sizes[static_generation+1];
     IGEN prcgeneration;
+    uptr bytes_finalized;
 
   /* intern.c */
     iptr oblist_length;

c/prim.c

@@ -170,6 +170,7 @@ void S_prim_init() {
 
     Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
     Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
+    Sforeign_symbol("(cs)bytes_finalized", (void *)S_bytes_finalized);
     Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
     Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
     Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);

csug/system.stex

@@ -4829,6 +4829,18 @@ still in use or not, can be obtained by summing
 \scheme{(bytes-deallocated)} and \scheme{(bytes-allocated)}
 and possibly subtracting \scheme{(initial-bytes-allocated)}.
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{bytes-finalized}{\categoryprocedure}{(bytes-finalized)}
+\returns the number of bytes queued in guardians
+\listlibraries
+\endentryheader
+
+The number of bytes associated with objects that were registered in
+guardians as otherwise inaccessible (including the bytes for objects
+reachable only through registered objects) during the most recent
+garbage collection.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{current-memory-bytes}{\categoryprocedure}{(current-memory-bytes)}

makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.25
+Version=csv9.5.3.26
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

s/7.ss

@@ -86,6 +86,13 @@
       [(g) (ba (filter-generation g) -1)]
       [(g s) (ba (if g (filter-generation g) -1) (if s (filter-space s) -1))])))
 
+(define-who bytes-finalized
+  (let ([bf (foreign-procedure "(cs)bytes_finalized"
+              ()
+              scheme-object)])
+    (lambda ()
+      (bf))))
+
 (define $spaces (lambda () (map car (constant real-space-alist))))
 
 (define current-memory-bytes (foreign-procedure "(cs)curmembytes" () uptr))

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050319)
+(define-constant scheme-version #x0905031A)
 
 (define-syntax define-machine-types
   (lambda (x)

s/mkgc.ss

@@ -746,37 +746,38 @@
    [copy
     (case-flag counts?
      [on
-      (let* ([c_rtd : ptr (cond
+      (when S_G.enable_object_counts
-                            [(== _tf_ _) _copy_]
+        (let* ([c_rtd : ptr (cond
-                            [else rtd])]
+                              [(== _tf_ _) _copy_]
-             [counts : ptr (record-type-counts c_rtd)])
+                              [else rtd])]
-        (cond
+               [counts : ptr (record-type-counts c_rtd)])
-          [(== counts Sfalse)
+          (cond
-           (let* ([grtd : IGEN (GENERATION c_rtd)])
+            [(== counts Sfalse)
-             (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1)
+             (let* ([grtd : IGEN (GENERATION c_rtd)])
-             ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts.
+               (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1)
-             (find_room space_data grtd type_typed_object size_rtd_counts counts)
+               ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts.
-             (set! (rtd-counts-type counts) type_rtd_counts)
+               (find_room space_data grtd type_typed_object size_rtd_counts counts)
-             (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
+               (set! (rtd-counts-type counts) type_rtd_counts)
-             (let* ([g : IGEN 0])
+               (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
-               (while
+               (let* ([g : IGEN 0])
-                :? (<= g static_generation)
+                 (while
-                (set! (rtd-counts-data counts g) 0)
+                  :? (<= g static_generation)
-                (set! g += 1)))
+                  (set! (rtd-counts-data counts g) 0)
+                  (set! g += 1)))
+               (set! (record-type-counts c_rtd) counts)
+               (set! (array-ref S_G.rtds_with_counts grtd)
+                     ;; this list will get copied again in `rtds_with_counts` fixup
+                     (S_cons_in space_new 0 c_rtd (array-ref S_G.rtds_with_counts grtd)))
+               (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
+            [else
+             (trace-early (just counts))
              (set! (record-type-counts c_rtd) counts)
-             (set! (array-ref S_G.rtds_with_counts grtd)
+             (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
-                   (S_cons_in (cond [(== grtd 0) space_new] [else space_impure]) grtd c_rtd
+               (S_fixup_counts counts))])
-                              (array-ref S_G.rtds_with_counts grtd)))
+          (set! (rtd-counts-data counts tg) (+ (rtd-counts-data counts tg) 1))))
-             (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
+      ;; Copies size that we may have already gathered, but needed for counting from roots:
-          [else
+      (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz))
-           (trace-early (just counts))
+      (count countof-record)]
-           (set! (record-type-counts c_rtd) counts)
-           (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
-             (S_fixup_counts counts))])
-        (set! (rtd-counts-data counts tg) (+ (rtd-counts-data counts tg) 1))
-        ;; Copies size that we've already gathered, but needed for counting from roots:
-        (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz))
-        (count countof-record))]
      [off])]
    [else]))
 

s/primdata.ss

@@ -1165,6 +1165,7 @@
   (bwp-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (bytes-allocated [sig [() -> (uint)] [(ptr) -> (uint)] [(ptr maybe-sub-symbol) -> (uint)]] [flags alloc])
   (bytes-deallocated [sig [() -> (uint)]] [flags unrestricted alloc])
+  (bytes-finalized [sig [() -> (uint)]] [flags unrestricted alloc])
   (bytevector [sig [(u8/s8 ...) -> (bytevector)]] [flags alloc cp02])
   (bytevector->s8-list [sig [(bytevector) -> (list)]] [flags alloc])
   (bytevector-truncate! [sig [(bytevector length) -> (bytevector)]] [flags true])