Mercurial > emacs

comparison lisp/emacs-lisp/find-gc.el @ 64403:db69241fec2b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(find-gc-subrs-callers): Renamed from find-gc-subrs-used. (find-gc-subrs-called): Renamed from subrs-called, and defvar'd.
author Richard M. Stallman <rms@gnu.org>
date Sat, 16 Jul 2005 19:20:50 +0000
parents ce8784010c3c
children 5b1a238fcbb4 187d6a1f84f7
comparison
equal deleted inserted replaced
64402:81b2fc299fbf 64403:db69241fec2b
32 (defvar find-gc-unsafe-list nil 32 (defvar find-gc-unsafe-list nil
33 "The list of unsafe functions is placed here by `find-gc-unsafe'.") 33 "The list of unsafe functions is placed here by `find-gc-unsafe'.")
34 34
35 (defvar find-gc-source-directory) 35 (defvar find-gc-source-directory)
36 36
37 (defvar find-gc-subrs-used nil 37 (defvar find-gc-subrs-callers nil
38 "List of subrs used so far in GC testing.") 38 "Alist of users of subrs, from GC testing.
39 Each entry has the form (FUNCTION . FUNCTIONS-THAT-CALL-IT).")
40
41 (defvar find-gc-subrs-called nil
42 "Alist of subrs called, in GC testing.
43 Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
44
39 45
40 ;;; Functions on this list are safe, even if they appear to be able 46 ;;; Functions on this list are safe, even if they appear to be able
41 ;;; to call the target. 47 ;;; to call the target.
42 48
43 (defvar find-gc-noreturn-list '(Fsignal Fthrow wrong_type_argument)) 49 (defvar find-gc-noreturn-list '(Fsignal Fthrow wrong_type_argument))
82 (setq find-gc-unsafe-list (list (list target))) 88 (setq find-gc-unsafe-list (list (list target)))
83 (trace-unsafe target) 89 (trace-unsafe target)
84 ) 90 )
85 91
86 (defun trace-unsafe (func) 92 (defun trace-unsafe (func)
87 (let ((used (assq func find-gc-subrs-used))) 93 (let ((used (assq func find-gc-subrs-callers)))
88 (or used 94 (or used
89 (error "No find-gc-subrs-used for %s" (car find-gc-unsafe-list))) 95 (error "No find-gc-subrs-callers for %s" (car find-gc-unsafe-list)))
90 (while (setq used (cdr used)) 96 (while (setq used (cdr used))
91 (or (assq (car used) find-gc-unsafe-list) 97 (or (assq (car used) find-gc-unsafe-list)
92 (memq (car used) find-gc-noreturn-list) 98 (memq (car used) find-gc-noreturn-list)
93 (progn 99 (progn
94 (push (cons (car used) func) find-gc-unsafe-list) 100 (push (cons (car used) func) find-gc-unsafe-list)
95 (trace-unsafe (car used)))))) 101 (trace-unsafe (car used))))))
96 ) 102 )
97 103
98 104
99 105
100 ;;; This produces an a-list of functions in subrs-called. The cdr of
101 ;;; each entry is a list of functions which the function in car calls.
102 106
103 (defun trace-call-tree (&optional already-setup) 107 (defun trace-call-tree (&optional already-setup)
104 (message "Setting up directories...") 108 (message "Setting up directories...")
105 (or already-setup 109 (or already-setup
106 (progn 110 (progn
110 (call-process "csh" nil nil nil "-c" 114 (call-process "csh" nil nil nil "-c"
111 (format "ln -s %s/*.[ch] /tmp/esrc" 115 (format "ln -s %s/*.[ch] /tmp/esrc"
112 find-gc-source-directory)))) 116 find-gc-source-directory))))
113 (save-excursion 117 (save-excursion
114 (set-buffer (get-buffer-create "*Trace Call Tree*")) 118 (set-buffer (get-buffer-create "*Trace Call Tree*"))
115 (setq subrs-called nil) 119 (setq find-gc-subrs-called nil)
116 (let ((case-fold-search nil) 120 (let ((case-fold-search nil)
117 (files find-gc-source-files) 121 (files find-gc-source-files)
118 name entry) 122 name entry)
119 (while files 123 (while files
120 (message "Compiling %s..." (car files)) 124 (message "Compiling %s..." (car files))
129 (looking-at "[a-zA-Z0-9_]+") 133 (looking-at "[a-zA-Z0-9_]+")
130 (setq name (intern (buffer-substring (match-beginning 0) 134 (setq name (intern (buffer-substring (match-beginning 0)
131 (match-end 0)))) 135 (match-end 0))))
132 (message "%s : %s" (car files) name) 136 (message "%s : %s" (car files) name)
133 (setq entry (list name) 137 (setq entry (list name)
134 subrs-called (cons entry subrs-called))) 138 find-gc-subrs-called (cons entry find-gc-subrs-called)))
135 (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") 139 (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"")
136 (progn 140 (progn
137 (setq name (intern (buffer-substring (match-beginning 1) 141 (setq name (intern (buffer-substring (match-beginning 1)
138 (match-end 1)))) 142 (match-end 1))))
139 (or (memq name (cdr entry)) 143 (or (memq name (cdr entry))
141 (delete-file (concat "/tmp/esrc/" (car files) ".rtl")) 145 (delete-file (concat "/tmp/esrc/" (car files) ".rtl"))
142 (setq files (cdr files))))) 146 (setq files (cdr files)))))
143 ) 147 )
144 148
145 149
146 ;;; This produces an inverted a-list in find-gc-subrs-used. The cdr of each
147 ;;; entry is a list of functions that call the function in car.
148
149 (defun trace-use-tree () 150 (defun trace-use-tree ()
150 (setq find-gc-subrs-used (mapcar 'list (mapcar 'car subrs-called))) 151 (setq find-gc-subrs-callers (mapcar 'list (mapcar 'car find-gc-subrs-called)))
151 (let ((ptr subrs-called) 152 (let ((ptr find-gc-subrs-called)
152 p2 found) 153 p2 found)
153 (while ptr 154 (while ptr
154 (setq p2 (car ptr)) 155 (setq p2 (car ptr))
155 (while (setq p2 (cdr p2)) 156 (while (setq p2 (cdr p2))
156 (if (setq found (assq (car p2) find-gc-subrs-used)) 157 (if (setq found (assq (car p2) find-gc-subrs-callers))
157 (setcdr found (cons (car (car ptr)) (cdr found))))) 158 (setcdr found (cons (car (car ptr)) (cdr found)))))
158 (setq ptr (cdr ptr)))) 159 (setq ptr (cdr ptr))))
159 ) 160 )
160 161
161 (provide 'find-gc) 162 (provide 'find-gc)