mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Improve allocator histogram
- A silly reason prevented the histogram and precise cons-profiling to both be enabled: there was a JRCX with an out-of-range branch target. - Distinguish between "allocator histogram" and "allocator metrics" because the former says something about user code that would likely hold regardless of the garbage collector implementation, whereas the latter measures aspects of gencgc such as the time taken to find free memory. - Count the sum of bytes allocated for the inexact (power-of-2) bins. - Instrumentation for the histogram is more amenable to inserting into all of the backends than is the code for the precise profiler, though at present it is still only implemented on x86-64. It is also a little easier to control in a build script, as it requires only a change to *features* rather than a compiler policy.
This commit is contained in:
Douglas Katzman
parent
e06a846894
commit
de5809667a
|
|
@ -72,7 +72,7 @@
|
|||
;; I would argue that this should not be exposed,
|
||||
;; but I would also anticipate blowback from removing it.
|
||||
:CHENEYGC :GENCGC ; GC: pick one and only one
|
||||
:ARENA-ALLOCATOR
|
||||
:ARENA-ALLOCATOR :ALLOCATION-SIZE-HISTOGRAM
|
||||
;; Can't use s-l-a-d :compression safely without it
|
||||
:SB-CORE-COMPRESSION
|
||||
;; Features that are also in *FEATURES-POTENTIALLY-AFFECTING-FASL-FORMAT*
|
||||
|
|
|
|||
|
|
@ -278,21 +278,23 @@ an error in that case."
|
|||
;; indicating that you observed a value of %OWNER which no longer exists.
|
||||
(t :thread-dead)))
|
||||
|
||||
(defun list-all-threads ()
|
||||
"Return a list of the live threads. Note that the return value is
|
||||
potentially stale even before the function returns, as new threads may be
|
||||
created and old ones may exit at any time."
|
||||
(defun %list-all-threads ()
|
||||
;; No lock needed, just an atomic read, since tree mutations can't happen.
|
||||
;; Of course by the time we're done collecting nodes, the tree can have
|
||||
;; been replaced by a different tree.
|
||||
(barrier (:read))
|
||||
(avltree-filter (lambda (node)
|
||||
(let ((thread (avlnode-data node)))
|
||||
(when (and (= (thread-%visible thread) 1)
|
||||
(neq thread sb-impl::*finalizer-thread*))
|
||||
(when (= (thread-%visible thread) 1)
|
||||
thread)))
|
||||
*all-threads*))
|
||||
|
||||
(defun list-all-threads ()
|
||||
"Return a list of the live threads. Note that the return value is
|
||||
potentially stale even before the function returns, as new threads may be
|
||||
created and old ones may exit at any time."
|
||||
(delete sb-impl::*finalizer-thread* (%list-all-threads)))
|
||||
|
||||
;;; used by debug-int.lisp to access interrupt contexts
|
||||
|
||||
(sb-ext:define-load-time-global *initial-thread* nil)
|
||||
|
|
@ -2595,9 +2597,9 @@ mechanism for inter-thread communication."
|
|||
#-sb-thread (ash thread-obj-len sb-vm:word-shift)
|
||||
by sb-vm:n-word-bytes
|
||||
do
|
||||
(unless (<= sb-vm::thread-obj-size-histo-slot
|
||||
(unless (<= sb-vm::thread-allocator-histogram-slot
|
||||
(ash tlsindex (- sb-vm:word-shift))
|
||||
(+ sb-vm::thread-obj-size-histo-slot (1- sb-vm:n-word-bits)))
|
||||
(1- sb-vm::thread-lisp-thread-slot))
|
||||
(let ((thread-slot-name
|
||||
(if (< tlsindex (ash thread-obj-len sb-vm:word-shift))
|
||||
(aref names (ash tlsindex (- sb-vm:word-shift))))))
|
||||
|
|
@ -2619,78 +2621,94 @@ mechanism for inter-thread communication."
|
|||
(show sym val))
|
||||
(setq from (sap+ from (* sb-vm:binding-size sb-vm:n-word-bytes))))))))
|
||||
|
||||
#+allocator-metrics
|
||||
(macrolet ((histogram-value (c-thread index)
|
||||
`(sap-ref-word (int-sap ,c-thread)
|
||||
(ash (+ sb-vm::thread-obj-size-histo-slot ,index)
|
||||
(ash (+ sb-vm::thread-allocator-histogram-slot ,index)
|
||||
sb-vm:word-shift)))
|
||||
(metric (c-thread slot)
|
||||
`(sap-ref-word (int-sap ,c-thread)
|
||||
(ash ,slot sb-vm:word-shift))))
|
||||
(export '(print-allocator-histogram reset-allocator-histogram))
|
||||
(ash ,slot sb-vm:word-shift)))
|
||||
(histogram-array-length ()
|
||||
(+ sb-vm::n-histogram-bins-small
|
||||
(* 2 sb-vm::n-histogram-bins-large))))
|
||||
|
||||
(export '(allocator-histogram print-allocator-histogram reset-allocator-histogram))
|
||||
(defun allocator-histogram (&optional (thread *current-thread*))
|
||||
(if (eq thread :all)
|
||||
(labels ((vector-sum (a b)
|
||||
(let ((result (make-array (max (length a) (length b))
|
||||
:element-type 'fixnum)))
|
||||
(let ((result (make-array (length a) :element-type 'fixnum)))
|
||||
(dotimes (i (length result) result)
|
||||
(setf (aref result i)
|
||||
(+ (if (< i (length a)) (aref a i) 0)
|
||||
(if (< i (length b)) (aref b i) 0))))))
|
||||
(setf (aref result i) (+ (aref a i) (aref b i))))))
|
||||
(sum (a b)
|
||||
(cond ((null a) b)
|
||||
((null b) a)
|
||||
(t (cons (vector-sum (car a) (car b))
|
||||
(mapcar #'+ (cdr a) (cdr b)))))))
|
||||
(reduce #'sum
|
||||
;; what about the finalizer thread?
|
||||
(mapcar 'allocator-histogram (list-all-threads))))
|
||||
(list (vector-sum (first a) (first b)) ; bin counts
|
||||
(vector-sum (second a) (second b)) ; nbytes in large bins
|
||||
(+ (third a) (third b)) ; unboxed total
|
||||
(+ (fourth a) (fourth b))))) ; boxed total
|
||||
;; can get a NIL if a thread exited by the time we got to asking for its data
|
||||
(reduce #'sum (delete nil
|
||||
(mapcar 'allocator-histogram (%list-all-threads)))))
|
||||
(with-deathlok (thread c-thread)
|
||||
(unless (= c-thread 0)
|
||||
(dx-let ((a (make-array (+ sb-vm::histogram-small-bins sb-vm:n-word-bits)
|
||||
:element-type 'fixnum)))
|
||||
(let ((a (make-array (histogram-array-length) :element-type 'fixnum))
|
||||
(boxed (metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot))
|
||||
(unboxed (metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot)))
|
||||
(declare (truly-dynamic-extent a))
|
||||
(dotimes (i (length a))
|
||||
(setf (aref a i) (histogram-value c-thread i)))
|
||||
(list (subseq a 0 (1+ (or (position 0 a :from-end t :test #'/=) -1)))
|
||||
(metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot)
|
||||
(metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot)
|
||||
(metric c-thread sb-vm::thread-slow-path-allocs-slot)
|
||||
(metric c-thread sb-vm::thread-et-allocator-mutex-acq-slot)
|
||||
(metric c-thread sb-vm::thread-et-find-freeish-page-slot)
|
||||
(metric c-thread sb-vm::thread-et-bzeroing-slot)))))))
|
||||
(list (subseq a 0 (+ sb-vm::n-histogram-bins-small
|
||||
sb-vm::n-histogram-bins-large))
|
||||
(subseq a (+ sb-vm::n-histogram-bins-small
|
||||
sb-vm::n-histogram-bins-large))
|
||||
unboxed
|
||||
boxed))))))
|
||||
|
||||
(defun reset-allocator-histogram (&optional (thread *current-thread*))
|
||||
(with-deathlok (thread c-thread)
|
||||
(unless (= c-thread 0)
|
||||
(setf (metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot) 0
|
||||
(metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot) 0
|
||||
(metric c-thread sb-vm::thread-slow-path-allocs-slot) 0)
|
||||
(dotimes (i (+ sb-vm::histogram-small-bins sb-vm:n-word-bits))
|
||||
(setf (histogram-value c-thread i) 0)))))
|
||||
(if (eq thread :all)
|
||||
(mapc #'reset-allocator-histogram (%list-all-threads))
|
||||
(with-deathlok (thread c-thread)
|
||||
(unless (= c-thread 0)
|
||||
(setf (metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot) 0
|
||||
(metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot) 0
|
||||
(metric c-thread sb-vm::thread-slow-path-allocs-slot) 0)
|
||||
(dotimes (i (histogram-array-length))
|
||||
(setf (histogram-value c-thread i) 0)))))))
|
||||
|
||||
(defun print-allocator-histogram (&optional (thread *current-thread*))
|
||||
(destructuring-bind (bins tot-bytes-boxed tot-bytes-unboxed n-slow-path lock find clear)
|
||||
(allocator-histogram thread)
|
||||
(let ((total-objects (reduce #'+ bins))
|
||||
(cumulative 0))
|
||||
(format t "~& Size Count Cum%~%")
|
||||
(loop for index from 0
|
||||
for count across bins
|
||||
for size-exact-p = (< index sb-vm::histogram-small-bins)
|
||||
for size = (if size-exact-p
|
||||
(* (1+ index) 2 sb-vm:n-word-bytes)
|
||||
(ash 1 (+ (- index sb-vm::histogram-small-bins) 10)))
|
||||
do
|
||||
(incf cumulative count)
|
||||
(format t "~& ~10@a : ~8d ~6,2,2f~%"
|
||||
(cond (size-exact-p size)
|
||||
((< size 1048576) (format nil "< ~d" size))
|
||||
(t (format nil "< 2^~d" (1- (integer-length size)))))
|
||||
count (/ cumulative total-objects))
|
||||
(setq size (* size 2)))
|
||||
(when (plusp total-objects)
|
||||
(format t "Total: ~D+~D bytes, ~D objects, ~,2,2f% fast path~%"
|
||||
tot-bytes-boxed tot-bytes-unboxed total-objects
|
||||
(/ (- total-objects n-slow-path) total-objects)))
|
||||
(format t "Times (sec): lock=~,,-9f find=~,,-9f clear=~,,-9f~%"
|
||||
lock find clear)))))
|
||||
(defun print-allocator-histogram (&optional (thread-or-values *current-thread*))
|
||||
(destructuring-bind (counts large-allocated tot-bytes-unboxed tot-bytes-boxed)
|
||||
(if (listp thread-or-values)
|
||||
thread-or-values ; histogram was already gathered, just print it
|
||||
(allocator-histogram thread-or-values))
|
||||
(let* ((tot-bins (length counts))
|
||||
(tot-objects (reduce #'+ counts))
|
||||
(bin-label (make-array tot-bins))
|
||||
(bin-nbytes (make-array tot-bins))
|
||||
(cumulative 0))
|
||||
(dotimes (i sb-vm::n-histogram-bins-small)
|
||||
(setf (aref bin-label i) (* (1+ i) sb-vm:cons-size sb-vm:n-word-bytes)
|
||||
(aref bin-nbytes i) (* (aref counts i) (aref bin-label i))))
|
||||
(dotimes (i sb-vm::n-histogram-bins-small)
|
||||
(let ((bin-index (+ sb-vm::n-histogram-bins-small i))
|
||||
(size-max (ash 1 (+ i sb-vm::first-large-histogram-bin-log2size)))
|
||||
(allocated (aref large-allocated i)))
|
||||
(setf (aref bin-label bin-index)
|
||||
(if (< size-max 1048576)
|
||||
(format nil "< ~d" size-max)
|
||||
(format nil "< 2^~d" (1- (integer-length size-max))))
|
||||
(aref bin-nbytes bin-index) allocated)))
|
||||
(format t "~& Bin Size Allocated Count Cum%~%")
|
||||
(dotimes (i tot-bins)
|
||||
(let ((count (aref counts i)))
|
||||
(incf cumulative count)
|
||||
(format t "~& ~2d ~10@a ~13d ~9d ~7,2,2f~%"
|
||||
i
|
||||
(aref bin-label i)
|
||||
(aref bin-nbytes i)
|
||||
count
|
||||
(when (plusp tot-objects) (/ cumulative tot-objects)))))
|
||||
(let ((tot-bytes (+ tot-bytes-unboxed tot-bytes-boxed)))
|
||||
(format t "~& Tot ~23d ~9d~%" tot-bytes tot-objects)
|
||||
(when (plusp tot-bytes)
|
||||
(format t "; ~D unboxed + ~D boxed bytes (~,1,2F% + ~,1,2F%)~%"
|
||||
tot-bytes-unboxed tot-bytes-boxed
|
||||
(/ tot-bytes-unboxed tot-bytes)
|
||||
(/ tot-bytes-boxed tot-bytes)))))))
|
||||
|
|
|
|||
|
|
@ -499,7 +499,16 @@ during backtrace.
|
|||
(assign-header-slot-indices))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defconstant histogram-small-bins 32)) ; for consing size histogram
|
||||
;; allocator histogram capacity
|
||||
(defconstant n-histogram-bins-small 32)
|
||||
(defconstant n-histogram-bins-large 32))
|
||||
;;; the #+allocation-size-histogram has an exact count of objects allocated
|
||||
;;; for all sizes up to (* cons-size n-word-bytes n-histogram-bins-small).
|
||||
;;; Larger allocations are grouped by the binary log of the size.
|
||||
;;; It seems that 99.5% of all allocations are less than the small bucket limit,
|
||||
;;; making the histogram exact except for the tail.
|
||||
(defconstant first-large-histogram-bin-log2size
|
||||
(integer-length (* n-histogram-bins-small cons-size n-word-bytes)))
|
||||
|
||||
;;; this isn't actually a lisp object at all, it's a c structure that lives
|
||||
;;; in c-land. However, we need sight of so many parts of it from Lisp that
|
||||
|
|
@ -610,8 +619,11 @@ during backtrace.
|
|||
(et-allocator-mutex-acq) ; elapsed times
|
||||
(et-find-freeish-page)
|
||||
(et-bzeroing)
|
||||
(obj-size-histo :c-type "size_histogram"
|
||||
:length #.(+ histogram-small-bins n-word-bits))
|
||||
(allocator-histogram :c-type "size_histogram"
|
||||
;; small bins store just a count
|
||||
;; large bins store a count and size
|
||||
:length #.(+ (* 2 n-histogram-bins-large)
|
||||
n-histogram-bins-small))
|
||||
|
||||
;; The *current-thread* MUST be the last slot in the C thread structure.
|
||||
;; It it the only slot that needs to be noticed by the garbage collector.
|
||||
|
|
|
|||
|
|
@ -52,17 +52,6 @@
|
|||
(aver (= thread-tot-bytes-alloc-unboxed-slot
|
||||
(1+ thread-tot-bytes-alloc-boxed-slot))))
|
||||
|
||||
;;; the #+allocator metrics histogram contains an exact count
|
||||
;;; for all sizes up to (* cons-size n-word-bytes histogram-small-bins).
|
||||
;;; Larger allocations are grouped by the binary log of the size.
|
||||
;;; It seems that 99.5% of all allocations are less than the small bucket limit,
|
||||
;;; making the histogram fairly exact except for the tail.
|
||||
(defparameter *consing-histo* nil)
|
||||
(defconstant non-small-bucket-offset
|
||||
(+ histogram-small-bins
|
||||
(- (integer-length (* sb-vm::histogram-small-bins
|
||||
sb-vm:cons-size sb-vm:n-word-bytes)))))
|
||||
|
||||
;;; Emit counter increments for SB-APROF. SCRATCH-REGISTERS is either a TN
|
||||
;;; or list of TNs that can be used to store into the profiling data.
|
||||
;;; We pick one of the available TNs to use for addressing the data buffer.
|
||||
|
|
@ -85,51 +74,66 @@
|
|||
;; so we may as well take advantage of this fact to load the temp reg
|
||||
;; here, if provided, rather than spewing more #+gs-seg tests around.
|
||||
#+gs-seg (when thread-temp (inst rdgsbase thread-temp))
|
||||
#+allocator-metrics
|
||||
(let ((use-size-temp (not (typep size '(or (signed-byte 32) tn))))
|
||||
(tally (gen-label))
|
||||
(inexact (gen-label)))
|
||||
(cond ((tn-p type) ; from ALLOCATE-VECTOR-ON-HEAP
|
||||
;; Constant huge size + unknown type can't occur.
|
||||
(aver (not use-size-temp))
|
||||
(inst cmp :byte type simple-vector-widetag)
|
||||
(inst set :ne temp)
|
||||
(inst and :dword temp 1)
|
||||
(inst add :qword
|
||||
(ea thread-segment-reg
|
||||
(ash thread-tot-bytes-alloc-boxed-slot word-shift)
|
||||
thread-tn temp 8)
|
||||
size))
|
||||
(t
|
||||
(inst add :qword
|
||||
(thread-slot-ea (if (alloc-unboxed-p type)
|
||||
thread-tot-bytes-alloc-unboxed-slot
|
||||
thread-tot-bytes-alloc-boxed-slot))
|
||||
(cond (use-size-temp (inst mov temp size) temp)
|
||||
(t size)))))
|
||||
(cond ((tn-p size)
|
||||
(inst cmp size (* histogram-small-bins 16))
|
||||
(inst jmp :g inexact)
|
||||
(inst mov :dword temp size)
|
||||
(inst shr :dword temp (1+ word-shift))
|
||||
(inst dec :dword temp)
|
||||
(inst jmp tally)
|
||||
(emit-label inexact)
|
||||
(inst bsr temp size)
|
||||
;; bsr returns 1 less than INTEGER-LENGTH
|
||||
(inst add :dword temp (1+ non-small-bucket-offset))
|
||||
(emit-label tally)
|
||||
(inst inc :qword (ea thread-segment-reg
|
||||
(ash thread-obj-size-histo-slot word-shift)
|
||||
thread-tn temp 8)))
|
||||
(t
|
||||
(let* ((n-conses (/ size (* sb-vm:cons-size sb-vm:n-word-bytes)))
|
||||
(bucket (if (<= n-conses histogram-small-bins)
|
||||
(1- n-conses)
|
||||
(+ (integer-length size)
|
||||
non-small-bucket-offset))))
|
||||
(inst inc :qword
|
||||
(thread-slot-ea (+ thread-obj-size-histo-slot bucket)))))))
|
||||
(when (member :allocation-size-histogram sb-xc:*features*)
|
||||
(let ((use-size-temp (not (typep size '(or (signed-byte 32) tn)))))
|
||||
;; Sum up the sizes of boxed vs unboxed allocations.
|
||||
(cond ((tn-p type) ; from ALLOCATE-VECTOR-ON-HEAP
|
||||
;; Constant huge size + unknown type can't occur.
|
||||
(aver (not use-size-temp))
|
||||
(inst cmp :byte type simple-vector-widetag)
|
||||
(inst set :ne temp)
|
||||
(inst and :dword temp 1)
|
||||
(inst add :qword
|
||||
(ea thread-segment-reg
|
||||
(ash thread-tot-bytes-alloc-boxed-slot word-shift)
|
||||
thread-tn temp 8)
|
||||
size))
|
||||
(t
|
||||
(inst add :qword
|
||||
(thread-slot-ea (if (alloc-unboxed-p type)
|
||||
thread-tot-bytes-alloc-unboxed-slot
|
||||
thread-tot-bytes-alloc-boxed-slot))
|
||||
(cond (use-size-temp (inst mov temp size) temp)
|
||||
(t size)))))
|
||||
(cond ((tn-p size)
|
||||
(assemble ()
|
||||
;; optimistically assume it's a small object, so just divide
|
||||
;; the size by the size of a cons to get a (1-based) index.
|
||||
(inst mov :dword temp size)
|
||||
(inst shr :dword temp (1+ word-shift))
|
||||
;; now see if the computed index is in range
|
||||
(inst cmp size (* n-histogram-bins-small 16))
|
||||
(inst jmp :le OK)
|
||||
;; oversized. Compute the log2 of the size
|
||||
(inst bsr :dword temp size)
|
||||
;; array of counts ... | array of sizes ...
|
||||
(inst add :qword (ea (ash (+ thread-allocator-histogram-slot
|
||||
1
|
||||
(- first-large-histogram-bin-log2size)
|
||||
n-histogram-bins-small
|
||||
n-histogram-bins-large)
|
||||
word-shift)
|
||||
thread-tn temp 8)
|
||||
size)
|
||||
;; not sure why this is "2" and not "1" in the fudge factor!!
|
||||
;; (but the assertions come out right)
|
||||
(inst add :dword temp
|
||||
(+ (- first-large-histogram-bin-log2size) n-histogram-bins-small 2))
|
||||
OK
|
||||
(inst inc :qword (ea thread-segment-reg
|
||||
(ash (1- thread-allocator-histogram-slot) word-shift)
|
||||
thread-tn temp 8))))
|
||||
((<= size (* sb-vm:cons-size sb-vm:n-word-bytes n-histogram-bins-small))
|
||||
(let ((index (1- (/ size (* sb-vm:cons-size sb-vm:n-word-bytes)))))
|
||||
(inst inc :qword (thread-slot-ea (+ thread-allocator-histogram-slot index)))))
|
||||
(t
|
||||
(let ((index (- (integer-length size) first-large-histogram-bin-log2size)))
|
||||
(inst add :qword (thread-slot-ea (+ thread-allocator-histogram-slot
|
||||
n-histogram-bins-small
|
||||
n-histogram-bins-large index))
|
||||
size)
|
||||
(inst inc :qword (thread-slot-ea (+ thread-allocator-histogram-slot
|
||||
n-histogram-bins-small index))))))))
|
||||
(when (policy node (> sb-c::instrument-consing 1))
|
||||
(when (tn-p size)
|
||||
(aver (not (location= size temp))))
|
||||
|
|
|
|||
|
|
@ -1293,7 +1293,11 @@
|
|||
(inst lea :dword rcx (ea nil count (ash 1 shift)))))
|
||||
;; Setup for the CDR of the last cons (or the entire result) being NIL.
|
||||
(inst mov result nil-value)
|
||||
(inst jrcxz DONE)
|
||||
(cond ((not (member :allocation-size-histogram sb-xc:*features*))
|
||||
(inst jrcxz DONE))
|
||||
(t ; jumps too far for JRCXZ sometimes
|
||||
(inst test rcx rcx)
|
||||
(inst jmp :z done)))
|
||||
(unless (node-stack-allocate-p node)
|
||||
(instrument-alloc +cons-primtype+ rcx node (list value dst) thread-tn))
|
||||
(pseudo-atomic (:elide-if (node-stack-allocate-p node) :thread-tn thread-tn)
|
||||
|
|
|
|||
|
|
@ -28,8 +28,9 @@ struct thread_state_word {
|
|||
#endif
|
||||
};
|
||||
|
||||
// (DEFCONSTANT +N-SMALL-BUCKETS+ 32)
|
||||
typedef lispobj size_histogram[32+N_WORD_BITS];
|
||||
#define N_HISTOGRAM_BINS_LARGE 32
|
||||
#define N_HISTOGRAM_BINS_SMALL 32
|
||||
typedef lispobj size_histogram[2*N_HISTOGRAM_BINS_LARGE+N_HISTOGRAM_BINS_SMALL];
|
||||
|
||||
#include "genesis/thread.h"
|
||||
#include "genesis/thread-instance.h"
|
||||
|
|
|
|||
110
tests/alloc-histo.impure.lisp
Normal file
110
tests/alloc-histo.impure.lisp
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
|
||||
#-x86-64 (invoke-restart 'run-tests::skip-file)
|
||||
|
||||
(defvar *print-histogram* nil)
|
||||
(defun check-histogram (bin-index count kind)
|
||||
(let* ((h (sb-thread:allocator-histogram))
|
||||
(bins (first h))
|
||||
(ok t))
|
||||
(dotimes (i (length bins))
|
||||
(setq ok (and ok
|
||||
(if (= i bin-index)
|
||||
(= (aref bins bin-index) count)
|
||||
(zerop (aref bins i))))))
|
||||
(when (or (not ok) *print-histogram*)
|
||||
(sb-thread:print-allocator-histogram h))
|
||||
(unless ok
|
||||
(error "Unexpected histogram: expected bin ~D = ~D"
|
||||
bin-index count))
|
||||
;; this isn't using the large-object-size vector so we can't assert
|
||||
;; about boxed/unboxed for bin >= 32
|
||||
(when (<= bin-index 31)
|
||||
(let ((nbytes (* count (* (1+ bin-index) sb-vm:cons-size sb-vm:n-word-bytes))))
|
||||
(ecase kind
|
||||
(:unboxed (assert (= (third h) nbytes)))
|
||||
(:boxed (assert (= (fourth h) nbytes))))))
|
||||
h))
|
||||
(compile 'check-histogram)
|
||||
|
||||
(defun compile-with-histogram (lexpr)
|
||||
(let ((*features* (cons :allocation-size-histogram *features*)))
|
||||
(compile nil lexpr)))
|
||||
|
||||
(defvar *arena* (sb-vm:new-arena (* 512 1024 1024))) ; 512 MiB
|
||||
|
||||
(defun %assert-histogram (lambda bin-index count kind)
|
||||
(sb-thread:reset-allocator-histogram)
|
||||
(sb-vm:with-arena (*arena*)
|
||||
(funcall lambda))
|
||||
(sb-vm:rewind-arena *arena*)
|
||||
(check-histogram bin-index count kind))
|
||||
(compile '%assert-histogram)
|
||||
|
||||
(defmacro assert-histogram (form bin-index count kind)
|
||||
`(%assert-histogram (compile-with-histogram '(lambda () ,form)) ,bin-index ,count ,kind))
|
||||
|
||||
(test-util:with-test (:name :1-cons)
|
||||
(assert-histogram (cons 1 2) 0 1 :boxed))
|
||||
|
||||
(test-util:with-test (:name :2-cons)
|
||||
;; this counts _allocations_ of a given size, not objects of a given size.
|
||||
;; The latter whould say that it was 2 cons-sized objects, but in fact
|
||||
;; it is counted as 1 4-word object.
|
||||
(assert-histogram (list 1 2) 1 1 :boxed))
|
||||
|
||||
(test-util:with-test (:name :bit-vector)
|
||||
(assert-histogram (make-array 128 :element-type 'bit)
|
||||
1 1 :unboxed))
|
||||
|
||||
(setf (symbol-function 'instrumented-make-array-n)
|
||||
(compile-with-histogram '(lambda (n) (make-array (the integer n)))))
|
||||
|
||||
;; make boxed arrays from 1 to 32 conses in length
|
||||
(test-util:with-test (:name :boxed-array-small)
|
||||
(loop for array-len from 0 to 62 by 2
|
||||
for bin-index from 0
|
||||
do (let* ((constructor `(make-array ,array-len))
|
||||
(function (compile-with-histogram `(lambda () ,constructor))))
|
||||
(assert (= (primitive-object-size (funcall function))
|
||||
(* (+ array-len sb-vm:vector-data-offset)
|
||||
sb-vm:n-word-bytes)))
|
||||
(let ((expected-histogram (%assert-histogram function bin-index 1 :boxed)))
|
||||
(sb-thread:reset-allocator-histogram)
|
||||
(opaque-identity (funcall 'instrumented-make-array-n array-len))
|
||||
(let ((histogram (sb-thread:allocator-histogram)))
|
||||
(assert (equalp histogram expected-histogram)))))))
|
||||
|
||||
(test-util:with-test (:name :boxed-array-large-bins)
|
||||
;; an array of 64 words exceeds the largest small bin
|
||||
(let ((array-len 64))
|
||||
(dotimes (trial 300)
|
||||
(let* ((constructor `(make-array ,array-len))
|
||||
(function (compile-with-histogram `(lambda () ,constructor)))
|
||||
(nbytes (primitive-object-size (funcall function)))
|
||||
(bin-index
|
||||
(+ 32 ; skip over the small bins
|
||||
(integer-length nbytes)
|
||||
-10))) ; first large bin is for 2^10. Subtract the bias
|
||||
(assert (= nbytes
|
||||
(* (+ array-len sb-vm:vector-data-offset)
|
||||
sb-vm:n-word-bytes)))
|
||||
(let ((expected-histogram (%assert-histogram function bin-index 1 :boxed)))
|
||||
(sb-thread:reset-allocator-histogram)
|
||||
(opaque-identity (funcall 'instrumented-make-array-n array-len))
|
||||
(let ((histogram (sb-thread:allocator-histogram)))
|
||||
;; (sb-thread:print-allocator-histogram histogram)
|
||||
(assert (equalp histogram expected-histogram)))))
|
||||
(incf array-len 2))))
|
||||
|
||||
(defun make-monster ()
|
||||
(let* ((desired-size (* 1024 1024 1024)) ; 1 GiB
|
||||
(desired-nwords (/ desired-size sb-vm:n-word-bytes))
|
||||
(nelem (- desired-nwords 2)))
|
||||
(funcall 'instrumented-make-array-n nelem)))
|
||||
|
||||
;(setq *print-histogram* t)
|
||||
(test-util:with-test (:name :monster)
|
||||
(assert-histogram (make-monster)
|
||||
;; I just printed the histogram and looked at it, and wired in
|
||||
;; the expected bin. I dont really feel like computing it in the test.
|
||||
53 1 :boxed))
|
||||
Loading…
Reference in a new issue