Fix problem reported by stassats on sbcl-devel

NEWS

@@ -4,6 +4,7 @@ changes relative to sbcl-1.4.2:
   * bug fix: DECODE-TIMEOUT and operators accepting a timeout no longer signal
     an error when called with an argument that is of type (real 0) but not
     (unsigned-byte 62) (lp#1727789)
+  * bug fix: fixed heap exhaustion bug when consing millions of small objects
 
 changes in sbcl-1.4.2 relative to sbcl-1.4.1:
   * minor incompatible change: SB-EXT:QUIT is no longer marked as deprecated

src/runtime/gencgc.c

@@ -1936,7 +1936,6 @@ wipe_nonpinned_words()
     // Prime the loop
     uword_t fill_from = page_base(pinned_objects.keys[0]);
     os_vm_size_t bytes_moved = 0; // i.e. virtually moved
-    os_vm_size_t bytes_freed = 0; // bytes after last pinned object per page
 
     for (i = 0; i < n_pins; ++i) {
         lispobj* obj = (lispobj*)pinned_objects.keys[i];
@@ -2001,18 +2000,18 @@ wipe_nonpinned_words()
             long nbytes = page_end - (uword_t)obj_end;
             gc_assert(nbytes >= 0);
             if (nbytes) {
-                // Bytes beyond a page's highest used byte must be zero.
+                // Zero the page filler. (Important if it's a cons)
                 memset(obj_end, 0, nbytes);
-                bytes_freed += nbytes;
-                set_page_bytes_used(end_page_index,
-                                    (uword_t)obj_end - obj_end_pageaddr);
+                if (nbytes > 2*N_WORD_BYTES) {
+                    obj_end[0] = SIMPLE_ARRAY_WORD_WIDETAG;
+                    obj_end[1] = make_fixnum(nbytes/N_WORD_BYTES - 2);
+                }
             }
             fill_from = page_base(pinned_objects.keys[i+1]);
         }
     }
     generations[from_space].bytes_allocated -= bytes_moved;
-    generations[new_space].bytes_allocated += bytes_moved - bytes_freed;
-    bytes_allocated -= bytes_freed;
+    generations[new_space].bytes_allocated += bytes_moved;
 #undef adjust_gen_usage
 #undef page_base
 }

tests/gc.impure.lisp

@@ -214,3 +214,22 @@
                 (+ sb-vm:fixedobj-space-start
                    sb-vm:fixedobj-space-size
                    sb-vm:varyobj-space-size)))))
+
+;;; After each iteration of FOO there are a few pinned conses.
+;;; On alternate GC cycles, those get promoted to generation 1.
+;;; When the logic for page-spanning-object zeroing incorrectly decreased
+;;; the upper bound on bytes used for partially pinned pages, it caused
+;;; an accumulation of pages in generation 1 each with 2 objects' worth
+;;; of bytes, and the remainder waste. Because the waste was not accounted
+;;; for, it did not trigger GC enough to avoid heap exhaustion.
+(with-test (:name :smallobj-auto-gc-trigger)
+  ;; Ensure that these are compiled functions because the interpreter
+  ;; would make lots of objects of various sizes which is insufficient
+  ;; to provoke the bug.
+  (setf (symbol-function 'foo)
+        (compile nil '(lambda () (list 1 2))))
+  ;; 500 million iterations of this loop seems to be reliable enough
+  ;; to show that GC happens.
+  (setf (symbol-function 'callfoo)
+        (compile nil '(lambda () (loop repeat 500000000 do (foo)))))
+  (funcall 'callfoo))