From: Alexey Dejneka Date: Tue, 30 Dec 2003 03:08:09 +0000 (+0000) Subject: 0.8.7.1: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0c25cf1e8e49095969378ab356a5516f29d4c139;p=sbcl.git 0.8.7.1: * Fix PFD's MISC.184 ... new kind of a deleted function: :ZOMBIE = effectless LET; ... DELETE-LAMBDA is used only for a deletion of an unreachable functions; ... for a LET-like lambda DELETE-LAMBDA deletes its BIND block; ... DO-NODES-BACKWARDS stops iteration when the traversed block is to be deleted. --- diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 1ada265..aae4e2f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1326,6 +1326,9 @@ (unlink-node call) (unlink-node (lambda-bind clambda)) (setf (lambda-bind clambda) nil)) + (setf (functional-kind clambda) :zombie) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) (values)) ;;; This function is called when one of the arguments to a LET diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 242aae3..5d228d5 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -305,7 +305,7 @@ (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) (lexenv-lambda (lambda-call-lexenv fun)))) - ((not (eq (functional-kind fun) :deleted)) + ((not (memq (functional-kind fun) '(:deleted :zombie))) (lambda-home fun)) (when (eq (lambda-home fun) fun) (return fun)))) @@ -323,12 +323,15 @@ (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) +(declaim (inline block-to-be-deleted-p)) +(defun block-to-be-deleted-p (block) + (or (block-delete-p block) + (eq (functional-kind (block-home-lambda block)) :deleted))) + ;;; Checks whether NODE is in a block to be deleted (declaim (inline node-to-be-deleted-p)) (defun node-to-be-deleted-p (node) - (let ((block (node-block node))) - (or (block-delete-p block) - (eq (functional-kind (block-home-lambda block)) :deleted)))) + (block-to-be-deleted-p (node-block node))) (declaim (ftype (sfunction (clambda) cblock) lambda-block)) (defun lambda-block (clambda) @@ -778,74 +781,71 @@ (clambda (delete-lambda fun))) (values)) -;;; Deal with deleting the last reference to a CLAMBDA. It is called -;;; in two situations: when the lambda is unreachable (so that its -;;; body may be deleted), and when it is an effectless LET (in this -;;; case its body is reachable and is not completely "its"). We set -;;; FUNCTIONAL-KIND to :DELETED and rely on IR1-OPTIMIZE to delete its -;;; blocks. +;;; Deal with deleting the last reference to a CLAMBDA, which means +;;; that the lambda is unreachable, so that its body may be +;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on +;;; IR1-OPTIMIZE to delete its blocks. (defun delete-lambda (clambda) (declare (type clambda clambda)) (let ((original-kind (functional-kind clambda)) (bind (lambda-bind clambda))) (aver (not (member original-kind '(:deleted :toplevel)))) (aver (not (functional-has-external-references-p clambda))) + (aver (or (eq original-kind :zombie) bind)) (setf (functional-kind clambda) :deleted) (setf (lambda-bind clambda) nil) - (when bind ; CLAMBDA is deleted due to unreachability - (labels ((delete-children (lambda) - (dolist (child (lambda-children lambda)) - (cond ((eq (functional-kind child) :deleted) - (delete-children child)) - (t - (delete-lambda child)))) - (setf (lambda-children lambda) nil) - (setf (lambda-parent lambda) nil))) - (delete-children clambda))) - (dolist (let (lambda-lets clambda)) - (setf (lambda-bind let) nil) - (setf (functional-kind let) :deleted)) - - ;; LET may be deleted if its BIND is unreachable. Autonomous - ;; function may be deleted if it has no reachable references. - (unless (member original-kind '(:let :mv-let :assignment)) - (dolist (ref (lambda-refs clambda)) - (mark-for-deletion (node-block ref)))) + (labels ((delete-children (lambda) + (dolist (child (lambda-children lambda)) + (cond ((eq (functional-kind child) :deleted) + (delete-children child)) + (t + (delete-lambda child)))) + (setf (lambda-children lambda) nil) + (setf (lambda-parent lambda) nil))) + (delete-children clambda)) ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except ;; that we're using the old value of the KIND slot, not the ;; current slot value, which has now been set to :DELETED.) - (if (member original-kind '(:let :mv-let :assignment)) - (let ((home (lambda-home clambda))) - (setf (lambda-lets home) (delete clambda (lambda-lets home)))) - ;; If the function isn't a LET, we unlink the function head - ;; and tail from the component head and tail to indicate that - ;; the code is unreachable. We also delete the function from - ;; COMPONENT-LAMBDAS (it won't be there before local call - ;; analysis, but no matter.) If the lambda was never - ;; referenced, we give a note. - (let* ((bind-block (node-block bind)) - (component (block-component bind-block)) - (return (lambda-return clambda)) - (return-block (and return (node-block return)))) - (unless (leaf-ever-used clambda) - (let ((*compiler-error-context* bind)) - (compiler-notify 'code-deletion-note - :format-control "deleting unused function~:[.~;~:*~% ~S~]" - :format-arguments (list (leaf-debug-name clambda))))) - (unless (block-delete-p bind-block) - (unlink-blocks (component-head component) bind-block)) - (when (and return-block (not (block-delete-p return-block))) - (mark-for-deletion return-block) - (unlink-blocks return-block (component-tail component))) - (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set clambda))) - (setf (tail-set-funs tails) - (delete clambda (tail-set-funs tails))) - (setf (lambda-tail-set clambda) nil)) - (setf (component-lambdas component) - (delq clambda (component-lambdas component))))) + (case original-kind + (:zombie) + ((:let :mv-let :assignment) + (let ((bind-block (node-block bind))) + (mark-for-deletion bind-block)) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home))))) + (t + ;; Function has no reachable references. + (dolist (ref (lambda-refs clambda)) + (mark-for-deletion (node-block ref))) + ;; If the function isn't a LET, we unlink the function head + ;; and tail from the component head and tail to indicate that + ;; the code is unreachable. We also delete the function from + ;; COMPONENT-LAMBDAS (it won't be there before local call + ;; analysis, but no matter.) If the lambda was never + ;; referenced, we give a note. + (let* ((bind-block (node-block bind)) + (component (block-component bind-block)) + (return (lambda-return clambda)) + (return-block (and return (node-block return)))) + (unless (leaf-ever-used clambda) + (let ((*compiler-error-context* bind)) + (compiler-notify 'code-deletion-note + :format-control "deleting unused function~:[.~;~:*~% ~S~]" + :format-arguments (list (leaf-debug-name clambda))))) + (unless (block-delete-p bind-block) + (unlink-blocks (component-head component) bind-block)) + (when (and return-block (not (block-delete-p return-block))) + (mark-for-deletion return-block) + (unlink-blocks return-block (component-tail component))) + (setf (component-reanalyze component) t) + (let ((tails (lambda-tail-set clambda))) + (setf (tail-set-funs tails) + (delete clambda (tail-set-funs tails))) + (setf (lambda-tail-set clambda) nil)) + (setf (component-lambdas component) + (delq clambda (component-lambdas component)))))) ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its ;; ENTRY-FUN so that people will know that it is not an entry @@ -927,7 +927,7 @@ (delete-lambda leaf)) (:external (delete-lambda leaf)) - ((:deleted :optional)))) + ((:deleted :zombie :optional)))) (optional-dispatch (unless (eq (functional-kind leaf) :deleted) (delete-optional-dispatch leaf))))) @@ -1542,7 +1542,7 @@ ;; analysis, it is LET-converted: LET-converted functionals ;; are too badly trashed to expand them inline, and deleted ;; LET-converted functionals are even worse. - (eql (functional-kind functional) :deleted))) + (memq (functional-kind functional) '(:deleted :zombie)))) (throw 'locall-already-let-converted functional))) (defun call-full-like-p (call) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 9b3613d..0e9ba01 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -281,7 +281,7 @@ (return)) (let ((kind (functional-kind functional))) (cond ((or (functional-somewhat-letlike-p functional) - (eql kind :deleted)) + (memq kind '(:deleted :zombie))) (values)) ; nothing to do ((and (null (leaf-refs functional)) (eq kind nil) (not (functional-entry-fun functional))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index fe19264..c92c88a 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -644,7 +644,9 @@ for ,n-prev = (when ,node-var (node-prev ,node-var)) and ,lvar = (when (and ,node-var (valued-node-p ,node-var)) (node-lvar ,node-var)) - while ,node-var + while ,(if restart-p + `(and ,node-var (not (block-to-be-deleted-p ,n-block))) + node-var) do (progn ,@body)))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 8ac629d..715f246 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -785,9 +785,12 @@ ;; :DELETED ;; This function has been found to be uncallable, and has been ;; marked for deletion. + ;; + ;; :ZOMBIE + ;; Effectless [MV-]LET; has no BIND node. (kind nil :type (member nil :optional :deleted :external :toplevel :escape :cleanup :let :mv-let :assignment - :toplevel-xep)) + :zombie :toplevel-xep)) ;; Is this a function that some external entity (e.g. the fasl dumper) ;; refers to, so that even when it appears to have no references, it ;; shouldn't be deleted? In the old days (before diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d7732db..124ffd3 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -977,3 +977,29 @@ (ceiling (flet ((%f16 () 0)) (%f16)))))))) '(0 0))) + +;;; MISC.184 +(assert (zerop + (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer 867934833 3293695878) a)) + (declare (type (integer -82111 1776797) b)) + (declare (type (integer -1432413516 54121964) c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (if nil + (flet ((%f15 (f15-1 &optional (f15-2 c)) + (labels ((%f1 (f1-1 f1-2) 0)) + (%f1 a 0)))) + (flet ((%f4 () + (multiple-value-call #'%f15 + (values (%f15 c 0) (%f15 0))))) + (if nil (%f4) + (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0)) + f8-3)) + 0)))) + 0))) + 3040851270 1664281 -1340106197))) diff --git a/version.lisp-expr b/version.lisp-expr index c60b0a8..06f0393 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.7" +"0.8.7.1"