;;;-*- Mode: Lisp; Package: CCL -*-

(in-package "CCL")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export 'ccl::summarize-dynamic-heap-usage "CCL"))

#|
? (ccl:summarize-dynamic-heap-usage)
|#

;;; Because of the way that per-thread consing works, the reported number
;;; of cons cells may be off by as much as ~8K (memory that's reserved
;;; for a thread to allocate things in - but not yet used - looks like
;;; a sequence of conses whose CAR and CDR both contain 0.)
;;; Fixing this is actually fairly hard (again, because of the way that
;;; per-thread consing works.)  The number and sizes of other reported
;;; data types should be accurate.

;;; If it's not clear (from a careful examination of the OpenMCL kernel
;;; and compiler sources), an "IVECTOR" is a vector-like object that
;;; contains immediate data (characters, machine instructions, floats,
;;; signed/unsigned bytes), whereas a "GVECTOR" is a vector-like object
;;; that contains lisp objects.

;;; SAVE-APPLICATION ordinarily tries to find certain read-only ivectors
;;; (code-vectors, pnames of interned symbols) and copies them to
;;; a read-only memory area.  This utility scans "dynamic space", which
;;; is roughly that area of memory in which the GC might free unreferenced
;;; objects.

(defun summarize-dynamic-heap-usage ()
  (let* ((nconses 0)
         (nivectors 0)
         (ivector-counts (make-array 32))
         (ivector-sizes (make-array 32))
         (ngvectors 0)
         (gvector-counts (make-array 32)) 
         (gvector-sizes (make-array 32)))
    (flet ((classify-object (o)
           (if (consp o)
             (incf nconses)
             (let* ((typecode (typecode o))
                    (elements (uvsize o))
                    (vector-type (ash typecode -3)))
               (declare (fixnum typecode elements vector-type))
               (if (= (logand typecode ppc32::fulltagmask)
                      ppc32::fulltag-immheader)
                 (progn
                   (incf nivectors)
                   (incf (svref ivector-counts vector-type))
                   (incf (svref ivector-sizes vector-type)
                         (logandc2 (+ 11 (subtag-bytes typecode elements)) 7)))
                 (progn
                   (incf ngvectors)
                   (incf (svref gvector-counts vector-type))
                   (incf (svref gvector-sizes vector-type)
                         (logandc2 (+ 7 (the fixnum (* 4 (1+ elements)))) 7))))))))
      (%map-areas #'classify-object ppc32::area-dynamic ppc32::area-dynamic)
      (report-heap-usage nconses nivectors ivector-counts ivector-sizes ngvectors gvector-counts  gvector-sizes))))


(defun report-heap-usage (nconses
                          nivectors
                          ivector-counts
                          ivector-sizes
                          ngvectors
                          gvector-counts
                          gvector-sizes)
  (format t "~&~d cons cells (~d bytes)" nconses (* 8 nconses))
  (format t "~%~% ~d ivectors:" nivectors)
  (dotimes (i 32)
    (let* ((count (svref ivector-counts i)))
      (unless (zerop count)
        (format t "~& #x~2,'0x (~a): ~d  (~d bytes)" (logior (ash i 3) ppc32::fulltag-immheader) (svref *immheader-types* i) count (svref ivector-sizes i)))))
  (format t "~%~% ~d gvectors:" ngvectors)
  (dotimes (i 32)
    (let* ((count (svref gvector-counts i)))
      (unless (zerop count)
        (format t "~& #x~2,'0x (~a): ~d (~d bytes)" (logior (ash i 3) ppc32::fulltag-nodeheader) (svref *nodeheader-types* i) count (svref gvector-sizes i)))))
  (values))