diff options
| -rw-r--r-- | lisp/emacs-lisp/cust-print.el | 569 | ||||
| -rw-r--r-- | lisp/emacs-lisp/profile.el | 355 |
2 files changed, 924 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el new file mode 100644 index 0000000000..444cc29f91 --- /dev/null +++ b/lisp/emacs-lisp/cust-print.el @@ -0,0 +1,569 @@ +;; cus-print.el -- handles print-level and print-circle. + +;; LCD Archive Entry: +;; custom-print|Daniel LaLiberte|[email protected] +;; |Handle print-level, print-circle and more. +;; |$Date: Tue Mar 17, 1992$|$Revision: 1.0$| + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; This package provides a general print handler for prin1 and princ +;; that supports print-level and print-circle, and by the way, +;; print-length since the standard routines are being replaced. Also, +;; to print custom types constructed from lists and vectors, use +;; custom-print-list and custom-print-vector. See the documentation +;; strings of these variables for more details. + +;; If the results of your expressions contain circular references to +;; other parts of the same structure, the standard Emacs print +;; subroutines may fail to print with an untrappable error, +;; "Apparently circular structure being printed". If you only use cdr +;; circular lists (where cdrs of lists point back; what is the right +;; term here?), you can limit the length of printing with +;; print-length. But car circular lists and circular vectors generate +;; the above mentioned untrappable error in Emacs version 18. Version +;; 19 will support print-level, but it is often useful to get a better +;; print representation of circular structures; the print-circle +;; option may be used to print more concise representations. + +;; There are two main ways to use this package. First, you may +;; replace prin1, princ, and some subroutines that use them by calling +;; install-custom-print-funcs so that any use of these functions in +;; lisp code will be affected. Second, you could call the custom +;; routines directly, thus only affecting the printing that requires +;; them. + +;; Note that subroutines which call print subroutines directly will not +;; use the custom print functions. In particular, the evaluation +;; functions like eval-region call the print subroutines directly. +;; Therefore, evaluating (aref circ-list 0), which calls error +;; directly (because circ-list is not an array), will jump to the top +;; level instead of printing the circular list. + +;; Obviously the right way to implement this custom-print facility +;; is in C. Please volunteer since I don't have the time or need. + +;; Implementation design: we want to use the same list and vector +;; processing algorithm for all versions of prin1 and princ, since how +;; the processing is done depends on print-length, print-level, and +;; print-circle. For circle printing, a preprocessing step is +;; required before the final printing. Thanks to Jamie Zawinski +;; for motivation and algorithms. + +;;========================================================= +;; export list: + +;; print-level +;; print-circle + +;; custom-print-list +;; custom-print-vector +;; add-custom-print-list +;; add-custom-print-vector + +;; install-custom-print-funcs +;; uninstall-custom-print-funcs + +;; custom-prin1 +;; custom-princ +;; custom-prin1-to-string +;; custom-print +;; custom-format +;; custom-message +;; custom-error + + +(provide 'custom-print) +;; Abbreviated package name: "CP" + +;;(defvar print-length nil +;; "*Controls how many elements of a list, at each level, are printed. +;;This is defined by emacs.") + +(defvar print-level nil + "*Controls how many levels deep a nested data object will print. + +If nil, printing proceeds recursively and may lead to +max-lisp-eval-depth being exceeded or an untrappable error may occur: +\"Apparently circular structure being printed.\" Also see +print-length and print-circle. + +If non-nil, components at levels equal to or greater than print-level +are printed simply as \"#\". The object to be printed is at level 0, +and if the object is a list or vector, its top-level components are at +level 1.") + + +(defvar print-circle nil + "*Controls the printing of recursive structures. + +If nil, printing proceeds recursively and may lead to +max-lisp-eval-depth being exceeded or an untrappable error may occur: +\"Apparently circular structure being printed.\" Also see +print-length and print-level. + +If non-nil, shared substructures anywhere in the structure are printed +with \"#n=\" before the first occurance (in the order of the print +representation) and \"#n#\" in place of each subsequent occurance, +where n is a positive decimal integer. + +Currently, there is no way to read this representation in Emacs.") + + +(defconst custom-print-list + nil + ;; e.g. '((floatp . float-to-string)) + "If non-nil, an alist for printing of custom list objects. +Pairs are of the form (pred . converter). If the predicate is true +for an object, the converter is called with the object and should +return a string which will be printed with princ. +Also see custom-print-vector.") + +(defconst custom-print-vector + nil + "If non-nil, an alist for printing of custom vector objects. +Pairs are of the form (pred . converter). If the predicate is true +for an object, the converter is called with the object and should +return a string which will be printed with princ. +Also see custom-print-list.") + + +(defun add-custom-print-list (pred converter) + "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list. +Any pair that has the same PREDICATE is first removed." + (setq custom-print-list (cons (cons pred converter) + (delq (assq pred custom-print-list) + custom-print-list)))) +;; e.g. (add-custom-print-list 'floatp 'float-to-string) + + +(defun add-custom-print-vector (pred converter) + "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector. +Any pair that has the same PREDICATE is first removed." + (setq custom-print-vector (cons (cons pred converter) + (delq (assq pred custom-print-vector) + custom-print-vector)))) + + +;;==================================================== +;; Saving and restoring internal printing routines. + +(defun CP::set-function-cell (symbol-pair) + (fset (car symbol-pair) + (symbol-function (car (cdr symbol-pair))))) + + +(if (not (fboundp 'CP::internal-prin1)) + (mapcar 'CP::set-function-cell + '((CP::internal-prin1 prin1) + (CP::internal-princ princ) + (CP::internal-print print) + (CP::internal-prin1-to-string prin1-to-string) + (CP::internal-format format) + (CP::internal-message message) + (CP::internal-error error)))) + + +(defun install-custom-print-funcs () + "Replace print functions with general, customizable, lisp versions. +The internal subroutines are saved away and may be recovered with +uninstall-custom-print-funcs." + (interactive) + (mapcar 'CP::set-function-cell + '((prin1 custom-prin1) + (princ custom-princ) + (print custom-print) + (prin1-to-string custom-prin1-to-string) + (format custom-format) + (message custom-message) + (error custom-error) + ))) + +(defun uninstall-custom-print-funcs () + "Reset print functions to their internal subroutines." + (interactive) + (mapcar 'CP::set-function-cell + '((prin1 CP::internal-prin1) + (princ CP::internal-princ) + (print CP::internal-print) + (prin1-to-string CP::internal-prin1-to-string) + (format CP::internal-format) + (message CP::internal-message) + (error CP::internal-error) + ))) + + +;;=============================================================== +;; Lisp replacements for prin1 and princ and for subrs that use prin1 +;; (or princ) -- so far only the printing and formatting subrs. + +(defun custom-prin1 (object &optional stream) + "Replacement for standard prin1 that uses the appropriate +printer depending on the values of print-level and print-circle (which see). + +Output the printed representation of OBJECT, any Lisp object. +Quoting characters are printed when needed to make output that `read' +can handle, whenever this is possible. +Output stream is STREAM, or value of `standard-output' (which see)." + (CP::top-level object stream 'CP::internal-prin1)) + + +(defun custom-princ (object &optional stream) + "Same as custom-prin1 except no quoting." + (CP::top-level object stream 'CP::internal-princ)) + +(defun custom-prin1-to-string-func (c) + "Stream function for custom-prin1-to-string." + (setq prin1-chars (cons c prin1-chars))) + +(defun custom-prin1-to-string (object) + "Replacement for standard prin1-to-string." + (let ((prin1-chars nil)) + (custom-prin1 object 'custom-prin1-to-string-func) + (concat (nreverse prin1-chars)))) + + +(defun custom-print (object &optional stream) + "Replacement for standard print." + (CP::internal-princ "\n") + (custom-prin1 object stream) + (CP::internal-princ "\n")) + + +(defun custom-format (fmt &rest args) + "Replacement for standard format. + +Calls format after first making strings for list or vector args. +The format specification for such args should be %s in any case, so a +string argument will also work. The string is generated with +custom-prin1-to-string, which quotes quotable characters." + (apply 'CP::internal-format fmt + (mapcar (function (lambda (arg) + (if (or (listp arg) (vectorp arg)) + (custom-prin1-to-string arg) + arg))) + args))) + + + +(defun custom-message (fmt &rest args) + "Replacement for standard message that works like custom-format." + ;; It doesnt work to princ the result of custom-format + ;; because the echo area requires special handling + ;; to avoid duplicating the output. CP::internal-message does it right. + ;; (CP::internal-princ (apply 'custom-format fmt args)) + (apply 'CP::internal-message fmt + (mapcar (function (lambda (arg) + (if (or (listp arg) (vectorp arg)) + (custom-prin1-to-string arg) + arg))) + args))) + + +(defun custom-error (fmt &rest args) + "Replacement for standard error that uses custom-format" + (signal 'error (list (apply 'custom-format fmt args)))) + + +;;========================================= +;; Support for custom prin1 and princ + +(defun CP::top-level (object stream internal-printer) + "Set up for printing." + (let ((standard-output (or stream standard-output)) + (circle-table (and print-circle (CP::preprocess-circle-tree object))) + (level (or print-level -1)) + ) + + (fset 'CP::internal-printer internal-printer) + (fset 'CP::low-level-prin + (cond + ((or custom-print-list + custom-print-vector + print-level ; comment out for version 19 + ) + 'CP::custom-object) + (circle-table + 'CP::object) + (t 'CP::internal-printer))) + (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin)) + + (CP::prin object) + object)) + + +(defun CP::object (object) + "Test object type and print accordingly." + ;; Could be called as either CP::low-level-prin or CP::prin. + (cond + ((null object) (CP::internal-printer object)) + ((consp object) (CP::list object)) + ((vectorp object) (CP::vector object)) + ;; All other types, just print. + (t (CP::internal-printer object)))) + + +(defun CP::custom-object (object) + "Test object type and print accordingly." + ;; Could be called as either CP::low-level-prin or CP::prin. + (cond + ((null object) (CP::internal-printer object)) + + ((consp object) + (or (and custom-print-list + (CP::custom-object1 object custom-print-list)) + (CP::list object))) + + ((vectorp object) + (or (and custom-print-vector + (CP::custom-object1 object custom-print-vector)) + (CP::vector object))) + + ;; All other types, just print. + (t (CP::internal-printer object)))) + + +(defun CP::custom-object1 (object alist) + "Helper for CP::custom-object. +Print the custom OBJECT using the custom type ALIST. +For the first predicate that matches the object, the corresponding +converter is evaluated with the object and the string that results is +printed with princ. Return nil if no predicte matches the object." + (while (and alist (not (funcall (car (car alist)) object))) + (setq alist (cdr alist))) + ;; If alist is not null, then something matched. + (if alist + (CP::internal-princ + (funcall (cdr (car alist)) object) ; returns string + ))) + + +(defun CP::circular (object) + "Printer for prin1 and princ that handles circular structures. +If OBJECT appears multiply, and has not yet been printed, +prefix with label; if it has been printed, use #n# instead. +Otherwise, print normally." + (let ((tag (assq object circle-table))) + (if tag + (let ((id (cdr tag))) + (if (> id 0) + (progn + ;; Already printed, so just print id. + (CP::internal-princ "#") + (CP::internal-princ id) + (CP::internal-princ "#")) + ;; Not printed yet, so label with id and print object. + (setcdr tag (- id)) ; mark it as printed + (CP::internal-princ "#") + (CP::internal-princ (- id)) + (CP::internal-princ "=") + (CP::low-level-prin object) + )) + ;; Not repeated in structure. + (CP::low-level-prin object)))) + + +;;================================================ +;; List and vector processing for print functions. + +(defun CP::list (list) + "Print a list using print-length, print-level, and print-circle." + (if (= level 0) + (CP::internal-princ "#") + (let ((level (1- level))) + (CP::internal-princ "(") + (let ((length (or print-length 0))) + + ;; Print the first element always (even if length = 0). + (CP::prin (car list)) + (setq list (cdr list)) + (if list (CP::internal-princ " ")) + (setq length (1- length)) + + ;; Print the rest of the elements. + (while (and list (/= 0 length)) + (if (and (listp list) + (not (assq list circle-table))) + (progn + (CP::prin (car list)) + (setq list (cdr list))) + + ;; cdr is not a list, or it is in circle-table. + (CP::internal-princ ". ") + (CP::prin list) + (setq list nil)) + + (setq length (1- length)) + (if list (CP::internal-princ " "))) + + (if (and list (= length 0)) (CP::internal-princ "...")) + (CP::internal-princ ")")))) + list) + + +(defun CP::vector (vector) + "Print a vector using print-length, print-level, and print-circle." + (if (= level 0) + (CP::internal-princ "#") + (let ((level (1- level)) + (i 0) + (len (length vector))) + (CP::internal-princ "[") + + (if print-length + (setq len (min print-length len))) + ;; Print the elements + (while (< i len) + (CP::prin (aref vector i)) + (setq i (1+ i)) + (if (< i (length vector)) (CP::internal-princ " "))) + + (if (< i (length vector)) (CP::internal-princ "...")) + (CP::internal-princ "]") + )) + vector) + + +;;================================== +;; Circular structure preprocessing + +(defun CP::preprocess-circle-tree (object) + ;; Fill up the table. + (let (;; Table of tags for each object in an object to be printed. + ;; A tag is of the form: + ;; ( <object> <nil-t-or-id-number> ) + ;; The id-number is generated after the entire table has been computed. + ;; During walk through, the real circle-table lives in the cdr so we + ;; can use setcdr to add new elements instead of having to setq the + ;; variable sometimes (poor man's locf). + (circle-table (list nil))) + (CP::walk-circle-tree object) + + ;; Reverse table so it is in the order that the objects will be printed. + ;; This pass could be avoided if we always added to the end of the + ;; table with setcdr in walk-circle-tree. + (setcdr circle-table (nreverse (cdr circle-table))) + + ;; Walk through the table, assigning id-numbers to those + ;; objects which will be printed using #N= syntax. Delete those + ;; objects which will be printed only once (to speed up assq later). + (let ((rest circle-table) + (id -1)) + (while (cdr rest) + (let ((tag (car (cdr rest)))) + (cond ((cdr tag) + (setcdr tag id) + (setq id (1- id)) + (setq rest (cdr rest))) + ;; Else delete this object. + (t (setcdr rest (cdr (cdr rest)))))) + )) + ;; Drop the car. + (cdr circle-table) + )) + + + +(defun CP::walk-circle-tree (object) + (let (read-equivalent-p tag) + (while object + (setq read-equivalent-p (or (numberp object) (symbolp object)) + tag (and (not read-equivalent-p) + (assq object (cdr circle-table)))) + (cond (tag + ;; Seen this object already, so note that. + (setcdr tag t)) + + ((not read-equivalent-p) + ;; Add a tag for this object. + (setcdr circle-table + (cons (list object) + (cdr circle-table))))) + (setq object + (cond + (tag ;; No need to descend since we have already. + nil) + + ((consp object) + ;; Walk the car of the list recursively. + (CP::walk-circle-tree (car object)) + ;; But walk the cdr with the above while loop + ;; to avoid problems with max-lisp-eval-depth. + ;; And it should be faster than recursion. + (cdr object)) + + ((vectorp object) + ;; Walk the vector. + (let ((i (length object)) + (j 0)) + (while (< j i) + (CP::walk-circle-tree (aref object j)) + (setq j (1+ j)))))))))) + + + +;;======================================= + +(quote + examples + + (progn + ;; Create some circular structures. + (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x))) + (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)) + (setcar (nthcdr 3 circ-list) circ-list) + (aset (nth 2 circ-list) 2 circ-list) + (setq dotted-circ-list (list 'a 'b 'c)) + (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list) + (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7)) + (aset circ-vector 5 (make-symbol "-gensym-")) + (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5)) + nil) + + (install-custom-print-funcs) + ;; (setq print-circle t) + + (let ((print-circle t)) + (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)") + (error "circular object with array printing"))) + + (let ((print-circle t)) + (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)") + (error "circular object with array printing"))) + + (let* ((print-circle t) + (x (list 'p 'q)) + (y (list (list 'a 'b) x 'foo x))) + (setcdr (cdr (cdr (cdr y))) (cdr y)) + (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))" + ) + (error "circular list example from CL manual"))) + + ;; There's no special handling of uninterned symbols in custom-print. + (let ((print-circle nil)) + (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)") + (error "uninterned symbols in list"))) + (let ((print-circle t)) + (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)") + (error "circular uninterned symbols in list"))) + + (uninstall-custom-print-funcs) + ) + +;;; cus-print.el ends here diff --git a/lisp/emacs-lisp/profile.el b/lisp/emacs-lisp/profile.el new file mode 100644 index 0000000000..1ce056f912 --- /dev/null +++ b/lisp/emacs-lisp/profile.el @@ -0,0 +1,355 @@ +;;; profile.el -- generate run time measurements of elisp functions +;;; +;;; Author: Boaz Ben-Zvi <[email protected]> +;;; Created: Feb. 7, 1992 +;;; Last Modified: Feb. 7, 1992 +;;; Version: 1.0 + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +; DESCRIPTION: +; ------------ +; This program can be used to monitor running time performance of elisp +; functions. It takes a list of functions and report the real time spent +; inside these functions. It runs a process with a separate timer program. +; Caveat: the C code included with this package requires BSD-compatible +; time-of-day functions. If you're running an AT&T version prior to SVr4, +; you may have difficulty getting it to work. Your X library may supply +; the required routines if the standard C library does not. + +; HOW TO USE: +; ----------- +; Set the variable profile-functions-list to the list of functions +; (as symbols) You want to profile. Call M-x profile-functions to set +; this list on and start using your program. Note that profile-functions +; MUST be called AFTER all the functions in profile-functions-list have +; been loaded !! (This call modifies the code of the profiled functions. +; Hence if you reload these functions, you need to call profile-functions +; again! ). +; To display the results do M-x profile-results . For example: +;------------------------------------------------------------------- +; (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game +; sokoban-move-vertical sokoban-move)) +; (load "sokoban") +; M-x profile-functions +; ... I play the sokoban game .......... +; M-x profile-results +; +; Function Time (Seconds.Useconds) +; ======== ======================= +; sokoban-move 0.539088 +; sokoban-move-vertical 0.410130 +; sokoban-load-game 0.453235 +; sokoban-set-mode-line 1.949203 +;----------------------------------------------------- +; To clear all the settings to profile use profile-finish. +; To set one function at a time (instead of or in addition to setting the +; above list and M-x profile-functions ) use M-x profile-a-function . + +; HOW TO INSTALL: +; --------------- +; First you need to compile and install the following C program in your +; path under the name "emacs-timer" (or set the variable +; profile-timer-program to whatever name you picked). +; +;/** +; ** To be run as an emacs process. Input string that starts with: +; ** 'z' -- resets the watch (to zero). +; ** 'p' -- return time (on stdout) as string with format <sec>.<micro-sec> +; ** 'q' -- exit. +; ** +; ** abstraction : a stopwatch +; ** operations: reset_watch, get_time +; */ +;#include <strings.h> +;#include <sys/time.h> +;#include <stdio.h> +;static struct timeval TV1,TV2; +;static struct timezone *tzp = (struct timezone *) NULL; /* no need timezone */ +;static int watch_not_started = 1 ; /* flag */ +;static char time_string[30] +; +;int reset_watch() /* this call resets the stopwatch to zero */ +;{ +; gettimeofday(&TV1, tzp) ; +; watch_not_started = 0; +;} +; +;char *get_time() +; /* this call returns the time since the last reset_watch() call. The time +; is returned as a string with the format <seconds>.<micro-seconds> +; If reset_watch() was not called yet, returns NULL */ +;{ +; char *result = time_string ; +; int i; +; if (watch_not_started) return((char *) 0); /* call reset_watch first ! */ +; gettimeofday(&TV2, tzp); +; if ( TV1.tv_usec > TV2.tv_usec ) +; { +; TV2.tv_usec += 1000000; +; TV2.tv_sec--; +; } +; sprintf(result,"%lu.%6lu", +; TV2.tv_sec - TV1.tv_sec, TV2.tv_usec - TV1.tv_usec); +; for (result = index(result,'.') + 1 ; *result == ' ' ; result++ ) +; *result = '0'; +; return(time_string); +;} +; +;void main() +;{ +; char inp[10]; +; while (1) +; { +; gets(inp); +; switch (inp[0]) +; { +; case 'z': reset_watch(); +; break; +; case 'p': puts(get_time()); +; break; +; case 'q': exit(0); +; } +; } +;} +; -------- end of clip ---------------- + +;;; +;;; User modifiable VARIABLES +;;; + +(defvar profile-functions-list nil "*List of functions to profile") +(defvar profile-timer-program "emacs-timer" "*Name of the timer program") + +;;; +;;; V A R I A B L E S +;;; + +(defvar profile-timer-process nil "Process running the timer") +(defvar profile-time-list nil + "List of accumulative time for each profiled function") +(defvar profile-init-list nil + "List of entry time for each function. \n\ +Both how many times invoked and real time of start.") +(defvar profile-max-fun-name 0 "Max length of name of any function profiled") +(defvar profile-temp-result- nil "Should NOT be used anywhere else") +(defvar profile-time (cons 0 0) "Used to return result from a filter") +(defvar profile-buffer "*profile*" "Name of profile buffer") + +;;; +;;; F U N C T I O N S +;;; + +(defun profile-functions (&optional flist) + "Profile all the functions listed in profile-functions-list.\n\ +With argument FLIST, use the list FLIST instead." + (interactive "*P") + (if (null flist) (setq flist profile-functions-list)) + (mapcar 'profile-a-function flist)) + +(defun profile-filter (process input) + "Filter for the timer process. Sets profile-time to the returned time." + (if (zerop (string-match "\\." input)) + (error "Bad output from %s" profile-timer-program) + (setcar profile-time + (string-to-int (substring input 0 (match-beginning 0)))) + (setcdr profile-time + (string-to-int (substring input (match-end 0)))))) + + +(defun profile-print (entry) + "Print one ENTRY (from profile-time-list) ." + (let ((time (cdr entry)) str (offset 5)) + (insert (format "%s" (car entry)) space) + (move-to-column ref-column) + (setq str (int-to-string (car time))) + (insert str) + (if (>= (length str) offset) nil + (move-to-column ref-column) + (insert (substring spaces 0 (- offset (length str)))) + (forward-char (length str))) + (setq str (int-to-string (cdr time))) + (insert "." (substring "000000" 0 (- 6 (length str))) str "\n") + )) + +(defconst spaces " ") + +(defun profile-results () + "Display profiling results in profile-buffer ." + (interactive) + (let* ((ref-column (+ 8 profile-max-fun-name)) + (space (substring spaces 0 ref-column))) + (switch-to-buffer profile-buffer) + (erase-buffer) + (insert "Function" space) + (move-to-column ref-column) + (insert "Time (Seconds.Useconds)\n" "========" space ) + (move-to-column ref-column) + (insert "=======================\n") + (mapcar 'profile-print profile-time-list))) + +(defun profile-reset-timer () + (process-send-string profile-timer-process "z\n")) + +(defun profile-check-zero-init-times (entry) + "If ENTRY has non zero time, give an error." + (let ((time (cdr (cdr entry)))) + (if (and (zerop (car time)) (zerop (cdr time))) nil ; OK + (error "Process timer died while making performance profile.")))) + +(defun profile-get-time () + "Get time from timer process into profile-time ." + ;; first time or if process dies + (if (and (processp profile-timer-process) + (eq 'run (process-status profile-timer-process))) nil + (setq profile-timer-process ;; [re]start the timer process + (start-process "timer" + (get-buffer-create profile-buffer) + profile-timer-program)) + (set-process-filter profile-timer-process 'profile-filter) + (process-kill-without-query profile-timer-process) + (profile-reset-timer) + ;; check if timer died during time measurement + (mapcar 'profile-check-zero-init-times profile-init-list)) + ;; make timer process return current time + (process-send-string profile-timer-process "p\n") + (accept-process-output)) + +(defun profile-find-function (fun flist) + "Linear search for FUN in FLIST ." + (if (null flist) nil + (if (eq fun (car (car flist))) (cdr (car flist)) + (profile-find-function fun (cdr flist))))) + +(defun profile-start-function (fun) + "On entry, keep current time for function FUN." + ;; assumes that profile-time contains the current time + (let ((init-time (profile-find-function fun profile-init-list))) + (if (null init-time) (error "Function %s missing from list" fun)) + (if (not (zerop (car init-time))) ;; is it a recursive call ? + (setcar init-time (1+ (car init-time))) + (setcar init-time 1) ; mark first entry + (setq init-time (cdr init-time)) + (setcar init-time (car profile-time)) + (setcdr init-time (cdr profile-time))) + )) + +(defconst profile-million 1000000) + +(defun profile-update-function (fun) + "When the call to the function FUN is finished, add its run time." + ;; assumes that profile-time contains the current time + (let ((init-time (profile-find-function fun profile-init-list)) + (accum (profile-find-function fun profile-time-list)) + sec usec) + (if (or (null init-time) + (null accum)) (error "Function %s missing from list" fun)) + (setcar init-time (1- (car init-time))) ; pop one level in recursion + (if (not (zerop (car init-time))) + nil ; in some recursion level, do not update accum. time + (setq init-time (cdr init-time)) + (setq sec (- (car profile-time) (car init-time)) + usec (- (cdr profile-time) (cdr init-time))) + (setcar init-time 0) ; reset time to check for error + (setcdr init-time 0) ; in case timer process dies + (if (>= usec 0) nil + (setq usec (+ usec profile-million)) + (setq sec (1- sec))) + (setcar accum (+ sec (car accum))) + (setcdr accum (+ usec (cdr accum))) + (if (< (cdr accum) profile-million) nil + (setcar accum (1+ (car accum))) + (setcdr accum (- (cdr accum) profile-million))) + ))) + +(defun profile-a-function (fun) + "Profile the function FUN" + (interactive "aFunction to profile: ") + (let ((def (symbol-function fun)) (funlen (length (symbol-name fun)))) + (if (eq (car def) 'lambda) nil + (error "To profile: %s must be a user-defined function" fun)) + (setq profile-time-list ; add a new entry + (cons (cons fun (cons 0 0)) profile-time-list)) + (setq profile-init-list ; add a new entry + (cons (cons fun (cons 0 (cons 0 0))) profile-init-list)) + (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen)) + (fset fun (profile-fix-fun fun def)))) + +(defun profile-fix-fun (fun def) + "Take function FUN and return it fixed for profiling.\n\ +DEF is (symbol-function FUN) ." + (let (prefix first second third (count 2) inter suffix) + (if (< (length def) 3) nil ; nothing to see + (setq first (car def) second (car (cdr def)) + third (car (nthcdr 2 def))) + (setq prefix (list first second)) + (if (and (stringp third) (< (length def) 3)) nil ; nothing to see + (if (not (stringp third)) (setq inter third) + (setq count 3 ; suffix to start after doc string + prefix (nconc prefix (list third)) + inter (car (nthcdr 3 def))) ; fourth sexp + ) + (if (not (and (listp inter) + (eq (car inter) 'interactive))) nil + (setq prefix (nconc prefix (list inter))) + (setq count (1+ count))) ; skip this sexp for suffix + (setq suffix (nthcdr count def)) + (if (equal (car suffix) '(profile-get-time)) nil ;; already set + ;; prepare new function + (nconc prefix + (list '(profile-get-time)) ; read time + (list (list 'profile-start-function + (list 'quote fun))) + (list (list 'setq 'profile-temp-result- + (nconc (list 'progn) suffix))) + (list '(profile-get-time)) ; read time + (list (list 'profile-update-function + (list 'quote fun))) + (list 'profile-temp-result-) + )))))) + +(defun profile-restore-fun (fun) + "Restore profiled function FUN to its original state." + (let ((def (symbol-function (car fun))) body index) + ;; move index beyond header + (setq index (cdr def)) + (if (stringp (car (cdr index))) (setq index (cdr index))) + (if (and (listp (car (cdr index))) + (eq (car (car (cdr index))) 'interactive)) + (setq index (cdr index))) + (setq body (car (nthcdr 3 index))) + (if (and (listp body) ; the right element ? + (eq (car (cdr body)) 'profile-temp-result-)) + (setcdr index (cdr (car (cdr (cdr body)))))))) + +(defun profile-finish () + "Stop profiling functions. Clear all the settings." + (interactive) + (mapcar 'profile-restore-fun profile-time-list) + (setq profile-max-fun-name 0) + (setq profile-time-list nil) + (setq profile-init-list nil)) + +(defun profile-quit () + "Kill the timer process." + (interactive) + (process-send-string profile-timer-process "q\n")) + +;; profile.el ends here |