diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/find-gc.el | 92 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 28 |
2 files changed, 59 insertions, 61 deletions
diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index ff9062150db..83eb26e86d7 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -23,14 +23,15 @@ ;; Produce in find-gc-unsafe-list the set of all functions that may invoke GC. ;; This expects the Emacs sources to live in find-gc-source-directory. -;; It creates a temporary working directory /tmp/esrc. ;;; Code: (defvar find-gc-unsafe-list nil "The list of unsafe functions is placed here by `find-gc-unsafe'.") -(defvar find-gc-source-directory) +(defvar find-gc-source-directory + (file-name-as-directory (expand-file-name "src" source-directory)) + "Directory containing Emacs C sources.") (defvar find-gc-subrs-callers nil "Alist of users of subrs, from GC testing. @@ -59,22 +60,21 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).") "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" "unexcoff.c" + "syntax.c" "unexcoff.c" "bytecode.c" "process.c" "callproc.c" "doprnt.c" - "x11term.c" "x11fns.c")) + "xterm.c" "xfns.c")) (defun find-gc-unsafe () "Return a list of unsafe functions--that is, which can call GC. -Also store it in `find-gc-unsafe'." +Also store it in `find-gc-unsafe-list'." (trace-call-tree nil) (trace-use-tree) (find-unsafe-funcs 'Fgarbage_collect) (setq find-gc-unsafe-list (sort find-gc-unsafe-list (function (lambda (x y) - (string-lessp (car x) (car y)))))) -) + (string-lessp (car x) (car y))))))) ;;; This does a depth-first search to find all functions that can ;;; ultimately call the function "target". The result is an a-list @@ -84,8 +84,7 @@ Also store it in `find-gc-unsafe'." (defun find-unsafe-funcs (target) (setq find-gc-unsafe-list (list (list target))) - (trace-unsafe target) -) + (trace-unsafe target)) (defun trace-unsafe (func) (let ((used (assq func find-gc-subrs-callers))) @@ -96,53 +95,43 @@ Also store it in `find-gc-unsafe'." (memq (car used) find-gc-noreturn-list) (progn (push (cons (car used) func) find-gc-unsafe-list) - (trace-unsafe (car used)))))) -) + (trace-unsafe (car used))))))) -(defun trace-call-tree (&optional already-setup) +(defun trace-call-tree (&optional ignored) (message "Setting up directories...") - (or already-setup - (progn - ;; Gee, wouldn't a built-in "system" function be handy here. - (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc") - (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc") - (call-process "csh" nil nil nil "-c" - (format "ln -s %s/*.[ch] /tmp/esrc" - find-gc-source-directory)))) - (with-current-buffer (get-buffer-create "*Trace Call Tree*") - (setq find-gc-subrs-called nil) - (let ((case-fold-search nil) - (files find-gc-source-files) - name entry) - (while files - (message "Compiling %s..." (car files)) - (call-process "csh" nil nil nil "-c" - (format "gcc -dr -c /tmp/esrc/%s -o /dev/null" - (car files))) - (erase-buffer) - (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl")) - (while (re-search-forward ";; Function \\|(call_insn " nil t) - (if (= (char-after (- (point) 3)) ?o) - (progn - (looking-at "[a-zA-Z0-9_]+") - (setq name (intern (buffer-substring (match-beginning 0) - (match-end 0)))) - (message "%s : %s" (car files) name) - (setq entry (list name) - find-gc-subrs-called (cons entry find-gc-subrs-called))) - (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") + (setq find-gc-subrs-called nil) + (let ((case-fold-search nil) + (default-directory find-gc-source-directory) + (files find-gc-source-files) + name entry rtlfile) + (dolist (file files) + (message "Compiling %s..." file) + (call-process "gcc" nil nil nil "-I" "." "-I" "../lib" + "-fdump-rtl-expand" "-o" null-device "-c" file) + (setq rtlfile + (file-expand-wildcards (format "%s.*.expand" file) t)) + (if (/= 1 (length rtlfile)) + (message "Error compiling `%s'?" file) + (with-temp-buffer + (insert-file-contents (setq rtlfile (car rtlfile))) + (delete-file rtlfile) + (while (re-search-forward ";; Function \\|(call_insn " nil t) + (if (= (char-after (- (point) 3)) ?o) (progn - (setq name (intern (buffer-substring (match-beginning 1) - (match-end 1)))) - (or (memq name (cdr entry)) - (setcdr entry (cons name (cdr entry)))))))) - (delete-file (concat "/tmp/esrc/" (car files) ".rtl")) - (setq files (cdr files))))) -) - + (looking-at "[a-zA-Z0-9_]+") + (setq name (intern (match-string 0))) + (message "%s : %s" (car files) name) + (setq entry (list name) + find-gc-subrs-called + (cons entry find-gc-subrs-called))) + (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") + (progn + (setq name (intern (match-string 1))) + (or (memq name (cdr entry)) + (setcdr entry (cons name (cdr entry))))))))))))) (defun trace-use-tree () (setq find-gc-subrs-callers (mapcar 'list (mapcar 'car find-gc-subrs-called))) @@ -153,8 +142,7 @@ Also store it in `find-gc-unsafe'." (while (setq p2 (cdr p2)) (if (setq found (assq (car p2) find-gc-subrs-callers)) (setcdr found (cons (car (car ptr)) (cdr found))))) - (setq ptr (cdr ptr)))) -) + (setq ptr (cdr ptr))))) (provide 'find-gc) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7be0354992f..c194e1352ac 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -868,7 +868,7 @@ MIN-VERSION should be a version list." ;; Also check built-in packages. (package-built-in-p package min-version))) -(defun package-compute-transaction (packages requirements) +(defun package-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. PACKAGES should be a list of `package-desc'. @@ -880,7 +880,9 @@ version of that package. This function recursively computes the requirements of the packages in REQUIREMENTS, and returns a list of all the packages that must be installed. Packages that are already installed are -not included in this list." +not included in this list. + +SEEN is used internally to detect infinite recursion." ;; FIXME: We really should use backtracking to explore the whole ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1 ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0: @@ -893,15 +895,22 @@ not included in this list." (dolist (pkg packages) (if (eq next-pkg (package-desc-name pkg)) (setq already pkg))) - (cond - (already + (when already (if (version-list-<= next-version (package-desc-version already)) - ;; Move to front, so it gets installed early enough (bug#14082). - (setq packages (cons already (delq already packages))) + ;; `next-pkg' is already in `packages', but its position there + ;; means it might be installed too late: remove it from there, so + ;; we re-add it (along with its dependencies) at an earlier place + ;; below (bug#16994). + (if (memq already seen) ;Avoid inf-loop on dependency cycles. + (message "Dependency cycle going through %S" + (package-desc-full-name already)) + (setq packages (delq already packages)) + (setq already nil)) (error "Need package `%s-%s', but only %s is being installed" next-pkg (package-version-join next-version) (package-version-join (package-desc-version already))))) - + (cond + (already nil) ((package-installed-p next-pkg next-version) nil) (t @@ -933,12 +942,13 @@ but version %s required" (t (setq found pkg-desc))))) (unless found (if problem - (error problem) + (error "%s" problem) (error "Package `%s-%s' is unavailable" next-pkg (package-version-join next-version)))) (setq packages (package-compute-transaction (cons found packages) - (package-desc-reqs found)))))))) + (package-desc-reqs found) + (cons found seen)))))))) packages) (defun package-read-from-string (str) |