Commit 8c74ad6c authored by Daniel Kochmański's avatar Daniel Kochmański

cosmetic: untabify, improve .gitignore

parent 17bf4145
*~
*.xcl
*.abcl
*.lib
*.o
......
......@@ -319,13 +319,13 @@ Estimated total monitoring overhead: 0.88 seconds
(provide "monitor")
(export '(*monitored-functions*
monitor monitor-all unmonitor monitor-form
with-monitoring
reset-monitoring-info reset-all-monitoring
monitored
report-monitoring
display-monitoring-results
monitoring-encapsulate monitoring-unencapsulate))
monitor monitor-all unmonitor monitor-form
with-monitoring
reset-monitoring-info reset-all-monitoring
monitored
report-monitoring
display-monitoring-results
monitoring-encapsulate monitoring-unencapsulate))
;;; Warn user if they're loading the source instead of compiling it first.
......@@ -396,10 +396,10 @@ Estimated total monitoring overhead: 0.88 seconds
#+clisp
(defmacro get-cons ()
`(the consing-type
(multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
(sys::%%time)
(declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
(dpb space1 (byte 24 24) space2))))
(multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
(sys::%%time)
(declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
(dpb space1 (byte 24 24) space2))))
#+clozure
(defmacro get-cons ()
......@@ -420,8 +420,8 @@ Estimated total monitoring overhead: 0.88 seconds
(eval-when (compile load)
(defmacro get-cons ()
`(the consing-type (ffi:c-inline () () :object
"ecl_make_unsigned_integer(GC_get_total_bytes())"
:one-liner t))))
"ecl_make_unsigned_integer(GC_get_total_bytes())"
:one-liner t))))
#-(or cmu clisp clozure ecl)
(progn
......@@ -447,23 +447,23 @@ Estimated total monitoring overhead: 0.88 seconds
(defun required-arguments (name)
(let ((type (ext:info function type name)))
(cond ((not (kernel:function-type-p type))
(warn "No argument count information available for:~% ~S~@
Allow for &rest arg consing."
name)
(values 0 t))
(t
(values (length (kernel:function-type-required type))
(if (or (kernel:function-type-optional type)
(kernel:function-type-keyp type)
(kernel:function-type-rest type))
t nil))))))
(warn "No argument count information available for:~% ~S~@
Allow for &rest arg consing."
name)
(values 0 t))
(t
(values (length (kernel:function-type-required type))
(if (or (kernel:function-type-optional type)
(kernel:function-type-keyp type)
(kernel:function-type-rest type))
t nil))))))
;;; Allegro and Clozure Common Lisp
#+(or allegro clozure)
(defun required-arguments (name)
(let* ((function (fdefinition name))
(args #+allegro(excl::arglist function)
#+clozure(ccl:arglist function))
#+clozure(ccl:arglist function))
(pos (position-if #'(lambda (x)
(and (symbolp x)
(let ((name (symbol-name x)))
......@@ -481,25 +481,25 @@ Estimated total monitoring overhead: 0.88 seconds
(case (type-of function)
(FUNCTION
(if (compiled-function-p function)
(multiple-value-bind (req-anz opt-anz rest-p key-p
keyword-list allow-other-keys-p)
(sys::signature function)
(declare (ignore keyword-list allow-other-keys-p))
(values req-anz (or (plusp opt-anz) rest-p key-p)))
(let ((lambdalist (car (sys::%record-ref function 1))))
(values (or (position-if #'(lambda (x)
(member x lambda-list-keywords))
lambdalist)
(length lambdalist))
(and (intersection lambdalist lambda-list-keywords) t)))))
(multiple-value-bind (req-anz opt-anz rest-p key-p
keyword-list allow-other-keys-p)
(sys::signature function)
(declare (ignore keyword-list allow-other-keys-p))
(values req-anz (or (plusp opt-anz) rest-p key-p)))
(let ((lambdalist (car (sys::%record-ref function 1))))
(values (or (position-if #'(lambda (x)
(member x lambda-list-keywords))
lambdalist)
(length lambdalist))
(and (intersection lambdalist lambda-list-keywords) t)))))
(COMPILED-FUNCTION
(multiple-value-bind (name req-anz opt-anz rest-p
keywords allow-other-keys)
(sys::subr-info function)
(declare (ignore allow-other-keys))
(if name
(values req-anz (or (plusp opt-anz) rest-p keywords))
(values 0 t))))
keywords allow-other-keys)
(sys::subr-info function)
(declare (ignore allow-other-keys))
(if name
(values req-anz (or (plusp opt-anz) rest-p keywords))
(values 0 t))))
(T (values 0 t)))))
#-(or cmu clisp clozure allegro)
......@@ -594,13 +594,13 @@ variables/arrays/structures."
(defstruct metering-functions
(name nil)
(old-definition (error "Missing required keyword argument :old-definition")
:type function)
:type function)
(new-definition (error "Missing required keyword argument :new-definition")
:type function)
:type function)
(read-metering (error "Missing required keyword argument :read-metering")
:type function)
:type function)
(reset-metering (error "Missing required keyword argument :reset-metering")
:type function))
:type function))
;;; In general using hash tables in time-critical programs is a bad idea,
;;; because when one has to grow the table and rehash everything, the
......@@ -622,7 +622,7 @@ variables/arrays/structures."
(defun MONITORED (function-place)
"Test to see if a FUNCTION-PLACE is monitored."
(and (place-fboundp function-place) ; this line necessary?
(and (place-fboundp function-place) ; this line necessary?
(get-monitor-info function-place)))
(defun reset-monitoring-info (name)
......@@ -633,8 +633,8 @@ variables/arrays/structures."
(defun reset-all-monitoring ()
"Reset monitoring info for all functions."
(setq *total-time* 0
*total-cons* 0
*total-calls* 0)
*total-cons* 0
*total-calls* 0)
(dolist (symbol *monitored-functions*)
(when (monitored symbol)
(reset-monitoring-info symbol))))
......@@ -644,36 +644,36 @@ variables/arrays/structures."
adjusted for overhead."
(let ((finfo (get-monitor-info name)))
(if finfo
(multiple-value-bind (inclusive-time inclusive-cons
exclusive-time exclusive-cons
calls nested-calls)
(funcall (metering-functions-read-metering finfo))
(unless (or (null warn)
(eq (place-function name)
(metering-functions-new-definition finfo)))
(warn "Funtion ~S has been redefined, so times may be inaccurate.~@
(multiple-value-bind (inclusive-time inclusive-cons
exclusive-time exclusive-cons
calls nested-calls)
(funcall (metering-functions-read-metering finfo))
(unless (or (null warn)
(eq (place-function name)
(metering-functions-new-definition finfo)))
(warn "Funtion ~S has been redefined, so times may be inaccurate.~@
MONITOR it again to record calls to the new definition."
name))
(case nested
(:exclusive (values calls
nested-calls
(- exclusive-time
(* calls *monitor-time-overhead*))
(- exclusive-cons
(* calls *monitor-cons-overhead*))))
;; In :inclusive mode, subtract overhead for all the
;; called functions as well. Nested-calls includes the
;; calls of the function as well. [Necessary 'cause of
;; functions which call themselves recursively.]
(:inclusive (values calls
nested-calls
(- inclusive-time
(* nested-calls ;(+ calls)
*monitor-time-overhead*))
(- inclusive-cons
(* nested-calls ;(+ calls)
*monitor-cons-overhead*))))))
(values 0 0 0 0))))
name))
(case nested
(:exclusive (values calls
nested-calls
(- exclusive-time
(* calls *monitor-time-overhead*))
(- exclusive-cons
(* calls *monitor-cons-overhead*))))
;; In :inclusive mode, subtract overhead for all the
;; called functions as well. Nested-calls includes the
;; calls of the function as well. [Necessary 'cause of
;; functions which call themselves recursively.]
(:inclusive (values calls
nested-calls
(- inclusive-time
(* nested-calls ;(+ calls)
*monitor-time-overhead*))
(- inclusive-cons
(* nested-calls ;(+ calls)
*monitor-cons-overhead*))))))
(values 0 0 0 0))))
;;; ********************************
;;; Encapsulate ********************
......@@ -692,100 +692,100 @@ adjusted for overhead."
(dotimes (i min-args) (push (gensym) required-args))
`(lambda (name)
(let ((inclusive-time 0)
(inclusive-cons 0)
(exclusive-time 0)
(exclusive-cons 0)
(calls 0)
(nested-calls 0)
(old-definition (place-function name)))
(declare (type time-type inclusive-time)
(type time-type exclusive-time)
(type consing-type inclusive-cons)
(type consing-type exclusive-cons)
(fixnum calls)
(fixnum nested-calls))
(pushnew name *monitored-functions*)
(setf (place-function name)
#'(lambda (,@required-args
,@(when optionals-p `(&rest optional-args)))
,(when optionals-p
;; &rest optional-args can be stack allocated
`(declare (dynamic-extent optional-args)))
(let ((prev-total-time *total-time*)
(prev-total-cons *total-cons*)
(prev-total-calls *total-calls*)
; (old-time inclusive-time)
; (old-cons inclusive-cons)
; (old-nested-calls nested-calls)
(start-time (get-time))
(start-cons (get-cons)))
(declare (type time-type prev-total-time)
(type time-type start-time)
(type consing-type prev-total-cons)
(type consing-type start-cons)
(fixnum prev-total-calls))
(multiple-value-prog1
,(if optionals-p
`(apply old-definition
,@required-args optional-args)
`(funcall old-definition ,@required-args))
(let ((delta-time (- (get-time) start-time))
(delta-cons (- (get-cons) start-cons)))
;; Calls
(incf calls)
(incf *total-calls*)
;;; nested-calls includes this call
(incf nested-calls (the fixnum
(- *total-calls*
prev-total-calls)))
; (setf nested-calls (+ old-nested-calls
; (- *total-calls*
; prev-total-calls)))
;; Time
;;; Problem with inclusive time is that it
;;; currently doesn't add values from recursive
;;; calls to the same function. Change the
;;; setf to an incf to fix this?
(incf inclusive-time (the time-type delta-time))
; (setf inclusive-time (+ delta-time old-time))
(incf exclusive-time (the time-type
(+ delta-time
(- prev-total-time
*total-time*))))
(setf *total-time* (the time-type
(+ delta-time
prev-total-time)))
;; Consing
(incf inclusive-cons (the consing-type delta-cons))
; (setf inclusive-cons (+ delta-cons old-cons))
(incf exclusive-cons (the consing-type
(+ delta-cons
(- prev-total-cons
*total-cons*))))
(setf *total-cons*
(the consing-type
(+ delta-cons prev-total-cons))))))))
(setf (get-monitor-info name)
(make-metering-functions
:name name
:old-definition old-definition
:new-definition (place-function name)
:read-metering #'(lambda ()
(values inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls))
:reset-metering #'(lambda ()
(setq inclusive-time 0
inclusive-cons 0
exclusive-time 0
exclusive-cons 0
calls 0
nested-calls 0)
t)))))))
(inclusive-cons 0)
(exclusive-time 0)
(exclusive-cons 0)
(calls 0)
(nested-calls 0)
(old-definition (place-function name)))
(declare (type time-type inclusive-time)
(type time-type exclusive-time)
(type consing-type inclusive-cons)
(type consing-type exclusive-cons)
(fixnum calls)
(fixnum nested-calls))
(pushnew name *monitored-functions*)
(setf (place-function name)
#'(lambda (,@required-args
,@(when optionals-p `(&rest optional-args)))
,(when optionals-p
;; &rest optional-args can be stack allocated
`(declare (dynamic-extent optional-args)))
(let ((prev-total-time *total-time*)
(prev-total-cons *total-cons*)
(prev-total-calls *total-calls*)
; (old-time inclusive-time)
; (old-cons inclusive-cons)
; (old-nested-calls nested-calls)
(start-time (get-time))
(start-cons (get-cons)))
(declare (type time-type prev-total-time)
(type time-type start-time)
(type consing-type prev-total-cons)
(type consing-type start-cons)
(fixnum prev-total-calls))
(multiple-value-prog1
,(if optionals-p
`(apply old-definition
,@required-args optional-args)
`(funcall old-definition ,@required-args))
(let ((delta-time (- (get-time) start-time))
(delta-cons (- (get-cons) start-cons)))
;; Calls
(incf calls)
(incf *total-calls*)
;;; nested-calls includes this call
(incf nested-calls (the fixnum
(- *total-calls*
prev-total-calls)))
; (setf nested-calls (+ old-nested-calls
; (- *total-calls*
; prev-total-calls)))
;; Time
;;; Problem with inclusive time is that it
;;; currently doesn't add values from recursive
;;; calls to the same function. Change the
;;; setf to an incf to fix this?
(incf inclusive-time (the time-type delta-time))
; (setf inclusive-time (+ delta-time old-time))
(incf exclusive-time (the time-type
(+ delta-time
(- prev-total-time
*total-time*))))
(setf *total-time* (the time-type
(+ delta-time
prev-total-time)))
;; Consing
(incf inclusive-cons (the consing-type delta-cons))
; (setf inclusive-cons (+ delta-cons old-cons))
(incf exclusive-cons (the consing-type
(+ delta-cons
(- prev-total-cons
*total-cons*))))
(setf *total-cons*
(the consing-type
(+ delta-cons prev-total-cons))))))))
(setf (get-monitor-info name)
(make-metering-functions
:name name
:old-definition old-definition
:new-definition (place-function name)
:read-metering #'(lambda ()
(values inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls))
:reset-metering #'(lambda ()
(setq inclusive-time 0
inclusive-cons 0
exclusive-time 0
exclusive-cons 0
calls 0
nested-calls 0)
t)))))))
);; End of EVAL-WHEN
;;; For efficiency reasons, we precompute the encapsulation functions
......@@ -801,54 +801,54 @@ adjusted for overhead."
(defun find-encapsulation (min-args optionals-p)
(or (gethash (cons min-args optionals-p) *existing-encapsulations*)
(setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
(compile nil
(make-monitoring-encapsulation min-args optionals-p)))))
(compile nil
(make-monitoring-encapsulation min-args optionals-p)))))
(macrolet ((frob ()
(let ((res ()))
(dotimes (i precomputed-encapsulations)
(push `(setf (gethash '(,i . nil) *existing-encapsulations*)
#',(make-monitoring-encapsulation i nil))
res)
(push `(setf (gethash '(,i . t) *existing-encapsulations*)
#',(make-monitoring-encapsulation i t))
res))
`(progn ,@res))))
(let ((res ()))
(dotimes (i precomputed-encapsulations)
(push `(setf (gethash '(,i . nil) *existing-encapsulations*)
#',(make-monitoring-encapsulation i nil))
res)
(push `(setf (gethash '(,i . t) *existing-encapsulations*)
#',(make-monitoring-encapsulation i t))
res))
`(progn ,@res))))
(frob))
(defun monitoring-encapsulate (name &optional warn)
"Monitor the function Name. If already monitored, unmonitor first."
;; Saves the current definition of name and inserts a new function which
;; returns the result of evaluating body.
(cond ((not (place-fboundp name)) ; not a function
(when warn
(warn "Ignoring undefined function ~S." name)))
((place-macrop name) ; a macro
(when warn
(warn "Ignoring macro ~S." name)))
(t ; tis a function
(when (get-monitor-info name) ; monitored
(when warn
(warn "~S already monitored, so unmonitoring it first." name))
(monitoring-unencapsulate name))
(multiple-value-bind (min-args optionals-p)
(required-arguments name)
(funcall (find-encapsulation min-args optionals-p) name)))))
(cond ((not (place-fboundp name)) ; not a function
(when warn
(warn "Ignoring undefined function ~S." name)))
((place-macrop name) ; a macro
(when warn
(warn "Ignoring macro ~S." name)))
(t ; tis a function
(when (get-monitor-info name) ; monitored
(when warn
(warn "~S already monitored, so unmonitoring it first." name))
(monitoring-unencapsulate name))
(multiple-value-bind (min-args optionals-p)
(required-arguments name)
(funcall (find-encapsulation min-args optionals-p) name)))))
(defun monitoring-unencapsulate (name &optional warn)
"Removes monitoring encapsulation code from around Name."
(let ((finfo (get-monitor-info name)))
(when finfo ; monitored
(when finfo ; monitored
(remprop name 'metering-functions)
(setq *monitored-functions*
(remove name *monitored-functions* :test #'equal))
(remove name *monitored-functions* :test #'equal))
(if (eq (place-function name)
(metering-functions-new-definition finfo))
(setf (place-function name)
(metering-functions-old-definition finfo))
(when warn
(warn "Preserving current definition of redefined function ~S."
name))))))
(metering-functions-new-definition finfo))
(setf (place-function name)
(metering-functions-old-definition finfo))
(when warn
(warn "Preserving current definition of redefined function ~S."
name))))))
;;; ********************************
;;; Main Monitoring Functions ******
......@@ -867,45 +867,45 @@ adjusted for overhead."
"Remove the monitoring on the named functions.
Names defaults to the list of all currently monitored functions."
`(dolist (name ,(if names `',names '*monitored-functions*) (values))
(monitoring-unencapsulate name)))
(monitoring-unencapsulate name)))
(defun MONITOR-ALL (&optional (package *package*))
"Monitor all functions in the specified package."
(let ((package (if (symbolp package)
(find-package package)
package)))
(find-package package)
package)))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
(monitoring-encapsulate symbol)))))
(monitoring-encapsulate symbol)))))
(defmacro MONITOR-FORM (form
&optional (nested :exclusive) (threshold 0.01)
(key :percent-time))
&optional (nested :exclusive) (threshold 0.01)
(key :percent-time))
"Monitor the execution of all functions in the current package
during the execution of FORM. All functions that are executed above
THRESHOLD % will be reported."
`(unwind-protect
(progn
(monitor-all)
(reset-all-monitoring)
(prog1
(time ,form)
(report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
(monitor-all)
(reset-all-monitoring)
(prog1
(time ,form)
(report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
(unmonitor)))
(defmacro WITH-MONITORING ((&rest functions)
(&optional (nested :exclusive)
(threshold 0.01)
(key :percent-time))
&body body)
(&optional (nested :exclusive)
(threshold 0.01)
(key :percent-time))
&body body)
"Monitor the specified functions during the execution of the body."
`(unwind-protect
(progn
(dolist (fun ',functions)
(monitoring-encapsulate fun))
(reset-all-monitoring)
,@body
(report-monitoring :all ,nested ,threshold ,key))
(dolist (fun ',functions)
(monitoring-encapsulate fun))
(reset-all-monitoring)
,@body
(report-monitoring :all ,nested ,threshold ,key))
(unmonitor)))
;;; ********************************
......@@ -924,7 +924,7 @@ THRESHOLD % will be reported."
"Determines the average overhead of monitoring by monitoring the execution
of an empty function many times."
(setq *monitor-time-overhead* 0
*monitor-cons-overhead* 0)
*monitor-cons-overhead* 0)
(stub-function nil)
(monitor stub-function)
(reset-all-monitoring)
......@@ -935,10 +935,10 @@ of an empty function many times."
; (stub-function nil))
(let ((fiter (float overhead-iterations)))
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values 'stub-function)
(monitor-info-values 'stub-function)
(declare (ignore calls nested-calls))
(setq *monitor-time-overhead* (truncate (/ time fiter))
*monitor-cons-overhead* (truncate (/ cons fiter)))))
*monitor-cons-overhead* (truncate (/ cons fiter)))))
(unmonitor stub-function))
(set-monitor-overhead)
......@@ -953,11 +953,11 @@ of an empty function many times."
(proclaim '(type time-type *estimated-total-overhead*))
(defstruct (monitoring-info
(:conc-name m-info-)
(:constructor make-monitoring-info
(name calls time cons
percent-time percent-cons
time-per-call cons-per-call)))
(:conc-name m-info-)
(:constructor make-monitoring-info
(name calls time cons
percent-time percent-cons
time-per-call cons-per-call)))
name
calls
time
......@@ -968,10 +968,10 @@ of an empty function many times."
cons-per-call)
(defun REPORT-MONITORING (&optional names
(nested :exclusive)
(threshold 0.01)
(key :percent-time)
ignore-no-calls)
(nested :exclusive)
(threshold 0.01)
(key :percent-time)
ignore-no-calls)
"Report the current monitoring state.
The percentage of the total time spent executing unmonitored code
in each function (:exclusive mode), or total time (:inclusive mode)
......@@ -981,134 +981,132 @@ below THRESHOLD % of the time will not be reported."
(when (or (null names) (eq names :all)) (setq names *monitored-functions*))
(let ((total-time 0)
(total-cons 0)
(total-calls 0))
(total-cons 0)
(total-calls 0))
;; Compute overall time and consing.
(dolist (name names)
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values name nested :warn)
(declare (ignore nested-calls))
(incf total-calls calls)
(incf total-time time)
(incf total-cons cons)))
(monitor-info-values name nested :warn)
(declare (ignore nested-calls))
(incf total-calls calls)
(incf total-time time)
(incf total-cons cons)))
;; Total overhead.
(setq *estimated-total-overhead*
(/ (* *monitor-time-overhead* total-calls)
time-units-per-second))
(setq *estimated-total-overhead*
(/ (* *monitor-time-overhead* total-calls)
time-units-per-second))
;; Assemble data for only the specified names (all monitored functions)
(if (zerop total-time)
(format *trace-output* "Not enough execution time to monitor.")
(progn
(setq *monitor-results* nil *no-calls* nil)
(dolist (name names)
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values name nested)
(declare (ignore nested-calls))
(when (minusp time) (setq time 0.0))
(when (minusp cons) (setq cons 0.0))
(if (zerop calls)
(push (if (symbolp name)
(symbol-name name)
(format nil "~S" name))
*no-calls*)
(push (make-monitoring-info
(format nil "~S" name) ; name
calls ; calls
(/ time (float time-units-per-second)) ; time in secs
(round cons) ; consing
(/ time (float total-time)) ; percent-time
(if (zerop total-cons) 0
(/ cons (float total-cons))) ; percent-cons
(/ (/ time (float calls)) ; time-per-call
time-units-per-second) ; sec/call
(round (/ cons (float calls)))) ; cons-per-call
*monitor-results*))))
(display-monitoring-results threshold key ignore-no-calls)))))
(format *trace-output* "Not enough execution time to monitor.")
(progn
(setq *monitor-results* nil *no-calls* nil)
(dolist (name names)
(multiple-value-bind (calls nested-calls time cons)
(monitor-info-values name nested)
(declare (ignore nested-calls))
(when (minusp time) (setq time 0.0))
(when (minusp cons) (setq cons 0.0))
(if (zerop calls)
(push (if (symbolp name)
(symbol-name name)
(format nil "~S" name))
*no-calls*)
(push (make-monitoring-info
(format nil "~S" name) ; name
calls ; calls
(/ time (float time-units-per-second)) ; time in secs
(round cons) ; consing
(/ time (float total-time)) ; percent-time
(if (zerop total-cons) 0
(/ cons (float total-cons))) ; percent-cons
(/ (/ time (float calls)) ; time-per-call
time-units-per-second) ; sec/call
(round (/ cons (float calls)))) ; cons-per-call
*monitor-results*))))
(display-monitoring-results threshold key ignore-no-calls)))))
(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time)
(ignore-no-calls t))
(let ((max-length 8) ; Function header size
(total-time 0.0)
(total-consed 0)
(total-calls 0)
(total-percent-time 0)