Mercurial > emacs
annotate lisp/find-gc.el @ 24419:30e478cd167e
(shell-command-default-error-buffer): Renamed from
shell-command-on-region-default-error-buffer.
(shell-command-on-region): Mention in echo area when there
is some error output. Mention success or failure, too.
Accumulate multiple error outputs
going forward, with formfeed in between. Display the error buffer
when we have put something in it.
(shell-command): Add the ERROR-BUFFER argument feature.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Mon, 01 Mar 1999 03:19:32 +0000 |
parents | 11218164bc54 |
children |
rev | line source |
---|---|
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
1 ;;; find-gc.el --- detect functions that call the garbage collector |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
2 |
845 | 3 ;; Copyright (C) 1992 Free Software Foundation, Inc. |
4 | |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
5 ;; Maintainer: FSF |
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
6 |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
7 ;; This file is part of GNU Emacs. |
123 | 8 |
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
9 ;; GNU Emacs is free software; you can redistribute it and/or modify |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
10 ;; it under the terms of the GNU General Public License as published by |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
11 ;; the Free Software Foundation; either version 2, or (at your option) |
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
12 ;; any later version. |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
13 |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
14 ;; GNU Emacs is distributed in the hope that it will be useful, |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
17 ;; GNU General Public License for more details. |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
18 |
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
19 ;; You should have received a copy of the GNU General Public License |
14169 | 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
123 | 23 |
2230
6314334d7c2b
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
24 ;;; Commentary: |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
662
diff
changeset
|
25 |
14169 | 26 ;; Produce in unsafe-list the set of all functions that may invoke GC. |
27 ;; This expects the Emacs sources to live in emacs-source-directory. | |
28 ;; It creates a temporary working directory /tmp/esrc. | |
123 | 29 |
2230
6314334d7c2b
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
30 ;;; Code: |
6314334d7c2b
Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
31 |
123 | 32 (defun find-gc-unsafe () |
33 (trace-call-tree nil) | |
34 (trace-use-tree) | |
35 (find-unsafe-funcs 'Fgarbage_collect) | |
36 (setq unsafe-list (sort unsafe-list | |
37 (function (lambda (x y) | |
38 (string-lessp (car x) (car y)))))) | |
39 ) | |
40 | |
41 (setq emacs-source-directory "/usr/gnu/src/dist/src") | |
42 | |
43 | |
44 ;;; This does a depth-first search to find all functions that can | |
45 ;;; ultimately call the function "target". The result is an a-list | |
46 ;;; in unsafe-list; the cars are the unsafe functions, and the cdrs | |
47 ;;; are (one of) the unsafe functions that these functions directly | |
48 ;;; call. | |
49 | |
50 (defun find-unsafe-funcs (target) | |
51 (setq unsafe-list (list (list target))) | |
52 (trace-unsafe target) | |
53 ) | |
54 | |
55 (defun trace-unsafe (func) | |
56 (let ((used (assq func subrs-used))) | |
57 (or used | |
58 (error "No subrs-used for %s" (car unsafe-list))) | |
59 (while (setq used (cdr used)) | |
60 (or (assq (car used) unsafe-list) | |
61 (memq (car used) noreturn-list) | |
62 (progn | |
63 (setq unsafe-list (cons (cons (car used) func) unsafe-list)) | |
64 (trace-unsafe (car used)))))) | |
65 ) | |
66 | |
67 | |
68 ;;; Functions on this list are safe, even if they appear to be able | |
69 ;;; to call the target. | |
70 | |
71 (setq noreturn-list '( Fsignal Fthrow wrong_type_argument )) | |
72 | |
73 | |
74 ;;; This produces an a-list of functions in subrs-called. The cdr of | |
75 ;;; each entry is a list of functions which the function in car calls. | |
76 | |
77 (defun trace-call-tree (&optional already-setup) | |
78 (message "Setting up directories...") | |
79 (or already-setup | |
80 (progn | |
81 ;; Gee, wouldn't a built-in "system" function be handy here. | |
82 (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc") | |
83 (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc") | |
84 (call-process "csh" nil nil nil "-c" | |
85 (format "ln -s %s/*.[ch] /tmp/esrc" | |
86 emacs-source-directory)))) | |
87 (save-excursion | |
88 (set-buffer (get-buffer-create "*Trace Call Tree*")) | |
89 (setq subrs-called nil) | |
90 (let ((case-fold-search nil) | |
91 (files source-files) | |
92 name entry) | |
93 (while files | |
94 (message "Compiling %s..." (car files)) | |
95 (call-process "csh" nil nil nil "-c" | |
96 (format "gcc -dr -c /tmp/esrc/%s -o /dev/null" | |
97 (car files))) | |
98 (erase-buffer) | |
99 (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl")) | |
100 (while (re-search-forward ";; Function \\|(call_insn " nil t) | |
101 (if (= (char-after (- (point) 3)) ?o) | |
102 (progn | |
103 (looking-at "[a-zA-Z0-9_]+") | |
104 (setq name (intern (buffer-substring (match-beginning 0) | |
105 (match-end 0)))) | |
106 (message "%s : %s" (car files) name) | |
107 (setq entry (list name) | |
108 subrs-called (cons entry subrs-called))) | |
109 (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") | |
110 (progn | |
111 (setq name (intern (buffer-substring (match-beginning 1) | |
112 (match-end 1)))) | |
113 (or (memq name (cdr entry)) | |
114 (setcdr entry (cons name (cdr entry)))))))) | |
115 (delete-file (concat "/tmp/esrc/" (car files) ".rtl")) | |
116 (setq files (cdr files))))) | |
117 ) | |
118 | |
119 | |
120 ;;; This was originally generated directory-files, but there were | |
121 ;;; too many files there that were not actually compiled. The | |
122 ;;; list below was created for a HP-UX 7.0 system. | |
123 | |
124 (setq source-files '("dispnew.c" "scroll.c" "xdisp.c" "window.c" | |
125 "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c" | |
126 "keymap.c" "sysdep.c" "buffer.c" "filelock.c" | |
127 "insdel.c" "marker.c" "minibuf.c" "fileio.c" | |
128 "dired.c" "filemode.c" "cmds.c" "casefiddle.c" | |
129 "indent.c" "search.c" "regex.c" "undo.c" | |
130 "alloc.c" "data.c" "doc.c" "editfns.c" | |
131 "callint.c" "eval.c" "fns.c" "print.c" "lread.c" | |
132 "abbrev.c" "syntax.c" "unexec.c" "mocklisp.c" | |
133 "bytecode.c" "process.c" "callproc.c" "doprnt.c" | |
134 "x11term.c" "x11fns.c")) | |
135 | |
136 | |
137 ;;; This produces an inverted a-list in subrs-used. The cdr of each | |
138 ;;; entry is a list of functions that call the function in car. | |
139 | |
140 (defun trace-use-tree () | |
141 (setq subrs-used (mapcar 'list (mapcar 'car subrs-called))) | |
142 (let ((ptr subrs-called) | |
143 p2 found) | |
144 (while ptr | |
145 (setq p2 (car ptr)) | |
146 (while (setq p2 (cdr p2)) | |
147 (if (setq found (assq (car p2) subrs-used)) | |
148 (setcdr found (cons (car (car ptr)) (cdr found))))) | |
149 (setq ptr (cdr ptr)))) | |
150 ) | |
151 | |
18383 | 152 (provide 'find-gc) |
153 | |
662
8a533acedb77
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
123
diff
changeset
|
154 ;;; find-gc.el ends here |