/[emacs]/emacs/lisp/emacs-lisp/find-gc.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/find-gc.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by lute, Mon Jul 4 17:33:35 2005 UTC revision 1.5 by rms, Sat Jul 16 17:24:40 2005 UTC
# Line 23  Line 23 
23    
24  ;;; Commentary:  ;;; Commentary:
25    
26  ;; Produce in unsafe-list the set of all functions that may invoke GC.  ;; Produce in find-gc-unsafe-list the set of all functions that may invoke GC.
27  ;; This expects the Emacs sources to live in emacs-source-directory.  ;; This expects the Emacs sources to live in find-gc-source-directory.
28  ;; It creates a temporary working directory /tmp/esrc.  ;; It creates a temporary working directory /tmp/esrc.
29    
30  ;;; Code:  ;;; Code:
31    
32    (defvar find-gc-unsafe-list nil
33      "The list of unsafe functions is placed here by `find-gc-unsafe'.")
34    
35    (defvar find-gc-source-directory)
36    
37    (defvar find-gc-subrs-used nil
38      "List of subrs used so far in GC testing.")
39    
40    ;;; Functions on this list are safe, even if they appear to be able
41    ;;; to call the target.
42    
43    (defvar find-gc-noreturn-list '(Fsignal Fthrow wrong_type_argument))
44    
45    ;;; This was originally generated directory-files, but there were
46    ;;; too many files there that were not actually compiled.  The
47    ;;; list below was created for a HP-UX 7.0 system.
48    
49    (defvar find-gc-source-files
50      '("dispnew.c" "scroll.c" "xdisp.c" "window.c"
51        "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c"
52        "keymap.c" "sysdep.c" "buffer.c" "filelock.c"
53        "insdel.c" "marker.c" "minibuf.c" "fileio.c"
54        "dired.c" "filemode.c" "cmds.c" "casefiddle.c"
55        "indent.c" "search.c" "regex.c" "undo.c"
56        "alloc.c" "data.c" "doc.c" "editfns.c"
57        "callint.c" "eval.c" "fns.c" "print.c" "lread.c"
58        "abbrev.c" "syntax.c" "unexec.c"
59        "bytecode.c" "process.c" "callproc.c" "doprnt.c"
60        "x11term.c" "x11fns.c"))
61    
62    
63  (defun find-gc-unsafe ()  (defun find-gc-unsafe ()
64      "Return a list of unsafe functions--that is, which can call GC.
65    Also store it in `find-gc-unsafe'."
66    (trace-call-tree nil)    (trace-call-tree nil)
67    (trace-use-tree)    (trace-use-tree)
68    (find-unsafe-funcs 'Fgarbage_collect)    (find-unsafe-funcs 'Fgarbage_collect)
69    (setq unsafe-list (sort unsafe-list    (setq find-gc-unsafe-list
70                            (function (lambda (x y)          (sort find-gc-unsafe-list
71                                        (string-lessp (car x) (car y))))))                (function (lambda (x y)
72                              (string-lessp (car x) (car y))))))
73  )  )
74    
 (setq emacs-source-directory "/usr/gnu/src/dist/src")  
   
   
75  ;;; This does a depth-first search to find all functions that can  ;;; This does a depth-first search to find all functions that can
76  ;;; ultimately call the function "target".  The result is an a-list  ;;; ultimately call the function "target".  The result is an a-list
77  ;;; in unsafe-list; the cars are the unsafe functions, and the cdrs  ;;; in find-gc-unsafe-list; the cars are the unsafe functions, and the cdrs
78  ;;; are (one of) the unsafe functions that these functions directly  ;;; are (one of) the unsafe functions that these functions directly
79  ;;; call.  ;;; call.
80    
81  (defun find-unsafe-funcs (target)  (defun find-unsafe-funcs (target)
82    (setq unsafe-list (list (list target)))    (setq find-gc-unsafe-list (list (list target)))
83    (trace-unsafe target)    (trace-unsafe target)
84  )  )
85    
86  (defun trace-unsafe (func)  (defun trace-unsafe (func)
87    (let ((used (assq func subrs-used)))    (let ((used (assq func find-gc-subrs-used)))
88      (or used      (or used
89          (error "No subrs-used for %s" (car unsafe-list)))          (error "No find-gc-subrs-used for %s" (car find-gc-unsafe-list)))
90      (while (setq used (cdr used))      (while (setq used (cdr used))
91        (or (assq (car used) unsafe-list)        (or (assq (car used) find-gc-unsafe-list)
92            (memq (car used) noreturn-list)            (memq (car used) find-gc-noreturn-list)
93            (progn            (progn
94              (setq unsafe-list (cons (cons (car used) func) unsafe-list))              (push (cons (car used) func) find-gc-unsafe-list)
95              (trace-unsafe (car used))))))              (trace-unsafe (car used))))))
96  )  )
97    
98    
 ;;; Functions on this list are safe, even if they appear to be able  
 ;;; to call the target.  
   
 (setq noreturn-list '( Fsignal Fthrow wrong_type_argument ))  
   
99    
100  ;;; This produces an a-list of functions in subrs-called.  The cdr of  ;;; 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.  ;;; each entry is a list of functions which the function in car calls.
# Line 83  Line 109 
109          (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc")          (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc")
110          (call-process "csh" nil nil nil "-c"          (call-process "csh" nil nil nil "-c"
111                        (format "ln -s %s/*.[ch] /tmp/esrc"                        (format "ln -s %s/*.[ch] /tmp/esrc"
112                                emacs-source-directory))))                                find-gc-source-directory))))
113    (save-excursion    (save-excursion
114      (set-buffer (get-buffer-create "*Trace Call Tree*"))      (set-buffer (get-buffer-create "*Trace Call Tree*"))
115      (setq subrs-called nil)      (setq subrs-called nil)
116      (let ((case-fold-search nil)      (let ((case-fold-search nil)
117            (files source-files)            (files find-gc-source-files)
118            name entry)            name entry)
119        (while files        (while files
120          (message "Compiling %s..." (car files))          (message "Compiling %s..." (car files))
# Line 117  Line 143 
143  )  )
144    
145    
146  ;;; This was originally generated directory-files, but there were  ;;; This produces an inverted a-list in find-gc-subrs-used.  The cdr of each
 ;;; too many files there that were not actually compiled.  The  
 ;;; list below was created for a HP-UX 7.0 system.  
   
 (setq source-files '("dispnew.c" "scroll.c" "xdisp.c" "window.c"  
                      "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c"  
                      "keymap.c" "sysdep.c" "buffer.c" "filelock.c"  
                      "insdel.c" "marker.c" "minibuf.c" "fileio.c"  
                      "dired.c" "filemode.c" "cmds.c" "casefiddle.c"  
                      "indent.c" "search.c" "regex.c" "undo.c"  
                      "alloc.c" "data.c" "doc.c" "editfns.c"  
                      "callint.c" "eval.c" "fns.c" "print.c" "lread.c"  
                      "abbrev.c" "syntax.c" "unexec.c"  
                      "bytecode.c" "process.c" "callproc.c" "doprnt.c"  
                      "x11term.c" "x11fns.c"))  
   
   
 ;;; This produces an inverted a-list in subrs-used.  The cdr of each  
147  ;;; entry is a list of functions that call the function in car.  ;;; entry is a list of functions that call the function in car.
148    
149  (defun trace-use-tree ()  (defun trace-use-tree ()
150    (setq subrs-used (mapcar 'list (mapcar 'car subrs-called)))    (setq find-gc-subrs-used (mapcar 'list (mapcar 'car subrs-called)))
151    (let ((ptr subrs-called)    (let ((ptr subrs-called)
152          p2 found)          p2 found)
153      (while ptr      (while ptr
154        (setq p2 (car ptr))        (setq p2 (car ptr))
155        (while (setq p2 (cdr p2))        (while (setq p2 (cdr p2))
156          (if (setq found (assq (car p2) subrs-used))          (if (setq found (assq (car p2) find-gc-subrs-used))
157              (setcdr found (cons (car (car ptr)) (cdr found)))))              (setcdr found (cons (car (car ptr)) (cdr found)))))
158        (setq ptr (cdr ptr))))        (setq ptr (cdr ptr))))
159  )  )

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26