get-consing.lisp

[Mark.Kantrowitz@A.GP.CS.CMU.EDU]

The following defines a get-consing function suitable for use in the 
profiling code I posted about recently. It is based on the examples
from MACL 1.3.2.  (Note that each call to get-consing conses, which
introduces some inaccuracy.)

--mark
;;; ****************************************************************
;;; get-consing.lisp ***********************************************
;;; ****************************************************************

;;; based on ccl memory-usage.lisp
(in-package :ccl)

(defvar *bytes-consed-chkpt* 0)

(eval-when (eval compile)
  (defconstant $currentA5 #x904)
  (defconstant $pagecounts #x-18e)
  (defconstant $lstFP #x-a42)
  (defconstant $consfirstob 64)
  (defconstant $pagesize 4096))

(let ((old-gc (symbol-function 'gc))
      (ccl:*warn-if-redefine-kernel* nil))
  (setf (symbol-function 'gc)
        #'(lambda ()
            (let ((old-consing (total-bytes-consed)))
              (prog1
                (funcall old-gc)
                (incf *bytes-consed-chkpt* (- old-consing (total-bytes-consed))))))))

(defun total-bytes-consed (&aux pages fp)
  "Returns number of conses (8 bytes each)"
  (let* ((a5 (%get-ptr $currentA5))
         (ptr (%inc-ptr a5 $pagecounts)))
    (%ilsr 3 (%i+ (%i- (%ilsl 12 (%i- (setq pages (%get-word ptr 0)) 1)) (%i* pages $consfirstob))
                   (if (eq 0 (setq fp (%get-long a5 $lstFP))) $pagesize (%ilogand2 #xfff fp))))))


(defun get-consing ()
  (+ (total-bytes-consed) *bytes-consed-chkpt*))