diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp index af3eb9c08f55598ad920a3750c77ca446cf1c2c2..a188d22bb055467b0ad81ee60b2d7e88b030dc4f 100644 --- a/compiler/dfo.lisp +++ b/compiler/dfo.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.26 2000/07/07 09:33:01 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.27 2003/10/02 19:23:11 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -241,33 +241,42 @@ (let* ((bind-block (node-block (lambda-bind fun))) (this (block-component bind-block)) (return (lambda-return fun))) - (cond - ((eq this component) component) - ((not (eq (component-kind this) :initial)) - (join-components this component) - this) - ((block-flag bind-block) - component) - (t - (push fun (component-lambdas component)) - (setf (component-lambdas this) - (delete fun (component-lambdas this))) - (link-blocks (component-head component) bind-block) - (unlink-blocks (component-head this) bind-block) - (when return - (let ((return-block (node-block return))) - (link-blocks return-block (component-tail component)) - (unlink-blocks return-block (component-tail this)))) - (let ((calls (if (eq (functional-kind fun) :external) - (append (find-reference-functions fun) - (lambda-calls fun)) - (lambda-calls fun)))) - (do ((res (find-initial-dfo-aux bind-block component) - (dfo-walk-call-graph (first funs) res)) - (funs calls (rest funs))) - ((null funs) res) - (declare (type component res)))))))) - + (cond ((eq this component) + component) + ((not (eq (component-kind this) :initial)) + (join-components this component) + this) + ((block-flag bind-block) + component) + (t + (push fun (component-lambdas component)) + (setf (component-lambdas this) + (delete fun (component-lambdas this))) + (link-blocks (component-head component) bind-block) + (unlink-blocks (component-head this) bind-block) + (when return + (let ((return-block (node-block return))) + (link-blocks return-block (component-tail component)) + (unlink-blocks return-block (component-tail this)))) + (let ((res (find-initial-dfo-aux bind-block component))) + (declare (type component res)) + (flet ((walk (clambda) + (unless (eq (lambda-kind clambda) :deleted) + (let ((home (lambda-home clambda))) + (setq res (dfo-walk-call-graph home res)))))) + (dolist (dd (lambda-dfo-dependencies fun)) + (etypecase dd + (clambda + (walk dd)) + (lambda-var + (unless (null (lambda-var-refs dd)) + (walk (lambda-home (lambda-var-home dd))))) + (entry + (walk (node-home-lambda dd))))) + (when (eq (lambda-kind fun) :external) + (dolist (lambda (find-reference-functions fun)) + (walk lambda)))) + res))))) ;;; HAS-XEP-OR-NLX -- Internal ;;; diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 0c0f83cc2d20bc6d3115e4170d6e5b8a19182b32..61beb85b751a9e502c7caad4def2cfa7d2850953 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.164 2003/09/14 10:13:27 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.165 2003/10/02 19:23:11 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -145,7 +145,7 @@ ;;;; Dynamic-Extent (defvar *trust-dynamic-extent-declarations* nil - "If null, don't trust dynamic-extent declarations. + "If NIL, never trust dynamic-extent declarations. If T, always trust dynamic-extent declarations. @@ -794,8 +794,10 @@ (let ((var (or (lexenv-find name variables) (find-free-variable name)))) (etypecase var (leaf - (when (and (lambda-var-p var) (lambda-var-ignorep var)) - (compiler-note "Reading an ignored variable: ~S." name)) + (when (lambda-var-p var) + (when (lambda-var-ignorep var) + (compiler-note "Reading an ignored variable: ~S." name)) + (note-dfo-dependency start var)) (reference-leaf start cont var)) (cons (assert (eq (car var) 'MACRO)) @@ -2325,6 +2327,7 @@ (setf (continuation-dest value-cont) exit) (ir1-convert start value-cont value) (prev-link exit value-cont) + (note-dfo-dependency start entry) (use-continuation exit (cont-ref-cont (second found))))) @@ -2415,6 +2418,7 @@ (exit (make-exit :entry entry))) (push exit (entry-exits entry)) (prev-link exit start) + (note-dfo-dependency start entry) (use-continuation exit (cont-ref-cont (second found))))) @@ -3268,9 +3272,10 @@ (and (global-var-p leaf) (eq (global-var-kind leaf) :constant))) (compiler-error "Attempt to set constant ~S." name)) - (when (and (lambda-var-p leaf) - (lambda-var-ignorep leaf)) - (compiler-note "Setting an ignored variable: ~S." name)) + (when (lambda-var-p leaf) + (when (lambda-var-ignorep leaf) + (compiler-note "Setting an ignored variable: ~S." name)) + (note-dfo-dependency start leaf)) (set-variable start cont leaf (second things))) (cons (assert (eq (car leaf) 'MACRO)) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index 7306f17f4ade7e224b7a8a23ade0dcb310736cb8..eb029350b8c940378faf381f46b28512981bafa7 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.94 2003/08/16 11:45:47 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.95 2003/10/02 19:23:11 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2194,3 +2194,21 @@ these can be NIL if unavailable or inapplicable.") (let ((action (event-info-action info))) (when action (funcall action node)))) + +(defun continuation-home-lambda (cont) + (if (continuation-use cont) + (node-home-lambda (continuation-use cont)) + (let* ((block (continuation-block cont)) + (last-node (block-last block))) + (when last-node + (node-home-lambda last-node))))) + +(defun note-dfo-dependency (dependent thing) + (declare (type (or lambda-var clambda entry) thing)) + (let ((home (etypecase dependent + (node + (node-home-lambda dependent)) + (continuation + (continuation-home-lambda dependent))))) + (when home + (pushnew thing (lambda-dfo-dependencies home))))) diff --git a/compiler/locall.lisp b/compiler/locall.lisp index 28a9ea27e4a30b023880cf27b7a2bf2550546356..ebde6169e458f50b41a0d90ae7cc0754334eb9fc 100644 --- a/compiler/locall.lisp +++ b/compiler/locall.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.54 2003/08/05 14:04:52 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.55 2003/10/02 19:23:11 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -102,7 +102,7 @@ (declare (type ref ref) (type combination call) (type clambda fun)) (propagate-to-args call fun) (setf (basic-combination-kind call) :local) - (pushnew fun (lambda-calls (node-home-lambda call))) + (note-dfo-dependency call fun) (merge-tail-sets call fun) (change-ref-leaf ref fun) (undefined-value)) @@ -432,7 +432,7 @@ (= (length (basic-combination-args call)) 1)) (let ((ep (car (last (optional-dispatch-entry-points fun))))) (setf (basic-combination-kind call) :local) - (pushnew ep (lambda-calls (node-home-lambda call))) + (note-dfo-dependency call ep) (merge-tail-sets call ep) (change-ref-leaf ref ep) @@ -758,11 +758,12 @@ ;; HOME no longer calls FUN, and owns all of FUN's old DFO ;; dependencies - (setf (lambda-calls home) - (delete fun (nunion (lambda-calls fun) (lambda-calls home)))) + (setf (lambda-dfo-dependencies home) + (delete fun (nunion (lambda-dfo-dependencies fun) + (lambda-dfo-dependencies home)))) ;; FUN no longer has an independent existence as an entity ;; which calls things or has DFO dependencies. - (setf (lambda-calls fun) ()) + (setf (lambda-dfo-dependencies fun) ()) ;; All of FUN's ENTRIES belong to HOME now. (setf (lambda-entries home) @@ -837,28 +838,29 @@ ;;; ;;; The called function might be an assignment in the case where we are ;;; currently converting that function. In steady-state, assignments never -;;; appear in the lambda-calls. +;;; appear in the lambda-dfo-dependencies. ;;; (defun unconvert-tail-calls (fun call next-block) - (dolist (called (lambda-calls fun)) - (dolist (ref (leaf-refs called)) - (let ((this-call (continuation-dest (node-cont ref)))) - (when (and (node-tail-p this-call) - (eq (node-home-lambda this-call) fun)) - (setf (node-tail-p this-call) nil) - (ecase (functional-kind called) - ((nil :cleanup :optional) - (let ((block (node-block this-call)) - (cont (node-cont call))) - (ensure-block-start cont) - (unlink-blocks block (first (block-succ block))) - (link-blocks block next-block) - (delete-continuation-use this-call) - (add-continuation-use this-call cont))) - (:deleted) - (:assignment - (assert (eq called fun)))))))) - (undefined-value)) + (dolist (called (lambda-dfo-dependencies fun)) + (when (lambda-p called) + (dolist (ref (leaf-refs called)) + (let ((this-call (continuation-dest (node-cont ref)))) + (when (and (node-tail-p this-call) + (eq (node-home-lambda this-call) fun)) + (setf (node-tail-p this-call) nil) + (ecase (functional-kind called) + ((nil :cleanup :optional) + (let ((block (node-block this-call)) + (cont (node-cont call))) + (ensure-block-start cont) + (unlink-blocks block (first (block-succ block))) + (link-blocks block next-block) + (delete-continuation-use this-call) + (add-continuation-use this-call cont))) + (:deleted) + (:assignment + (assert (eq called fun))))))))) + (values)) ;;; MOVE-RETURN-STUFF -- Internal diff --git a/compiler/node.lisp b/compiler/node.lisp index c87b3517761c4ba1382ecec5e6df6085630baf12..7df863f42c90b802f64167d17b8384bf5742fd99 100644 --- a/compiler/node.lisp +++ b/compiler/node.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.43 2003/08/25 20:50:59 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.44 2003/10/02 19:23:11 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -936,10 +936,16 @@ ;; let. (entries () :type list) ;; - ;; A list of all the functions directly called from this function (or one of + ;; A list of leafs and nodes determining this lambda's dfo. + ;; + ;; - Clambdas directly called from this function (or one of ;; its lets) using a non-let local call. May include deleted functions ;; because nobody bothers to clear them out. - (calls () :type list) + ;; + ;; - Lambda-Vars used + ;; + ;; - Entries + (dfo-dependencies () :type list) ;; ;; The Tail-Set that this lambda is in. Null during creation and in let ;; lambdas. diff --git a/compiler/xref.lisp b/compiler/xref.lisp index 9ad58487a7a9a7e3e60356fa119d06fc1ca4ad67..ea192bdca3c89d91d40e48b741bacf4c3bbf911b 100644 --- a/compiler/xref.lisp +++ b/compiler/xref.lisp @@ -3,7 +3,7 @@ ;;; Author: Eric Marsden <emarsden@laas.fr> ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.4 2003/06/11 12:58:08 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.5 2003/10/02 19:23:11 gerd Exp $") ;; ;; This code was written as part of the CMUCL project and has been ;; placed in the public domain. @@ -197,6 +197,9 @@ be set at runtime." (in-package :compiler) +(defun lambda-contains-calls-p (clambda) + (declare (type clambda clambda)) + (some #'lambda-p (lambda-dfo-dependencies clambda))) (defun prettiest-caller-name (lambda-node toplevel-name) (cond @@ -207,7 +210,7 @@ be set at runtime." ;; If the home slot contains a lambda with a nice name, we use ;; that; otherwise fall back on the toplevel-name. ((or (not (eq (lambda-home lambda-node) lambda-node)) - (lambda-calls lambda-node)) + (lambda-contains-calls-p lambda-node)) (let ((home (lambda-name (lambda-home lambda-node))) (here (lambda-name lambda-node))) (cond ((and home here) @@ -244,7 +247,7 @@ be set at runtime." (list :internal (lambda-name (lambda-home lambda-node)) (lambda-name lambda-node))) - ((lambda-calls lambda-node) + ((lambda-contains-calls-p lambda-node) (list :internal/calls (lambda-name (lambda-home lambda-node)) (lambda-name lambda-node)))