view lisp/emacs-lisp/profile.el @ 10219:d97313bb6f39

(bibtex-string, bibtex-preamble): Use forward-line. (sort-subr): Don't call autload for this--that's done in loaddefs.el. (bibtex-mode): Add autoload cookie. Changed keybinding for bibtex-print-help-message (from \C-ch to \C-c?). Therefore, describe-mode is not longer on \C-c?. Also, changed prefix \C-cn for bibtex-narrow functions to \C-c\C-r. (bibtex-string-files): Changed documentation. (bibtex-mode-map): Inscriptions of menu bar changed from "Entry Types" to "Entry-Types" and "Bibtex Edit" to "BibTeX-Edit". (bibtex-string-files): Changed documentation. (bibtex-mode): If environment variable BIBINPUTS isn't defined, string files are searched in the current directory. (bibtex-completion-candidates): Now buffer-local to allow evaluation of different bibtex-string-files in different buffers. (bibtex-autokey-edit-before-use, bibtex-clean-entry): New variable that determines, if the user is allowed to edit auto-generated reference keys before they are used. (bibtex-generate-autokey, bibtex-clean-entry): New function to generate an autokey if necessary. (bibtex-autokey-names, bibtex-autokey-name-change-strings, bibtex-autokey-name-length, bibtex-autokey-name-separator, bibtex-autokey-year-length, bibtex-autokey-titlewords, bibtex-autokey-title-terminators, bibtex-autokey-titlewords-stretch, bibtex-autokey-titleword-first-ignore, bibtex-autokey-titleword-abbrevs, bibtex-autokey-titleword-change-strings, bibtex-autokey-titleword-length, bibtex-autokey-titleword-separator, bibtex-autokey-name-year-separator, bibtex-autokey-year-title-separator): New variables related to bibtex-generate-autokey. (bibtex-find-entry-location): Optional second parameter maybedup to tell it that entering a duplicate entry isn't to report by an error but by the return value of the function (necessary for bibtex-clean-entry to find the correct position of an entry with an autogenerated key without disturbing the user with unwanted messages). (bibtex-help-message): New variable to avoid printing of help messages in the echo area. (assoc-of-regexp): New function to match an alist of regexps. (bibtex-string-files, bibtex-completion-candidates, bibtex-mode): New variables to allow bibtex-complete-string to work on strings initialized from a variable and from @String definitions in a list of files, too. (bibtex-predefined-strings, bibtex-entry-field-alist): Changed to user options. (bibtex-mode): Changed doc string. (many functions and variables): Changed documentation strings of variables and functions to hold a complete sentence in the first line. (bibtex-print-help-message): Now line dependent and reports if it is called outside a BibTeX field. (validate-bibtex-buffer): Completely rewritten to validate, if buffer is syntactically correct. (find-bibtex-duplicates): Moved into validate-bibtex-buffer. (ispell-abstract, bibtex-ispell-abstract, ispell-bibtex-entry, bibtex-ispell-entry, beginning-of-bibtex-entry, bibtex-beginning-of-entry, end-of-bibtex-entry, bibtex-end-of-entry, hide-bibtex-entry-bodies, bibtex-hide-entry-bodies, narrow-to-bibtex-entry, bibtex-narrow-to-entry, sort-bibtex-entries, bibtex-sort-entries, validate-bibtex-buffer, bibtex-validate-buffer, find-bibtex-entry-location, bibtex-find-entry-location): All interactive functions are renamed, so that any interface function begins with "bibtex-". Mapping: ispell-abstract --> bibtex-ispell-abstract ispell-bibtex-entry --> bibtex-ispell-entry beginning-of-bibtex-entry --> bibtex-beginning-of-entry end-of-bibtex-entry --> bibtex-end-of-entry hide-bibtex-entry-bodies --> bibtex-hide-entry-bodies narrow-to-bibtex-entry --> bibtex-narrow-to-entry sort-bibtex-entries --> bibtex-sort-entries validate-bibtex-buffer --> bibtex-validate-buffer find-bibtex-entry-location --> bibtex-find-entry-location (bibtex-maintain-sorted-entries, bibtex-sort-ignore-string-entries): Default is now t. (bibtex-complete-string): String list is built from additional string list bibtex-predefined-string and current strings in file. (string-equalp): Deleted and substituted by string-equal. (assoc-string-equalp): Renamed to assoc-ignore-case. (bibtex-entry): Reference key can be entered with completion. All reference keys that are defined in buffer and all labels that appear in crossreference entries are object to completion. (Entry types): Changed order of entries in menu "entry types". (bibtex-entry-field-alist): Changed order of entries slightly to be more conform with standard BibTeX style layouts. (bibtex-mode-map): Uniform keybindings for \C-c\C-e prefix (often used types on control keys, sometimes used types on normal keys, rarely used types on shift keys, almost never used types on meta keys). (bibtex-mode-map): Function narrow-to-bibtex-entry and counterpart widen and function hide-bibtex-entry-bodies and counterpart show-all bounded to appropriate local keys. (bibtex-abbrev-table): Deleted (bibtex-current-entry-label, put-string-on-kill-ring): Deleted (AUCTeX provides all the functionality needed for citation completion). (bibtex-enclosing-reference, bibtex-pop-previous, bibtex-pop-next, bibtex-clean-entry): Hacked for speed (bibtex-pop-previous and bibtex-pop-next were to slow for larger BibTeX files). (bibtex-pop-previous, bibtex-pop-next): Delimiters from previous or next entry are changed to actual delimters if necessary. (bibtex-entry): Fixed bug (False entry wasn't reported in error message if bibtex-entry was called with undefined reference name). (bibtex-entry-field-alist, bibtex-entry, bibtex-make-field, bibtex-next-field, bibtex-clean-entry): Every reference entry now contains a comment in addition to the name of the reference. This comment appears in the echo area if you start editing that field (after calling bibtex-next-field). (bibtex-include-OPTcrossref, bibtex-entry): Changed bibtex-include-OPTcrossref from single boolean variable to hold a list of reference names which should have a crossref field. (bibtex-complete-word): New function, which completes word fragment before point to the longest prefix of predefined strings in the buffer in the same way that ispell-complete-word operates for words found in the dictionary. (bibtex-reference-head): Start of bibtex-reference-head changed from "^[ \t]*\\(" to "^\\( \\|\t\\)*\\(" (bibtex-pop-previous and bibtex-pop-next didn't work, probably due to a bug in re-search-forward). (several functions): Added support for {} as field delimiters (better than '"' for accented characters. (bibtex-clean-entry): If optional field crossref is empty or missing, former optional fields (if bibtex-include-OPTcrossref was t) are necessary again. bibtex-clean-entry complains if they are empty but not if they are missing, so you can intenionally omit them, e. g. for a pseudo @Journal entry (needed for crossreferences) made out of an @article with missing non-optional fields. Menu bar entries aren't centered anymore.

;;; profile.el --- generate run time measurements of Emacs Lisp functions

;; Copyright (C) 1992, 1994 Free Software Foundation, Inc.

;; Author: Boaz Ben-Zvi <[e-mail]>
;; Created: 07 Feb 1992
;; Version: 1.0
;; Adapted-By: ESR
;; Keywords: lisp, tools

;; 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 2, 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.

;;; Commentary:

; DESCRIPTION:
; ------------
;   This program can be used to monitor running time performance of Emacs Lisp
; 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 in ../lib-src/profile.c 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.

;;; Code:

;;;
;;;  User modifiable VARIABLES
;;;

(defvar profile-functions-list nil "*List of functions to profile.")
(defvar profile-timer-program
  (concat exec-directory "profile")
  "*Name of the profile 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 the buffer `*profile*'.
\(The buffer name comes from `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