; .EnTete "Le-Lisp (c) version 15.2" " " "The Count Call Tool"
; .EnPied "countcalls.ll" "%" " "
;
; .Centre "$Header: countcalls.ll,v 1.2 88/11/15 15:17:05 chaillou Exp $"

; The Count Calls Tool :

; counts the number of calls for all the functions present in memory
; compiled or not, with a small overhead (30-50 % of the total execution
; time).
;
; Usage :
;      (count-calls-init)
;                  initialize the counters and start the counting
;      (count-calls-start)
;                  start the counting
;      (count-calls-stop)
;                  stop the counting
;      (count-calls-infos [min])
;                  return the a-list of the form :
;                          ((name count typefn) ...)
;                  for the current counting. If a float optionnal
;                  argument is provided, it represents the threshold
;                  value of the counters. By default this value is 1.0
;      (count-calls-printn [min])
;                  print, sorted by counts, the current counting. Use the
;                  same optionnal argument than the previous function.
;      (count-calls-printa [min])
;                  print, sorted by names, the current counting. Use the
;                  same optionnal argument than the previous function.

;
; Example :
; ? ^Acountcalls
; = countcalls
; ? (de fib (n) (cond ((eq n 1) 1)
; ?                   ((eq n 2) 1)
; ?                   (t (add (fib (sub1 n)) (fib (sub n 2)))))))
; = fib
; ? 
; ? (count-calls-init)
; = t
; ? (fib 20)
; = 6765
; ? (count-calls-printn 40)
;    24474.  subr2  eq
;    13529.  fsubr  cond
;    13529.  fsubr  quote
;    13529.   expr  fib
;     6764.  subr2  add
;     6764.  subr2  sub
;     6764.  subr1  sub1
; = ()
; ? (compile-all-in-core)
; = ()
; ? (count-calls-init)
; = t
; ? (fib 20)
; = 6765
; ? (count-calls-printn 40)
;    13529.  subr1  fib
; = ()



; .Section "Global Variables and Libraries"

(unless (>= (version) 15.21)
        (error 'load 'erricf 'countcalls))


(add-feature 'countcalls)

(setq #:sys-package:colon 'count-calls)

(defvar :plist-indicator ':count-calls-indicator)

(defvar :last-loc-for-system-functions (loc 'calln))

(defvar :active-flag ())

(defvar :debug-flag ())


; .Section "The Count Call Internal Function"



(loader '(

          ; Hand coded function equivalent to :
          ;
          ;(df :fincrplist (symb)
          ;    ; an FEXPR version of :incrplist
          ;    (:incrplist symb))
          ;   
          ;(defun :incrplist (symb)
          ;    ; has to return () to avoid interferences
          ;    ; with functions without body.
          ;    (if :active-flag
          ;        (let ((:active-flag ()))
          ;             (:incrplist-aux (plist symb))
          ;             ())
          ;        ()))
          ;
          ;(defun :incrplist-aux (plist)
          ;    (cond ((null plist) ())
          ;          ((eq (car plist) :plist-indicator)
          ;           (rplaca (cdr plist) (fadd (cadr plist) 1.)))
          ;          (t (:incrplist-aux (cddr plist)))))
          ;
          (fentry :fincrplist fsubr)
          (mov (car a1) a1)
          (jmp :incrplist)    

          (fentry :incrplist subr1)
          (cabeq nil (cvalq :active-flag) 101)
          (bfvar a1 101)
          (mov (plist a1) a1)
          (call 104)
      101 (mov nil a1)
          (return)

      103 (mov (cdr a1) a1)
          (bfcons a1 105)
          (mov (cdr a1) a1)
      104 (bfcons a1 105)
          (cabne (car a1) (cvalq :plist-indicator) 103)
          (mov (cdr a1) a1)
          (bfcons a1 105)
          (fplus '1. (car a1))
      105 (return)
          (end)))
          

; .Section "Initialize the Count-Call"

(defun count-calls-init ()
    (let ((:active-flag ()))
         (mapoblist (lambda (x) (if (getprop x :plist-indicator)
                                    (putprop x 0.0 :plist-indicator)
                                    (:count-calls-init1 x)))))
    (count-calls-start))

(defun :count-calls-init1 (x)
  ; prepare the count call of the symbol "x"
  (when (typefn x)
        (let ((#:ld:special-case-loader t))
             ; to realize the SETFN not during the FENTRY but after the END
             ; in order to assemble the rigth address operand in BRI
          (if (or (eq (packagecell x) '#.#:sys-package:colon)
                  (and (eq (packagecell x) 'llcp)
                       (gtadr :last-loc-for-system-functions (loc x))))
              ()
              (when :debug-flag (print ':count-calls-init1 " " x))
              (putprop x 0.0 :plist-indicator)
              (selectq (typefn x)
                 ((subr0 subr1 subr2 subr3 nsubr fsubr msubr dmsubr)
                  (loader `((fentry ,x ,(typefn x))
                            (push a1)
                            (mov ',x a1)
                            (jcall :incrplist)
                            (pop a1)
                            (bri (eval (kwote (vag (valfn ',x)))))
                            (end))))
                 ((expr fexpr macro dmacro)
                  (let ((v (valfn x)))
                       (resetfn x
                                (typefn x) 
                                (mcons (car v)
                                       `(:fincrplist 
,x)
                                       (cdr v)))))
                 (t ()))))))


; .Section "Start / Stop the Count Call Tool"

(defun count-calls-start ()
    (setq :active-flag t))

(defun count-calls-stop ()
    (setq :active-flag ()))


; .Section "Print various Count Call Infos"

(defun :get-count-calls-infos (fnt val-min)
    ; returns an unordered list of the current values of the Count Call
    ; discaring all the values < than val-min.
    ; This internal function is called by the "fnt" function
    ; of the interface.
    (setq val-min (if (consp val-min)
                      (if (and (floatp (car val-min))
                               (>= (car val-min) 0.0))
                          (car val-min)
                        (error fnt 'erroob (car val-min)))
                      1.))
    (let ((l))
         (mapoblist (lambda (x) (let ((v (getprop x :plist-indicator)))
                                  (when (and v
                                             (floatp v)
                                             (fle val-min v))
                                        (newl l (list x
                                                      v
                                                      (typefn x)))))))
         l))


(defun count-calls-infos val-min
    (let ((:active-flag ()))
         (:get-count-calls-infos 'count-calls-infos val-min)))


(defun count-calls-printn val-min
    (let ((:active-flag ()))
         (let ((l (:get-count-calls-infos 'count-calls-printn val-min)))
              (setq l (sort (lambda (x y) (> (cadr x) (cadr y))) l))
              (mapc (lambda (z)
                      (prinf " ~8,0F ~6A  ~A"
                             (cadr z)
                             (caddr z)
                             (car z))
                      (terpri))
                    l))))


(defun count-calls-printa val-min
    (let ((:active-flag ()))
         (let ((l (:get-count-calls-infos 'count-calls-printa val-min)))
              (setq l (sort (lambda (x y) (alphalessp (car x) (car y))) l))
              (mapc (lambda (z)
                      (prinf " ~36A  ~6@A ~8,0F "
                             (car z)
                             (caddr z)
                             (cadr z))
                      (terpri))
                    l))))