; .EnTete "Le-Lisp (c) version 15.2" " " "Print GC Infos"
; .EnPied "printgcinfo.ll" "%" " "
;
; .Centre "$Header: printgcinfo.ll,v 1.4 89/01/04 19:17:20 chaillou Exp $"

; Print GC Infos in a more readable way than (GCINFO)

; CAUTION : (print-gcinfo) works only with 32bit pointers Le-Lisp



(defvar #:sys-package:colon 'printgcinfo)


(defvar :gcinfo-database (list (cons () (gcinfo t))))

(defvar :list-name '(cons symbol string vector float fix heap code))
(defvar :list-size '(10   12     14     16     18    20  22   24))
(defvar :list-cont '(1    2      3      4      5     6   7    ()))

; This line has to be changed if the size of a Lisp pointer is not 32 bits
(defvar :list-byte '(8    32     8      8      8     0   1    1))


(de save-gcinfo (name)
    (if (symbolp name)
	(setq :gcinfo-database (acons name (gc t) :gcinfo-database))
        (error 'save-gcinfo 'errsymb name))
    name)

(de :get-gcinfo (name)
    (or (cassq name :gcinfo-database)
	(cassq ()   :gcinfo-database)))

(de print-gcinfo rest
    (let ((format1 "~A~7T~4D~14T~8,0F~9,0F~34T~7,0F~9,0F~54T~7,0F~9,0F")
          (initial-gcinfo (if (symbolp (car rest))
			      (:get-gcinfo (car rest))
			      (error 'print-gcinfo 'errsymb (car rest))))
	  (current-gcinfo (gc t))
	  (total-call 0)
	  (total-init 0.)
	  (total-used 0.)
	  (total-free 0.))
         (prinf "Type~9TCall~20T  Init~39T  Used~59T  Free")
	 (terpri)
         (prinf "~18Tnb     size~37Tnb     size~57Tnb     size")
	 (terpri)
	 (mapc (lambda (name size byte call)
		 (let* ((ni   (:intval (nth size initial-gcinfo) 1))
			(init (:intval (nth size initial-gcinfo) byte))
			(nf   (:intval (nth size current-gcinfo) 1))
			(free (:intval (nth size current-gcinfo) byte))
			(nu   (- ni nf))
			(used (- init free))
			(call (if call (nth call current-gcinfo) 0)))
		   (incr total-call call)
		   (incr total-init init)
		   (incr total-used used)
		   (incr total-free free)
		   (prinf format1 name call ni init nu used nf free)
		   (terpri)))
	       :list-name
	       :list-size
	       :list-byte
	       :list-cont)
	 (print (format () format1 "Total" 
			total-call 0. total-init 0. total-used 0. total-free)))
    'print-gcinfo)

(de :intval (n byte)
    (* (if (consp n)
	   (* (car n) 1024)
	   n)
       byte))