Mercurial > emacs
annotate lisp/emacs-lisp/find-gc.el @ 78005:3049bd99b03e
* term/xterm.el (terminal-init-xterm): Escape parens in character
constants.
author | Dan Nicolaescu <dann@ics.uci.edu> |
---|---|
date | Wed, 13 Jun 2007 19:08:44 +0000 |
parents | 7a3f13e2dd57 |
children | 935157c0b596 95d0cdf160ea |
rev | line source |
---|---|
39027 | 1 ;;; find-gc.el --- detect functions that call the garbage collector |
2 | |
74466 | 3 ;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, |
75346 | 4 ;; 2006, 2007 Free Software Foundation, Inc. |
39027 | 5 |
6 ;; Maintainer: FSF | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
10 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 ;; it under the terms of the GNU General Public License as published by | |
12 ;; the Free Software Foundation; either version 2, or (at your option) | |
13 ;; any later version. | |
14 | |
15 ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 ;; GNU General Public License for more details. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
64085 | 22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02110-1301, USA. | |
39027 | 24 |
25 ;;; Commentary: | |
26 | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
27 ;; Produce in find-gc-unsafe-list the set of all functions that may invoke GC. |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
28 ;; This expects the Emacs sources to live in find-gc-source-directory. |
39027 | 29 ;; It creates a temporary working directory /tmp/esrc. |
30 | |
31 ;;; Code: | |
32 | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
33 (defvar find-gc-unsafe-list nil |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
34 "The list of unsafe functions is placed here by `find-gc-unsafe'.") |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
35 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
36 (defvar find-gc-source-directory) |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
37 |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
38 (defvar find-gc-subrs-callers nil |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
39 "Alist of users of subrs, from GC testing. |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
40 Each entry has the form (FUNCTION . FUNCTIONS-THAT-CALL-IT).") |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
41 |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
42 (defvar find-gc-subrs-called nil |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
43 "Alist of subrs called, in GC testing. |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
44 Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).") |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
45 |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
46 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
47 ;;; Functions on this list are safe, even if they appear to be able |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
48 ;;; to call the target. |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
49 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
50 (defvar find-gc-noreturn-list '(Fsignal Fthrow wrong_type_argument)) |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
51 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
52 ;;; This was originally generated directory-files, but there were |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
53 ;;; too many files there that were not actually compiled. The |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
54 ;;; list below was created for a HP-UX 7.0 system. |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
55 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
56 (defvar find-gc-source-files |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
57 '("dispnew.c" "scroll.c" "xdisp.c" "window.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
58 "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
59 "keymap.c" "sysdep.c" "buffer.c" "filelock.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
60 "insdel.c" "marker.c" "minibuf.c" "fileio.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
61 "dired.c" "filemode.c" "cmds.c" "casefiddle.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
62 "indent.c" "search.c" "regex.c" "undo.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
63 "alloc.c" "data.c" "doc.c" "editfns.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
64 "callint.c" "eval.c" "fns.c" "print.c" "lread.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
65 "abbrev.c" "syntax.c" "unexec.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
66 "bytecode.c" "process.c" "callproc.c" "doprnt.c" |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
67 "x11term.c" "x11fns.c")) |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
68 |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
69 |
39027 | 70 (defun find-gc-unsafe () |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
71 "Return a list of unsafe functions--that is, which can call GC. |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
72 Also store it in `find-gc-unsafe'." |
39027 | 73 (trace-call-tree nil) |
74 (trace-use-tree) | |
75 (find-unsafe-funcs 'Fgarbage_collect) | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
76 (setq find-gc-unsafe-list |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
77 (sort find-gc-unsafe-list |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
78 (function (lambda (x y) |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
79 (string-lessp (car x) (car y)))))) |
39027 | 80 ) |
81 | |
82 ;;; This does a depth-first search to find all functions that can | |
83 ;;; ultimately call the function "target". The result is an a-list | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
84 ;;; in find-gc-unsafe-list; the cars are the unsafe functions, and the cdrs |
39027 | 85 ;;; are (one of) the unsafe functions that these functions directly |
86 ;;; call. | |
87 | |
88 (defun find-unsafe-funcs (target) | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
89 (setq find-gc-unsafe-list (list (list target))) |
39027 | 90 (trace-unsafe target) |
91 ) | |
92 | |
93 (defun trace-unsafe (func) | |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
94 (let ((used (assq func find-gc-subrs-callers))) |
39027 | 95 (or used |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
96 (error "No find-gc-subrs-callers for %s" (car find-gc-unsafe-list))) |
39027 | 97 (while (setq used (cdr used)) |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
98 (or (assq (car used) find-gc-unsafe-list) |
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
99 (memq (car used) find-gc-noreturn-list) |
39027 | 100 (progn |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
101 (push (cons (car used) func) find-gc-unsafe-list) |
39027 | 102 (trace-unsafe (car used)))))) |
103 ) | |
104 | |
105 | |
106 | |
107 | |
108 (defun trace-call-tree (&optional already-setup) | |
109 (message "Setting up directories...") | |
110 (or already-setup | |
111 (progn | |
112 ;; Gee, wouldn't a built-in "system" function be handy here. | |
113 (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc") | |
114 (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc") | |
115 (call-process "csh" nil nil nil "-c" | |
116 (format "ln -s %s/*.[ch] /tmp/esrc" | |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
117 find-gc-source-directory)))) |
39027 | 118 (save-excursion |
119 (set-buffer (get-buffer-create "*Trace Call Tree*")) | |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
120 (setq find-gc-subrs-called nil) |
39027 | 121 (let ((case-fold-search nil) |
64380
ce8784010c3c
(find-gc-unsafe-list, find-gc-source-directory, find-gc-subrs-used)
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
122 (files find-gc-source-files) |
39027 | 123 name entry) |
124 (while files | |
125 (message "Compiling %s..." (car files)) | |
126 (call-process "csh" nil nil nil "-c" | |
127 (format "gcc -dr -c /tmp/esrc/%s -o /dev/null" | |
128 (car files))) | |
129 (erase-buffer) | |
130 (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl")) | |
131 (while (re-search-forward ";; Function \\|(call_insn " nil t) | |
132 (if (= (char-after (- (point) 3)) ?o) | |
133 (progn | |
134 (looking-at "[a-zA-Z0-9_]+") | |
135 (setq name (intern (buffer-substring (match-beginning 0) | |
136 (match-end 0)))) | |
137 (message "%s : %s" (car files) name) | |
138 (setq entry (list name) | |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
139 find-gc-subrs-called (cons entry find-gc-subrs-called))) |
39027 | 140 (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") |
141 (progn | |
142 (setq name (intern (buffer-substring (match-beginning 1) | |
143 (match-end 1)))) | |
144 (or (memq name (cdr entry)) | |
145 (setcdr entry (cons name (cdr entry)))))))) | |
146 (delete-file (concat "/tmp/esrc/" (car files) ".rtl")) | |
147 (setq files (cdr files))))) | |
148 ) | |
149 | |
150 | |
151 (defun trace-use-tree () | |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
152 (setq find-gc-subrs-callers (mapcar 'list (mapcar 'car find-gc-subrs-called))) |
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
153 (let ((ptr find-gc-subrs-called) |
39027 | 154 p2 found) |
155 (while ptr | |
156 (setq p2 (car ptr)) | |
157 (while (setq p2 (cdr p2)) | |
64403
db69241fec2b
(find-gc-subrs-callers): Renamed from find-gc-subrs-used.
Richard M. Stallman <rms@gnu.org>
parents:
64380
diff
changeset
|
158 (if (setq found (assq (car p2) find-gc-subrs-callers)) |
39027 | 159 (setcdr found (cons (car (car ptr)) (cdr found))))) |
160 (setq ptr (cdr ptr)))) | |
161 ) | |
162 | |
163 (provide 'find-gc) | |
164 | |
52401 | 165 ;;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 |
39027 | 166 ;;; find-gc.el ends here |