cs: correct and imprrove heuristics for force a major GC

Use `current-memory-bytes` instead of `bytes-allocated` to determine
major GCs, because the latter doesn't include enough (perhaps missing
finalized values). For example, the repair avoids unbounded memory use
from

  (let loop ([i 0])
    (malloc 6400 'atomic-interior)
    (loop))

due to finalizers that pile up faster than they are run.

pkgs/racket-test-core/tests/racket/number.rktl

@@ -2691,6 +2691,10 @@
                               (apply append (for/list ([i 10000])
                                               (random-sample (range 10) 100)))))))
 
+(parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)])
+  (random-seed 2)
+  (test '#(1062645402 3593208522 3838676319 2291995347 179540564 3081399108)
+        pseudo-random-generator->vector (current-pseudo-random-generator)))
 
 (test #t = 0 0)
 (test #f = 0 (expt 2 32))

racket/src/cs/rumble/foreign.ss

@@ -1402,7 +1402,7 @@
     (let* ([bstr (make-bytevector size 0)]
            [p (make-cpointer bstr #f)])
       (lock-object bstr)
-      (with-global-lock (the-foreign-guardian p (lambda () (unlock-object bstr))))
+      (unsafe-add-global-finalizer p (lambda () (unlock-object bstr)))
       p)]
    [else
     (raise-unsupported-error 'malloc
@@ -1464,7 +1464,7 @@
       (poll-foreign-guardian))))
 
 (define (unsafe-add-global-finalizer v proc)
-  (the-foreign-guardian v proc))
+  (with-global-lock (the-foreign-guardian v proc)))
 
 ;; ----------------------------------------
 
@@ -1973,7 +1973,7 @@
         (let* ([code (make-code proc)]
                [cb (create-callback code)])
           (lock-object code)
-          (with-global-lock (the-foreign-guardian cb (lambda () (unlock-object code))))
+          (unsafe-add-global-finalizer cb (lambda () (unlock-object code)))
           cb)))]))
 
 ;; ----------------------------------------

racket/src/cs/rumble/memory.ss

@@ -34,7 +34,8 @@
 (define gc-counter 1)
 (define log-collect-generation-radix 2)
 (define collect-generation-radix-mask (sub1 (bitwise-arithmetic-shift 1 log-collect-generation-radix)))
-(define allocated-after-major (* 32 1024 1024))
+(define allocated+overhead-after-major (* 32 1024 1024))
+(define non-full-gc-counter 0)
 
 ;; Called in any thread with all other threads paused. The Racket
 ;; thread scheduler may be in atomic mode. In fact, the engine
@@ -51,7 +52,8 @@
         (set! gc-counter (add1 this-counter)))
     (let ([gen (cond
                 [(and (not g)
-                      (>= pre-allocated (* 2 allocated-after-major)))
+                      (or (>= pre-allocated+overhead (* 2 allocated+overhead-after-major))
+                          (>= non-full-gc-counter 10000)))
                  ;; Force a major collection if memory use has doubled
                  (collect-maximum-generation)]
                 [else
@@ -63,12 +65,13 @@
                     [else gen]))])])
       (run-collect-callbacks car)
       (collect gen)
-      (let ([post-allocated (bytes-allocated)])
+      (let ([post-allocated (bytes-allocated)]
+            [post-allocated+overhead (current-memory-bytes)])
         (when (= gen (collect-maximum-generation))
-          (set! allocated-after-major post-allocated))
+          (set! allocated+overhead-after-major post-allocated+overhead))
         (garbage-collect-notify gen
                                 pre-allocated pre-allocated+overhead pre-time pre-cpu-time
-                                post-allocated  (current-memory-bytes) (real-time) (cpu-time)))
+                                post-allocated  post-allocated+overhead (real-time) (cpu-time)))
       (update-eq-hash-code-table-size!)
       (poll-foreign-guardian)
       (run-collect-callbacks cdr)
@@ -80,6 +83,11 @@
         ;; This `set-timer` doesn't necessarily penalize the right thread,
         ;; but it's likely to penalize a thread that is allocating quickly:
         (set-timer 1))
+      (cond
+       [(= gen (collect-maximum-generation))
+        (set! non-full-gc-counter 0)]
+       [else
+        (set! non-full-gc-counter (add1 non-full-gc-counter))])
       (void))))
 
 (define collect-garbage
@@ -349,7 +357,7 @@
 (define/who (make-phantom-bytes k)
   (check who exact-nonnegative-integer? k)
   (let ([ph (create-phantom-bytes (make-phantom-bytevector k))])
-    (when (>= (bytes-allocated) (* 2 allocated-after-major))
+    (when (>= (current-memory-bytes) (* 2 allocated+overhead-after-major))
       (collect-garbage))
     ph))