;;; -*- Mode:LISP; Package:MICRO; Base:8; Readtable:ZL -*-

(define-micro-function %read-a-mem (adr)
  (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-fix)) trap)
;(error-table ...)
  ((oa-reg-high) dpb oah-a-src pdl-pop)
  ((m-1) seta a-garbage)
  (jump return-m-1-unsigned))

(define-micro-function %write-a-mem (adr val)
  ((m-t) pdl-top)
  (call get-32-bits)
  (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-fix)) trap)
  ((m-2) q-pointer pdl-pop)
  (jump-greater-or-equal m-2 (a-constant 64.) write-a)
  ((oa-reg-low) dpb oal-m-dest m-2)
  ((m-garbage) m-1)
  (popj)
write-a
  ((oa-reg-low) dpb oal-a-dest m-2)
  ((a-garbage) m-1)
  (popj))

(define-micro-function increment (a)
  "Increment a."
  ((m-t) pdl-pop)
  (popj-after-next popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)))
 ((m-t) m+a+1 m-t a-zero)
  )

(define-micro-function foo (x)
 (locality d-mem)
 (start-dispatch 1 0)
 d-foobar
	(foo1 n-bit)
	(foo2 n-bit)
 (end-dispatch)

 (locality i-mem)
	(dispatch pdl-pop (byte-field 1 0) d-foobar)
foo1
	((m-t) a-v-true)
	(popj)
foo2
	((m-t) a-v-nil)
	(popj)
 )

(define-micro-function add-1-if-even (num)
  ((m-t) pdl-pop)
  (popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)))
  (popj-if-bit-set (byte 1 0) m-t)
  ((m-t) add m-t (a-constant 1))
  (popj)
  )

(define-micro-function car-if-list (l)
  ((m-t) pdl-pop)
  (popj-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)))
  ((vma-start-read) m-t)
  (check-page-read)
  (dispatch transport md)
  ((m-t) md)
  (popj))
  
(define-micro-function stat-counter ()
  ((m-1) stat-counter)
  (jump return-m-1-unsigned))


(define-micro-function reset-and-enable-stat-counters (main-clock main-count aux-clock aux-count)
  ((a-processor-switches) dpb m-zero (lisp-byte lam:%%processor-switch-use-stat2-for-usec-clock) a-processor-switches)
  ;;stop counters
  ((rg-mode) andca rg-mode (a-constant (eval (+ (dpb -1 (byte 3 0) 0)	;aux count
						(dpb -1 (byte 1 4) 0)	;aux clock
						(dpb -1 (byte 3 20.) 0)	;main count
						(dpb -1 (byte 1 24.) 0)	;main clock
						))))
  ((m-1) rg-mode)
  ((m-1) dpb pdl-pop (byte 3 0) a-1)		;aux count
  ((m-1) dpb pdl-pop (byte 1 4) a-1)		;aux clock
  ((m-1) dpb pdl-pop (byte 3 20.) a-1)		;main count
  ((m-1) dpb pdl-pop (byte 1 24.) a-1)
  ((stat-counter) setz)
  ((stat-counter-aux) setz)
  (popj-after-next (m-t) a-v-nil)
 ((rg-mode) m-1)
 )

(define-micro-function stop-and-read-stat-counters ()
  ((a-processor-switches) dpb m-zero (lisp-byte lam:%%processor-switch-use-stat2-for-usec-clock) a-processor-switches)
  ;;stop counters
  ((rg-mode) andca rg-mode (a-constant (eval (+ (dpb -1 (byte 3 0) 0)	;aux count
						(dpb -1 (byte 1 4) 0)	;aux clock
						(dpb -1 (byte 3 20.) 0)	;main count
						(dpb -1 (byte 1 24.) 0)	;main clock
						))))
  ((m-1) stat-counter)
  (call return-m-1-unsigned)
  ((pdl-push) m-t)
  ((m-1) stat-counter-aux)
  (call return-m-1-unsigned)
  ((pdl-push) m-t)
  (call xcons)
  (popj))

(define-micro-function write-new-car (list new-car)
  ((md) pdl-pop)
  (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-list)) trap)
  ((vma-start-write) pdl-pop)
  (check-page-write)
  (gc-write-test)
  ((m-t) a-v-nil)
  (popj))

(define-micro-function xor-nil-and-t (x)
  ((m-a) q-typed-pointer pdl-pop)
  (jump-equal m-a a-v-nil foo)
  ((m-t) a-v-nil)
  (popj)
foo
  ((m-t) a-v-true)
  (popj))

