home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / profile.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  12KB  |  294 lines
  1. ;;; profile.el --- generate run time measurements of Emacs Lisp functions
  2.  
  3. ;; Copyright (C) 1992, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
  6. ;; Created: 07 Feb 1992
  7. ;; Version: 1.0
  8. ;; Adapted-By: ESR
  9. ;; Keywords: lisp, tools
  10.  
  11. ;; This file is part of GNU Emacs.
  12.  
  13. ;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;; it under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;; GNU General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  25. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;;; Commentary:
  28.  
  29. ; DESCRIPTION:
  30. ; ------------
  31. ;   This program can be used to monitor running time performance of Emacs Lisp
  32. ; functions. It takes a list of functions and report the real time spent 
  33. ; inside these functions. It runs a process with a separate timer program.
  34. ;   Caveat: the C code in ../lib-src/profile.c requires BSD-compatible
  35. ; time-of-day functions.  If you're running an AT&T version prior to SVr4,
  36. ; you may have difficulty getting it to work.  Your X library may supply
  37. ; the required routines if the standard C library does not.
  38.  
  39. ; HOW TO USE:
  40. ; -----------
  41. ;   Set the variable  profile-functions-list  to the list of functions
  42. ; (as symbols) You want to profile. Call  M-x  profile-functions to set 
  43. ; this list on and start using your program.  Note that profile-functions 
  44. ; MUST be called AFTER all the functions in profile-functions-list have 
  45. ; been loaded !!   (This call modifies the code of the profiled functions.
  46. ; Hence if you reload these functions, you need to call  profile-functions  
  47. ; again! ).
  48. ;   To display the results do  M-x  profile-results .  For example:
  49. ;-------------------------------------------------------------------
  50. ;  (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game 
  51. ;                              sokoban-move-vertical sokoban-move))
  52. ;  (load "sokoban")
  53. ;  M-x profile-functions
  54. ;     ...  I play the sokoban game ..........
  55. ;  M-x profile-results
  56. ;
  57. ;      Function                     Time (Seconds.Useconds)
  58. ;      ========                     =======================
  59. ;      sokoban-move                     0.539088
  60. ;      sokoban-move-vertical            0.410130
  61. ;      sokoban-load-game                0.453235
  62. ;      sokoban-set-mode-line            1.949203
  63. ;-----------------------------------------------------
  64. ; To clear all the settings to profile use profile-finish. 
  65. ; To set one function at a time (instead of or in addition to setting the 
  66. ; above list and  M-x profile-functions) use M-x profile-a-function.
  67.  
  68. ;;; Code:
  69.  
  70. ;;;
  71. ;;;  User modifiable VARIABLES
  72. ;;;
  73.  
  74. (defvar profile-functions-list nil "*List of functions to profile.")
  75. (defvar profile-timer-program
  76.   (concat exec-directory "profile")
  77.   "*Name of the profile timer program.")
  78.  
  79. ;;;
  80. ;;; V A R I A B L E S
  81. ;;;
  82.  
  83. (defvar profile-timer-process nil "Process running the timer.")
  84. (defvar profile-time-list nil 
  85.     "List of accumulative time for each profiled function.")
  86. (defvar profile-init-list nil
  87.     "List of entry time for each function. \n\
  88. Both how many times invoked and real time of start.")
  89. (defvar profile-max-fun-name 0 "Max length of name of any function profiled.")
  90. (defvar profile-temp-result- nil "Should NOT be used anywhere else.")
  91. (defvar profile-time (cons 0 0) "Used to return result from a filter.")
  92. (defvar profile-buffer "*profile*" "Name of profile buffer.")
  93.  
  94. ;;;
  95. ;;; F U N C T I O N S
  96. ;;;
  97.  
  98. (defun profile-functions (&optional flist)
  99.   "Profile all the functions listed in `profile-functions-list'.\n\
  100. With argument FLIST, use the list FLIST instead."
  101.   (interactive "*P")
  102.   (if (null flist) (setq flist profile-functions-list))
  103.   (mapcar 'profile-a-function flist))
  104.  
  105. (defun profile-filter (process input)
  106.   "Filter for the timer process.  Sets `profile-time' to the returned time."
  107.   (if (zerop (string-match "\\." input)) 
  108.       (error "Bad output from %s" profile-timer-program)
  109.     (setcar profile-time 
  110.         (string-to-int (substring input 0 (match-beginning 0))))
  111.     (setcdr profile-time 
  112.         (string-to-int (substring input (match-end 0))))))
  113.  
  114.  
  115. (defun profile-print (entry)
  116.   "Print one ENTRY (from `profile-time-list')."
  117.   (let ((time (cdr entry)) str (offset 5))
  118.     (insert (format "%s" (car entry)) space)
  119.     (move-to-column ref-column)
  120.     (setq str (int-to-string (car time)))
  121.     (insert str)
  122.     (if (>= (length str) offset) nil
  123.       (move-to-column ref-column)
  124.       (insert (substring spaces 0 (- offset (length str))))
  125.       (forward-char (length str)))
  126.     (setq str (int-to-string (cdr time)))
  127.     (insert "." (substring "000000" 0 (- 6 (length str))) str "\n")))
  128.  
  129. (defconst spaces "                                                         ")
  130.  
  131. (defun profile-results ()
  132.   "Display profiling results in the buffer `*profile*'.
  133. \(The buffer name comes from `profile-buffer'.)"
  134.   (interactive)
  135.   (let* ((ref-column (+ 8 profile-max-fun-name))
  136.      (space (substring spaces 0 ref-column)))
  137.     (switch-to-buffer profile-buffer)
  138.     (erase-buffer)
  139.     (insert "Function" space)
  140.     (move-to-column ref-column)
  141.     (insert "Time (Seconds.Useconds)\n" "========" space )
  142.     (move-to-column ref-column)
  143.     (insert    "=======================\n")
  144.     (mapcar 'profile-print profile-time-list)))
  145.     
  146. (defun profile-reset-timer ()
  147.   (process-send-string profile-timer-process "z\n"))
  148.  
  149. (defun profile-check-zero-init-times (entry)
  150.   "If ENTRY has non zero time, give an error."
  151.   (let ((time (cdr (cdr entry))))
  152.     (if (and (zerop (car time)) (zerop (cdr time))) nil ; OK
  153.       (error "Process timer died while making performance profile."))))
  154.  
  155. (defun profile-get-time ()
  156.   "Get time from timer process into `profile-time'."
  157.   ;; first time or if process dies
  158.   (if (and (processp profile-timer-process)
  159.        (eq 'run (process-status profile-timer-process))) nil
  160.     (setq profile-timer-process;; [re]start the timer process
  161.       (start-process "timer" 
  162.              (get-buffer-create profile-buffer) 
  163.              profile-timer-program))
  164.     (set-process-filter profile-timer-process 'profile-filter)
  165.     (process-kill-without-query profile-timer-process)
  166.     (profile-reset-timer)
  167.     ;; check if timer died during time measurement
  168.     (mapcar 'profile-check-zero-init-times profile-init-list)) 
  169.   ;; make timer process return current time
  170.   (process-send-string profile-timer-process "p\n")
  171.   (accept-process-output))
  172.  
  173. (defun profile-find-function (fun flist)
  174.   "Linear search for FUN in FLIST."
  175.   (if (null flist) nil
  176.     (if (eq fun (car (car flist))) (cdr (car flist))
  177.       (profile-find-function fun (cdr flist)))))
  178.  
  179. (defun profile-start-function (fun)
  180.   "On entry, keep current time for function FUN."
  181.   ;; assumes that profile-time contains the current time
  182.   (let ((init-time (profile-find-function fun profile-init-list)))
  183.     (if (null init-time) (error "Function %s missing from list" fun))
  184.     (if (not (zerop (car init-time)));; is it a recursive call ?
  185.     (setcar init-time (1+ (car init-time)))
  186.       (setcar init-time 1)        ; mark first entry
  187.       (setq init-time (cdr init-time))
  188.       (setcar init-time (car profile-time))
  189.       (setcdr init-time (cdr profile-time)))
  190.     ))
  191.     
  192. (defconst profile-million 1000000)
  193.  
  194. (defun profile-update-function (fun)
  195.   "When the call to the function FUN is finished, add its run time."
  196.   ;; assumes that profile-time contains the current time
  197.   (let ((init-time (profile-find-function fun profile-init-list))
  198.     (accum (profile-find-function fun profile-time-list))
  199.     sec usec)
  200.     (if (or (null init-time)
  201.         (null accum)) (error "Function %s missing from list" fun))
  202.     (setcar init-time (1- (car init-time))) ; pop one level in recursion
  203.     (if (not (zerop (car init-time))) 
  204.     nil                ; in some recursion level, do not update accum. time
  205.       (setq init-time (cdr init-time))
  206.       (setq sec (- (car profile-time) (car init-time))
  207.         usec (- (cdr profile-time) (cdr init-time)))
  208.       (setcar init-time 0)        ;  reset time to check for error
  209.       (setcdr init-time 0)        ;  in case timer process dies
  210.       (if (>= usec 0) nil
  211.     (setq usec (+ usec profile-million))
  212.     (setq sec (1- sec)))
  213.       (setcar accum (+ sec (car accum)))
  214.       (setcdr accum (+ usec (cdr accum)))
  215.       (if (< (cdr accum) profile-million) nil
  216.     (setcar accum (1+ (car accum)))
  217.     (setcdr accum (- (cdr accum) profile-million)))
  218.       )))
  219.  
  220. (defun profile-a-function (fun)
  221.   "Profile the function FUN."
  222.   (interactive "aFunction to profile: ")
  223.   (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
  224.     (if (eq (car def) 'lambda) nil
  225.       (error "To profile: %s must be a user-defined function" fun))
  226.     (setq profile-time-list        ; add a new entry
  227.       (cons (cons fun (cons 0 0)) profile-time-list))
  228.     (setq profile-init-list        ; add a new entry
  229.       (cons (cons fun (cons 0 (cons 0 0))) profile-init-list))
  230.     (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
  231.     (fset fun (profile-fix-fun fun def))))
  232.  
  233. (defun profile-fix-fun (fun def)
  234.   "Take function FUN and return it fixed for profiling.\n\
  235. DEF is (symbol-function FUN)."
  236.   (let (prefix first second third (count 2) inter suffix)
  237.     (if (< (length def) 3) nil        ; nothing to see
  238.       (setq first (car def) second (car (cdr def))
  239.         third (car (nthcdr 2 def)))
  240.       (setq prefix (list first second))
  241.       (if (and (stringp third) (< (length def) 3)) nil ; nothing to see
  242.     (if (not (stringp third))  (setq inter third) 
  243.       (setq count 3            ; suffix to start after doc string
  244.         prefix (nconc prefix (list third))
  245.         inter (car (nthcdr 3 def))) ; fourth sexp
  246.       )
  247.     (if (not (and (listp inter) 
  248.               (eq (car inter) 'interactive))) nil
  249.       (setq prefix (nconc prefix (list inter)))
  250.       (setq count (1+ count)))    ; skip this sexp for suffix
  251.     (setq suffix (nthcdr count def))
  252.     (if (equal (car suffix) '(profile-get-time)) nil;; already set
  253.       ;; prepare new function
  254.       (nconc prefix
  255.          (list '(profile-get-time)) ; read time
  256.          (list (list 'profile-start-function 
  257.                  (list 'quote fun)))
  258.          (list (list 'setq 'profile-temp-result- 
  259.                  (nconc (list 'progn) suffix)))
  260.          (list '(profile-get-time)) ; read time
  261.          (list (list 'profile-update-function 
  262.                  (list 'quote fun)))
  263.          (list 'profile-temp-result-)
  264.          ))))))
  265.  
  266. (defun profile-restore-fun (fun)
  267.   "Restore profiled function FUN to its original state."
  268.   (let ((def (symbol-function (car fun))) body index)
  269.     ;; move index beyond header
  270.     (setq index (cdr def))
  271.     (if (stringp (car (cdr index))) (setq index (cdr index)))
  272.     (if (and (listp (car (cdr index)))
  273.          (eq (car (car (cdr index))) 'interactive))
  274.     (setq index (cdr index)))
  275.     (setq body (car (nthcdr 3 index)))
  276.     (if (and (listp body)        ; the right element ?
  277.          (eq (car (cdr body)) 'profile-temp-result-))
  278.     (setcdr index (cdr (car (cdr (cdr body))))))))
  279.  
  280. (defun profile-finish ()
  281.   "Stop profiling functions.  Clear all the settings."
  282.   (interactive)
  283.   (mapcar 'profile-restore-fun profile-time-list)
  284.   (setq profile-max-fun-name 0)
  285.   (setq profile-time-list nil)
  286.   (setq profile-init-list nil))
  287.  
  288. (defun profile-quit ()
  289.   "Kill the timer process."
  290.   (interactive)
  291.   (process-send-string profile-timer-process "q\n"))
  292.  
  293. ;;; profile.el ends here
  294.