tests/arenaheapwaste.impure.lisp

   1 #+(or interpreter (not system-tlabs) (not sb-thread))
   2 (invoke-restart 'run-tests::skip-file)
   3
   4 (setf (generation-number-of-gcs-before-promotion 0) 1000000)
   5
   6 (defun use-heap-and-arena ()
   7   (values (make-array 100)
   8           (sb-vm:without-arena "test"
   9             (make-array 100))))
  10
  11 (defvar *runflag* t)
  12 (defun worker (index arena semaphores)
  13   (declare (ignorable index))
  14   (loop
  15     (sb-thread:wait-on-semaphore (first semaphores))
  16     (unless *runflag* (return))
  17     (sb-vm:with-arena (arena)
  18       (dotimes (i 1000)
  19         (use-heap-and-arena)))
  20     (sb-thread:signal-semaphore (second semaphores))))
  21
  22 (defun try-wasting-heap (&optional (nthreads 4))
  23   (let* ((arena (sb-vm:new-arena (* 10 1024 1024)))
  24          (semaphores (list (sb-thread:make-semaphore)
  25                            (sb-thread:make-semaphore)))
  26          (threads
  27           (loop repeat 4
  28                 for i from 0
  29                 collect
  30                 (sb-thread:make-thread #'worker :arguments (list i arena semaphores))))
  31          (niter 500)
  32          (sum-fractional-waste 0))
  33     (dotimes (i niter)
  34       (sb-thread:signal-semaphore (first semaphores) nthreads)
  35       (sb-thread:wait-on-semaphore (second semaphores) :n nthreads)
  36       (let* ((used-bytes (generation-bytes-allocated 0))
  37              (consumed-bytes
  38               (* (alien-funcall (extern-alien "count_generation_pages"
  39                                               (function long char unsigned))
  40                                 0 0)
  41                  sb-vm:gencgc-page-bytes))
  42              (waste-bytes (- consumed-bytes used-bytes))
  43              (waste (/ waste-bytes consumed-bytes)))
  44         (incf sum-fractional-waste waste)
  45         #+nil (format t "~&waste: ~,,2f~%" waste))
  46       (sb-vm:rewind-arena arena))
  47     (setq *runflag* nil)
  48     (sb-thread:signal-semaphore (first semaphores) nthreads)
  49     (mapc 'sb-thread:join-thread threads)
  50     (/ sum-fractional-waste niter)))
  51
  52 (with-test (:name :waste-heap
  53                   ;; don't have count_generation_pages()
  54             :skipped-on (or :mark-region-gc :gc-stress))
  55   ;; Prior to the logic that picked up where we left off in the heap
  56   ;; it was easily demonstrated that the heap waste could rise to as much
  57   ;; as 70% before starting a GC.
  58   (let ((avg-frac-waste (try-wasting-heap)))
  59     (assert (< avg-frac-waste .05))))
  60
  61 (defvar *arena* (sb-vm:new-arena 10485760))
  62 (defun make-biga (a &optional (len 3000))
  63   (sb-vm:with-arena (a) (make-array (the integer len))))
  64 (compile 'make-biga)
  65 (defvar *biggy*)
  66 (loop (setq *biggy* (make-biga *arena* 2000000))
  67  (when (/= 0 (sb-vm::arena-huge-objects *arena*))
  68    (return)))
  69 (defvar *cons-address* 0)
  70 (sb-thread:join-thread
  71  (sb-thread:make-thread
  72   (lambda ()
  73     (let ((c (list "try" "this")))
  74       (setf (aref *biggy* 0) c)
  75       (setf *cons-address* (sb-kernel:get-lisp-obj-address c))))))
  76
  77 (gc :gen 2)
  78 (test-util:with-test (:name :huge-objects-scavenged-in-gc)
  79   (let ((cell (aref *biggy* 0)))
  80     #-mark-region-gc ; cons doesn't move
  81     (assert (/= (sb-kernel:get-lisp-obj-address cell) *cons-address*))
  82     (assert (string= (car cell) "try"))
  83     (assert (string= (cadr cell) "this")))
  84   (sb-vm:destroy-arena *arena*))