(define-micro-function check-noop-insert ()
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ((m-t) a-v-nil)
  ;the assembler inserts a no-op here
  (jump-xct-next bar)
 ((m-t) a-v-true)
  ((m-t) (a-constant (byte-value q-data-type dtp-fix)))
  (popj)
bar
  (popj))

(define-micro-function test-trap ()
  (call trap)
 (error-table illegal-instruction))

(define-micro-function return-t-fast ()
  (declare (:call-as-misc-instruction t))
  ((m-t) a-v-true)
  (popj))

(defun foo ()
  (return-t-fast))

(define-micro-function test-mmcall-ucode (func)
  ((m-a) pdl-pop)
  (call-data-type-not-equal m-a (a-constant (byte-value q-data-type dtp-fef-pointer)) trap)
;(error-table ...)
  (call p3zero)
  ((pdl-push) m-a)
  ((pdl-push) a-v-true)
  ((arg-call mmcall) (i-arg 1))
  (call-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-fix)) trap)
;(error-table...)
  ((m-t) add m-t (a-constant 1))
  (popj))

(defun test-mmcall ()
  (test-mmcall-ucode #'(lambda (arg) (format t "~&The arg is ~s" arg) 5)))

;   M-A (and M-FEF and C-PDL at M-AP) HAS PNTR TO FEF TO CALL
;   m-ap has already been updated 
;   m-s has previous m-ap (for frame leaving)
;   M-R HAS NUMBER OF ARGUMENTS, (%%lp-ens-num-args-supplied already stored)

; M-T debugging info
; M-B the atom 'si:stat-stuff
(define-micro-patch qlentr ()
  (declare (:support-vector (i-arg-stat-data 'si:stat-data)))
  ((arg-call ref-support-vector) i-arg-stat-data)
  ((vma-start-read) add md (a-constant 1))
  (check-page-read)
  ;no transport - it might be unbound, and we only care about T
  ((md) q-typed-pointer md)
  (jump-not-equal md a-v-true return)
  ((vma-start-read) m-fef)
  (check-page-read)
  (dispatch transport md)
  ((m-1) (lisp-byte si:%%fefh-pc-in-words) md)
  ((m-1) sub m-1 (a-constant 1))
  ((vma-start-read) add m-1 a-fef)
  (check-page-read)
  (dispatch transport md)
  ((m-t) md)
  ;;now have debugging info
  (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) return)
  ((arg-call ref-support-vector) i-arg-stat-data)
  ((m-b) q-typed-pointer md)
again
  (call carcdr-no-sb)  ;get car in M-A, cdr in M-T
  (jump-data-type-not-equal m-a (a-constant (byte-value q-data-type dtp-list)) return)
  ;;do another car
  ((vma-start-read) m-a)
  (check-page-read)
  (dispatch transport md)
  ((md) q-typed-pointer md)
  (jump-equal md a-b found-it)
  ((m-t) q-typed-pointer m-t)
  (jump-not-equal m-t a-v-nil again)
  (jump return)

found-it
  ((m-t) m-a)
  (call qcdr)
  (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) return)
  ((vma-start-read) m-t)
  (check-page-read)
  (dispatch transport md)
  (jump-data-type-not-equal md (a-constant (byte-value q-data-type dtp-fix)) return)
  ((m-1) md)
  ((md) q-pointer md)
  ((md) add md (a-constant 1))
  ((md-start-write) ldb md q-pointer a-1)
  (check-page-write)
  (gc-write-test)
  (jump return)

return
  ((m-a vma-start-read) m-fef)
  (check-page-read)
  (popj)
  )

(defun add-stat-data-slot (function &aux (si:%inhibit-read-only t))
  (when (symbolp function)
    (setq function (symbol-function function)))
  (etypecase function
    (compiled-function
     (let ((debug-info (%p-contents-offset function (1- (%structure-boxed-size function))))
	   (debug-info-present (%p-ldb-offset si:%%fefhi-ms-debug-info-present function si:%fefhi-misc)))
       (cond ((null debug-info)
	      (%p-dpb-offset 1 si:%%fefhi-ms-debug-info-present function si:%fefhi-misc))
	     ((consp (car debug-info))
	      (when (zerop debug-info-present)
		(format t "~&Function ~s has debug-info ~s, but says no debug-info present" function debug-info)
		(%p-dpb-offset 1 si:%%fefhi-ms-debug-info-present function si:%fefhi-misc)))
	     (t
	      (format t "~&Function ~s has debug-info ~s and debug-info-present ~s" function debug-info debug-info-present)
	      (when (y-or-n-p "~&Set to NIL ?")
		(setq debug-info nil))
	      (%p-dpb-offset 1 si:%%fefhi-ms-debug-info-present function si:%fefhi-misc)))
       (when (null (assq 'si:stat-data debug-info))
	 (setf (si:fef-debugging-info function)
	       (cons (list 'si:stat-data 0)
		     debug-info)))))))

(defun add-stat-data-slot-to-all-functions ()
  (mapcar 'add-stat-data-slot si:*fef-list*)
  nil)

(defun reset-all-stat-data ()
  (mapcar #'(lambda (function)
	      (let ((sdata (assq 'si:stat-data (debugging-info function))))
		(when (null sdata)
		  (ferror nil "no stat data for function ~s" function))
		(setf (cadr sdata) 0)))
	  si:*fef-list*)
  nil)

(defvar *stat-data-array* (make-array 2000. :leader-list '(0)))

(defun collect-stat-data ()
  (array-initialize *stat-data-array* nil)
  (setf (fill-pointer *stat-data-array*) 0)
  (mapcar #'(lambda (function)
	      (let ((sdata (assq 'si:stat-data (debugging-info function))))
		(when (and sdata
			   (not (zerop (cadr sdata))))
		  (array-push-extend *stat-data-array* (list (cadr sdata) function)))))
	  si:*fef-list*)
  nil)

(defun sort-it ()
  (time '(sort *stat-data-array* #'(lambda (x y) (< (car x) (car y))))))

(define-micro-function sort-it-fast-lessp (x y)
  (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-list)) trap)
  ((vma-start-read) pdl-pop)
  (check-page-read)
  (call-data-type-not-equal md (a-constant (byte-value q-data-type dtp-fix)) trap)
  ((m-b) q-pointer md)
  (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-list)) trap)
  ((vma-start-read) pdl-pop)
  (check-page-read)
  (call-data-type-not-equal md (a-constant (byte-value q-data-type dtp-fix)) trap)
  ((m-a) q-pointer md)
  ((m-t) a-v-true)
  (popj-after-next popj-less-than m-a a-b)
 ((m-t) a-v-nil))

(defun sort-it-fast ()
  (time '(sort *stat-data-array* #'sort-it-fast-lessp)))

(defun print-it ()
  (do ((i (1- (fill-pointer *stat-data-array*)) (1- i)))
      ((<= i 0))
    (print (aref *stat-data-array* i))))

(defvar test-start-time)
(defvar test-end-time)

(defvar si:stat-data nil)

(defun start-test ()
  (when (null (get 'qlentr 'i-mem-block))
    (ferror nil "must have qlentr patch ready"))
  (setq si:stat-data nil)
  (reset-all-stat-data)
  (setq test-start-time (time:get-universal-time))
  t)

(defun finish-test ()
  (setq si:stat-data nil)
  (setq test-end-time (time:get-universal-time))
  (collect-stat-data)
  (sort-it-fast)
  t)

(defun run-test ()
  (start-test)
  (let ((si:stat-data t))
    (print-herald))
  (finish-test))

(defun run-whole-machine-test ()
  (start-test)
  (dolist (process si:all-processes)
    (dolist (reason (send process :run-reasons))
      (when (instancep reason)
	(typecase reason
	  ((or tv:lisp-listener
	       zwei:zmacs-frame)
	   (make-process-bind-stat-data process t)))))))

(defun find-processes-with-stat-data-on ()
  (loop for process in si:all-processes
	when (and (not (send process :simple-p))
		  (eq (symeval-in-stack-group 'si:stat-data
					      (send process :initial-stack-group))
		      t))
	collect process))

(defun get-whole-machine-running-results ()
  (collect-stat-data)
  (setq test-end-time (time:get-universal-time))
  (sort-it-fast)
  nil)

(defun print-stats ()
  (format t "~&From ~\time\ to ~\time\ -- ~\time-interval\"
	  test-start-time
	  test-end-time
	  (- test-end-time test-start-time))
  (let ((sum 0))
    (dotimes (i (array-active-length *stat-data-array*))
      (incf sum (car (aref *stat-data-array* i))))
    (format t "~&~:d function calls total" sum)
    (do ((i (1- (array-active-length *stat-data-array*)) (1- i)))
	((< i 0))
      (format t "~&~10:d  ~2d%  ~s"
	      (car (aref *stat-data-array* i))
	      (round (* 100. (// (float (car (aref *stat-data-array* i))) sum)))
	      (function-name (cadr (aref *stat-data-array* i)))))))

(defun new-fef (f)
  (if (symbolp f) (setq f (symbol-function f)))
  (etypecase f
    (compiled-function
     (add-stat-data-slot f)
     (push f si:*fef-list*)))
  nil)

(defun make-process-bind-stat-data (process val)
  (check-type process si:process)
  (when (eq process current-process)
    (process-run-function "bind hack"
			  #'make-process-bind-stat-data
			  process
			  val)
    (return-from make-process-bind-stat-data nil))
  (let ((sg (send process :initial-stack-group)))
    (let ((rp (si:sg-regular-pdl sg))
	  (sp (si:sg-special-pdl sg)))
      (when (not (= (si:sg-initial-function-index sg) 3))
	(ferror nil "initial function index not 3"))
      (when (not (> (si:sg-regular-pdl-pointer sg) 3))
	(ferror nil "regular pdl too short"))
      (when (not (or (eq (aref rp 3) #'si:process-top-level)
		     (eq (aref rp 3) #'si:lisp-top-level)))
	(ferror nil "inital function is not PROCESS-TOP-LEVEL or LISP-TOP-LEVEL"))

      (do ((index 0 (+ index 2))
	   slot)
	  ((>= index (si:sg-special-pdl-pointer sg))
	   (ferror nil "ran out of special pdl"))
	(without-interrupts
	  (when (or (not (locativep (aref sp (1+ index))))
		    (and (not (zerop index))
			 (not (zerop (%p-ldb si:%%SPECPDL-BLOCK-START-FLAG
					     (locf (aref sp index)))))))
	    ;;didn't find a binding already there, so bash //////
	    (%p-store-contents (locf (aref sp (1+ slot))) (locf (symbol-value 'si:stat-data)))
	    (%p-store-contents (locf (aref sp slot)) val)
	    (return nil))
	  (when (eq (aref sp (1+ index)) (locf (symbol-value 'si:stat-data)))
	    (%p-store-contents (locf (aref sp index)) val)
	    (return nil))
	  (when (eq (aref sp (1+ index)) (locf (symbol-value '//////)))
	    (setq slot index))))))
  (let* ((closure (symeval-in-instance process 'si:closure))
	 (bindings (closure-bindings closure)))
    (cond ((null bindings)
	   (setf (closure-bindings closure) (list (locf (symbol-value 'si:stat-data))
						  (%make-pointer dtp-locative (ncons val)))))
	  (t
	   (do ((rest bindings (cddr rest)))
	       ((null rest)
		(setf (closure-bindings closure)
		      (list* (locf (symbol-value 'si:stat-data))
			     (%make-pointer dtp-locative (ncons val))
			     (closure-bindings closure))))
	     (when (eq (car rest) (locf (symbol-value 'si:stat-data)))
	       (%p-store-contents (cadr rest) val)
	       (return nil))))))
  )
      
(defvar total-min-args (make-array 100. :initial-element 0))
(defvar total-max-args (make-array 100. :initial-element 0))
(defvar total-locals (make-array 100. :initial-element 0))
(defvar total-calls 0)

(defun find-average-number-of-locals ()
  (setq total-calls 0)
  (array-initialize total-min-args 0)
  (array-initialize total-max-args 0)
  (array-initialize total-locals 0)
  (dotimes (i (array-active-length *stat-data-array*))
    (let ((f (cadr (aref *stat-data-array* i)))
	  (ncalls (car (aref *stat-data-array* i))))
      (incf total-calls ncalls)
      (when (not (= (%data-type f) dtp-fef-pointer))
	(ferror nil "not a fef pointer"))
      (let ((misc (%p-ldb-offset %%q-pointer f si:%fefhi-misc))
	    (args-info (args-info f)))
	(incf (aref total-min-args (ldb %%arg-desc-min-args args-info)) ncalls)
	(incf (aref total-max-args (ldb %%arg-desc-max-args args-info)) ncalls)
	(incf (aref total-locals (ldb si:%%FEFHI-MS-LOCAL-BLOCK-LENGTH misc)) ncalls))))
  )

(defun print-average-number-of-locals ()
  (format t "~&~20tMIN~35tMAX~50tLOCALS")
  (dotimes (i (array-length total-min-args))
    (when (or (not (zerop (aref total-min-args i)))
	      (not (zerop (aref total-max-args i)))
	      (not (zerop (aref total-locals i))))
      (format t "~&~5d: " i))
    (when (not (zerop (aref total-min-args i)))
      (format t "~20t~8d" (aref total-min-args i)))

    (when (not (zerop (aref total-max-args i)))
      (format t "~35t~8d" (aref total-max-args i)))

    (when (not (zerop (aref total-locals i)))
      (format t "~50t~8d" (aref total-locals i)))))