From 12bd68a3ff68b4e06cfb8c441383b6e898d2ed78 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Tue, 17 Dec 2002 12:10:22 +0000 Subject: [PATCH] 0.7.10.21: Delete CLAMBDA when its BIND is detected to be unreachable. --- BUGS | 7 ---- src/compiler/dfo.lisp | 2 +- src/compiler/ir1opt.lisp | 78 ++++++++++++++++++++------------------------ src/compiler/ir1util.lisp | 41 ++++++++++++++--------- src/compiler/macros.lisp | 16 ++++----- tests/compiler.impure.lisp | 33 +++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 105 insertions(+), 74 deletions(-) diff --git a/BUGS b/BUGS index 8d43fb9..557e23e 100644 --- a/BUGS +++ b/BUGS @@ -1231,13 +1231,6 @@ WORKAROUND: recurses endlessly in sbcl-0.7.9.32. (Or it works if #' and FDEFINITION are replaced by SYMBOL-FUNCTION.) -224: - SBCL 0.7.8 fails to compile - (localy (declare (optimize (safety 3))) - (ignore-errors (progn (values-list (car (list '(1 . 2)))) t))) - (the LOCALY there is not a typo; any unknown function (e.g. FROB) - will do). - 228: "function-lambda-expression problems" in sbcl-0.7.9.6x, from the REPL: * (progn (declaim (inline foo)) (defun foo (x) x)) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 4161810..65134b1 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -187,7 +187,7 @@ (res home)))) (res))) -;;; If CLAMBDA is not already in COMPONENT, just return that +;;; If CLAMBDA is already in COMPONENT, just return that ;;; component. Otherwise, move the code for CLAMBDA and all lambdas it ;;; physically depends on (either because of calls or because of ;;; closure relationships) into COMPONENT, or possibly into another diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index e4c633b..1c878eb 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -288,53 +288,47 @@ (setf (component-reoptimize component) nil) (do-blocks (block component) (cond - ((or (block-delete-p block) - (null (block-pred block))) - (delete-block block)) - ((eq (functional-kind (block-home-lambda block)) :deleted) - ;; Preserve the BLOCK-SUCC invariant that almost every block has - ;; one successor (and a block with DELETE-P set is an acceptable - ;; exception). - (labels ((mark-blocks (block) - (dolist (pred (block-pred block)) - (unless (or (block-delete-p pred) - (eq (component-head (block-component pred)) - pred)) - (setf (block-delete-p pred) t) - (mark-blocks pred))))) - (mark-blocks block) - (delete-block block))) - (t - (loop - (let ((succ (block-succ block))) - (unless (and succ (null (rest succ))) - (return))) - - (let ((last (block-last block))) - (typecase last - (cif - (flush-dest (if-test last)) - (when (unlink-node last) - (return))) - (exit - (when (maybe-delete-exit last) - (return))))) - - (unless (join-successor-if-possible block) - (return))) - - (when (and (block-reoptimize block) (block-component block)) - (aver (not (block-delete-p block))) - (ir1-optimize-block block)) - ;; We delete blocks when there is either no predecessor or the ;; block is in a lambda that has been deleted. These blocks ;; would eventually be deleted by DFO recomputation, but doing ;; it here immediately makes the effect available to IR1 ;; optimization. - (when (and (block-flush-p block) (block-component block)) - (aver (not (block-delete-p block))) - (flush-dead-code block))))) + ((or (block-delete-p block) + (null (block-pred block))) + (delete-block block)) + ((eq (functional-kind (block-home-lambda block)) :deleted) + ;; Preserve the BLOCK-SUCC invariant that almost every block has + ;; one successor (and a block with DELETE-P set is an acceptable + ;; exception). + (mark-for-deletion block) + (delete-block block)) + (t + (loop + (let ((succ (block-succ block))) + (unless (and succ (null (rest succ))) + (return))) + + (let ((last (block-last block))) + (typecase last + (cif + (flush-dest (if-test last)) + (when (unlink-node last) + (return))) + (exit + (when (maybe-delete-exit last) + (return))))) + + (unless (join-successor-if-possible block) + (return))) + + (when (and (block-reoptimize block) (block-component block)) + (aver (not (block-delete-p block))) + (ir1-optimize-block block)) + + (cond ((block-delete-p block) + (delete-block block)) + ((and (block-flush-p block) (block-component block)) + (flush-dead-code block)))))) (values)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index aa2eb57..eb1531d 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -589,7 +589,7 @@ (link-blocks block new-block) (add-to-dfo new-block block) (setf (component-reanalyze (block-component block)) t) - + (do ((cont start (node-cont (continuation-next cont)))) ((eq cont last-cont) (when (eq (continuation-kind last-cont) :inside-block) @@ -603,7 +603,7 @@ ;;;; deleting stuff -;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. +;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. (defun delete-lambda-var (leaf) (declare (type lambda-var leaf)) @@ -682,6 +682,12 @@ (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)))) + ;; (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.) @@ -696,17 +702,17 @@ ;; referenced, we give a note. (let* ((bind-block (node-block bind)) (component (block-component bind-block)) - (return (lambda-return clambda))) - (dolist (ref (lambda-refs clambda)) - (let ((home (node-home-lambda ref))) - (aver (eq home clambda)))) + (return (lambda-return clambda)) + (return-block (and return (node-block return)))) (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" (leaf-debug-name clambda)))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) + (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) @@ -843,11 +849,17 @@ ;;; blocks with the DELETE-P flag. (defun mark-for-deletion (block) (declare (type cblock block)) - (unless (block-delete-p block) - (setf (block-delete-p block) t) - (setf (component-reanalyze (block-component block)) t) - (dolist (pred (block-pred block)) - (mark-for-deletion pred))) + (let* ((component (block-component block)) + (head (component-head component))) + (labels ((helper (block) + (setf (block-delete-p block) t) + (dolist (pred (block-pred block)) + (unless (or (block-delete-p pred) + (eq pred head)) + (helper pred))))) + (unless (block-delete-p block) + (helper block) + (setf (component-reanalyze component) t)))) (values)) ;;; Delete CONT, eliminating both control and value semantics. We set @@ -954,7 +966,6 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (aver (functional-somewhat-letlike-p lambda)) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index df8fb02..9fce92e 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -756,8 +756,8 @@ new-value)) (defsetf event-level %set-event-level) -;;; Define a new kind of event. Name is a symbol which names the event -;;; and Description is a string which describes the event. Level +;;; Define a new kind of event. NAME is a symbol which names the event +;;; and DESCRIPTION is a string which describes the event. Level ;;; (default 0) is the level of significance associated with this ;;; event; it is used to determine whether to print a Note when the ;;; event happens. @@ -776,7 +776,7 @@ (declaim (type unsigned-byte *event-note-threshold*)) (defvar *event-note-threshold* 1) -;;; Note that the event with the specified Name has happened. Node is +;;; Note that the event with the specified NAME has happened. NODE is ;;; evaluated to determine the node to which the event happened. (defmacro event (name &optional node) ;; Increment the counter and do any action. Mumble about the event if @@ -813,8 +813,8 @@ #!-sb-fluid (declaim (inline find-in position-in)) -;;; Find Element in a null-terminated List linked by the accessor -;;; function Next. Key, Test and Test-Not are the same as for generic +;;; Find ELEMENT in a null-terminated LIST linked by the accessor +;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic ;;; sequence functions. (defun find-in (next element @@ -836,9 +836,9 @@ (when (funcall test (funcall key current) element) (return current))))) -;;; Return the position of Element (or NIL if absent) in a -;;; null-terminated List linked by the accessor function Next. Key, -;;; Test and Test-Not are the same as for generic sequence functions. +;;; Return the position of ELEMENT (or NIL if absent) in a +;;; null-terminated LIST linked by the accessor function NEXT. KEY, +;;; TEST and TEST-NOT are the same as for generic sequence functions. (defun position-in (next element list diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 0a530bd..37b12fc 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -669,6 +669,39 @@ BUG 48c, not yet fixed: x) (assert (= (bug219-b-aux2 1) (if *bug219-b-expanded-p* 3 1))) + +;;; bug 224: failure in unreachable code deletion +(defmacro do-optimizations (&body body) + `(dotimes (.speed. 4) + (dotimes (.space. 4) + (dotimes (.debug. 4) + (dotimes (.compilation-speed. 4) + (proclaim `(optimize (speed , .speed.) (space , .space.) + (debug , .debug.) + (compilation-speed , .compilation-speed.))) + ,@body))))) + +(do-optimizations + (compile nil + (read-from-string + "(lambda () (#:localy (declare (optimize (safety 3))) + (ignore-errors (progn (values-list (car (list '(1 . 2)))) t))))"))) + +(do-optimizations + (compile nil '(lambda () + (labels ((ext () + (tagbody + (labels ((i1 () (list (i2) (i2))) + (i2 () (list (int) (i1))) + (int () (go :exit))) + (list (i1) (i1) (i1))) + :exit (return-from ext) + ))) + (list (error "nih") (ext) (ext)))))) + +(do-optimizations + (compile nil '(lambda (x) (let ((y (error ""))) (list x y))))) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index d1f84f0..75ff9c0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.20" +"0.7.10.21" -- 1.7.10.4