(in-package "KPML")

;;; File: performance-profiler.lisp
;;; John, Ober-Ramstadt, Jan97.
;;; Supplied as patch 1.0.29 (patches at beginning and end).
;;;
;;; Various utilities for measuring performance...
;;;
;;; ----------------------------------------------------------------------
;;; Sometimes GC becomes a problem...
;;; ----------------------------------------------------------------------

(defmacro PROTECT-FROM-GC (&body body)
  #+lispworks
  `(progn
     (hcl::avoid-gc)
     (hcl::with-heavy-allocation 
       ,@body)
     (format t "~%;;; garbage collecting between timings...")
     (hcl::mark-and-sweep 2)
     (format t "... Done."))
  #-lispworks
  `(progn ,@body))

;;; ----------------------------------------------------------------------
;;; Defines the function `config-profiler' which runs either a single
;;; example (default 10 times) or an entire example set (default once)
;;; under the different possile speed-up configurations for KPML.
;;; The timing results are written to the results file.
;;; The function is primarily for use in a batch mode and so does
;;; not admit errors. Is defined primarily for ACL.
;;; ----------------------------------------------------------------------

(defvar *profile-count* 10)

(defun CONFIG-PROFILER (ci? resources ex-param results)
  (format t "~%  ... starting profiler (~S, ~S, ~S)" ci? resources ex-param)
  (multiple-value-bind (result condition)
      (ignore-errors
       (let ((lg (intern (string-upcase (string resources)) "KEYWORD"))
	     (ex (if (eq ex-param :all) :all
		   (intern (string-upcase (string ex-param)) "KPML"))))
	 (setf all_languages (list lg))
	 (load-linguistic-resources lg :clear T :merge NIL)
	 (when ci? (load-compiled-inquiry-implementations lg))
	 (do-all-kpml-initializations)
	 #+allegro(excl:gc T)
	 (with-open-file
	     (*trace-output* (pathname results)
	      :direction :output
	      :if-does-not-exist :create
	      :if-exists :append)
	   (performance-profile-header *trace-output* ci? lg ex)

	   (setf *rigidly-monolingual* nil)
	   (labelled-performance *trace-output* 
				 (if ci? "compiled inquiries; full" "full")
				 ex)

	   (setf *rigidly-monolingual* T)
	   (labelled-performance 
	    *trace-output* (if ci? "compiled-inquiries; monolingual"
			     "monolingual")
	    ex)

	   (setf *rigidly-monolingual* nil)
	   (kb-package-reduction-speedup :force-p T)
	   (labelled-performance 
	    *trace-output* 
	    (if ci? "compiled-inquiries; package reduction" 
	      "package reduction") ex)
	   
	   (setf *rigidly-monolingual* T)
	   (labelled-performance 
	    *trace-output* 
	    (if ci? "compiled inquiries; monolingual package reduction"
	      "monolingual package reduction")
	    ex)
	   (values nil nil)
	   )))
    (declare (ignore result))
    (when condition
      (format t "~%!!! Something broke... (~A)" condition))))
	    

;;; ----------------------------------------------------------------------
;;; Describe what we've just monitored...
;;; ----------------------------------------------------------------------

(defun PERFORMANCE-PROFILE-HEADER (stream ci? resources ex)
  (format stream "~%KPML performance measures (~A)
  Resource set: ~A
  Compiled inquiries: ~A
  On example: ~A (~A times)
  At: ~A
  ----------------------
" (time-stamp) resources ci? ex *profile-count* (long-site-name))
  (let ((*standard-output* stream)) (describe-kpml))
  (format stream "~2%~S~2%" *features*))

(defun LABELLED-PERFORMANCE (stream id example)
  (format *trace-output* "~%Timing: ~A..." id)
  (format stream "~2%    Configuration: ~A~2%" id)
  (protect-from-gc
    (time
     (if (eq example :all)
         (example-runner (list-of-examples))
       (dotimes (n *profile-count*)(say example))))
    (format stream "~%")))

;;; ----------------------------------------------------------------------
;;; trivial version profiler functions...
;;; ----------------------------------------------------------------------

(defun KPML-SAY-PROFILE (example &optional (times 10))
  (format t "~%;;; Profiling on example ~A (language: ~A; ~A times)"
	  example curlan times)
  (format t "~%;;; Generated string: ~A" (say example))
  (time
   (dotimes (x times)
	    (say example))))

;;; ----------------------------------------------------------------------
;;; 2.0
;;; small extension for sets of examples... (with something done
;;; about excessive gc intervention in Lispworks)...
;;; ----------------------------------------------------------------------

(defun PROFILE-EXAMPLES (exlist)
  (loop for x in exlist
        do 
        (protect-from-gc
         (kpml-say-profile x))))


;;; Following incorporates the generation statistic gathering features
;;; developed for monitoring GREX (incorporated October 1997: Stirling: John)

;;; ----------------------------------------------------------------------
;;; Following word counter makes use of the fact that the default
;;; KPML setting is to put 2 spaces (or a comma and a space) between
;;; each leaf on its structure tree.
;;; (Corrected: October 97: John)
;;; ----------------------------------------------------------------------

(defun WC (string)
  (let (ch
	(count 0)
	(wc 1)
	(l (- (length string) 1)))
    (loop
      (setf ch (char string count))
      (cond ((and (or (char= ch #\space) 
		      (char= ch #\,))
		  (char= (char string (1+ count)) #\space))
	     (setf wc (1+ wc))
	     (setf count (1+ count))
	     ;; got our word, now skip over whitespace...
	     (loop
		 until (= count l)
		 while (char= (char string count) #\space)
		 do (setf count (1+ count)))
	     )
	    (t (setf count (1+ count))))
      (if (= count l)(return-from WC wc)))))


;;; ----------------------------------------------------------------------
;;; Creates a file where the runtime statistics and length of generated
;;; strings are easily accessible...
;;; 2.1 scaling factor and keywords added.
;;; ----------------------------------------------------------------------

(defun MAKE-TIMED-RUN (exs pathname 
		       &key (demo-mode T)(single-language T)(scaling 1))
  (when demo-mode (setf *demo-mode* T))
  (when single-language (setf *rigidly-monolingual* T))
  (with-open-file (stream pathname :direction :output :if-exists :supersede)
    (timed-and-lengthed exs scaling stream)))
  

(defun TIMED-AND-LENGTHED (exs &optional (scaling 1)(stream *standard-output*))
  (let ((s ""))
    (loop for ex in exs
	do (format stream "~%(:example ~A" ex)
	   (format stream "~% :runtime ~A"
		   (/ (runtime-extractor 
		       (with-output-to-string (out)
			 (let ((*trace-output* out))
			   (kpml-say-profile ex))))
		      scaling))
	   (setf s (say ex))
	   (format stream "~% :string ~S~% :length ~A)" s (wc s)))))


;;; ----------------------------------------------------------------------
;;; Extracts the runtime from the time message of Allegro Unix
;;; Common Lisp... Need similar things for other Lisps...
;;
;; 3.2.71
;;    Generation profiling updated for Lispworks.
;;; ----------------------------------------------------------------------

(defun RUNTIME-EXTRACTOR (message)
  (/
   (let ((runtime (read-from-string 
		   #+allegro
		   (remove #\,
			   (subseq message 
				   (+ (search "(non-gc) " message) 9) 
				   (search "msec" message)))
		   #+lispworks
		   (subseq message 1 (position #\space message))
		   )))
     (if (numberp runtime)
	 runtime
       0))
   10.0))

;;; ----------------------------------------------------------------------
;;; Gives coords for a sentence length against time plot
;;; ----------------------------------------------------------------------

(defun LENGTH-x-TIME (stats)
  (mapcar #'(lambda (s) (cons (eighth s)(fourth s))) stats))

;;; ----------------------------------------------------------------------
;;; Following takes a list in the form of a setf-ed input of a list
;;; as made with make-timed-run and produces the average runtimes
;;; according to sentence lengths.
;;; ----------------------------------------------------------------------

(defun AVERAGE-RUNTIMES (stats)
  (let ((data (mapcar #'(lambda (x) (cons (eighth x)(fourth x))) stats)))
    (loop for sl from 3 to 22 
	collect
	  (let* ((number 0)
		 (rts (loop for (l .  rt) in data
			  when (equal sl l)
			  do (setf number (1+ number))
			  and sum rt)))
	    (if (equal number 0)
		(cons sl 0)
	      (cons sl (/ rts number)))))))


;;; ----------------------------------------------------------------------
;;; Following messes about with the x and y scales for fitting
;;; easily in LaTeX-epic graphs. 
;;; ----------------------------------------------------------------------

(defun MAKE-SCALED-POINTS (path stats)
  (with-open-file 
      (str path :direction :output :if-exists :supersede)
    (loop for lt in stats
	do (format str "~%~A ~A" (* (first lt) 10) (/ (cdr lt) 10.0)))))


;;; ----------------------------------------------------------------------

(defvar *stats*)

(defun READ-STRING-STATS-FILE (pathname)
  (setf *stats* nil)
  (with-open-file (stream pathname :direction :input
		   :if-does-not-exist nil)
    (when (streamp stream)
      (loop until (eq (setf form (read stream nil :eof)) :eof)
	  do
	    (push form *stats*))))
  T)





