From 784b195743728436795b90f95273c3535ebee9a5 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Thu, 10 Jul 2003 07:27:03 +0000 Subject: [PATCH] 0.8.1.29: * DELETE-BLOCK: if the last continuation has a destination, delete it. (bug reported by ohler on #lisp 2003-07-10) * make condition slot accessors be methods. --- NEWS | 4 ++++ src/code/condition.lisp | 29 ++++++++++++++++++++------- src/code/late-condition.lisp | 21 ++++++++++++++++++++ src/cold/warm.lisp | 1 + src/compiler/debug.lisp | 45 +++++++++++++++++++++++------------------- src/compiler/ir1util.lisp | 11 +++++++---- tests/compiler.impure.lisp | 6 ++++++ tests/condition.impure.lisp | 38 +++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 125 insertions(+), 32 deletions(-) create mode 100644 src/code/late-condition.lisp create mode 100644 tests/condition.impure.lisp diff --git a/NEWS b/NEWS index 8c61ff0..ffdb9b4 100644 --- a/NEWS +++ b/NEWS @@ -1913,8 +1913,12 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1: anymore. * fixed bug: sometimes MAKE-INSTANCE did not work with classes with many :DEFAULT-INITARGS. (reported by Istvan Marko) + * fixed bug: if last continuation of a deleted block has a + destination, this destination should be deleted too. (reported by + ohler on #lisp) * fixed some bugs revealed by Paul Dietz' test suite: ** LAST and [N]BUTLAST should accept a bignum. + ** condition slot accessors are methods. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 62b7465..4e686ef 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -346,6 +346,25 @@ (res (copy-structure sslot))))))) (res))) +;;; Early definitions of slot accessor creators. +;;; +;;; Slot accessors must be generic functions, but ANSI does not seem +;;; to specify any of them, and we cannot support it before end of +;;; warm init. So we use ordinary functions inside SBCL, and switch to +;;; GFs only at the end of building. +(declaim (notinline install-condition-slot-reader + install-condition-slot-writer)) +(defun install-condition-slot-reader (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (condition) + (condition-reader-function condition slot-name)))) +(defun install-condition-slot-writer (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (new-value condition) + (condition-writer-function condition new-value slot-name)))) + (defun %define-condition (name slots documentation report default-initargs) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) @@ -356,15 +375,11 @@ (dolist (slot slots) ;; Set up reader and writer functions. - (let ((name (condition-slot-name slot))) + (let ((slot-name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) - (setf (fdefinition reader) - (lambda (condition) - (condition-reader-function condition name)))) + (install-condition-slot-reader reader name slot-name)) (dolist (writer (condition-slot-writers slot)) - (setf (fdefinition writer) - (lambda (new-value condition) - (condition-writer-function condition new-value name)))))) + (install-condition-slot-writer writer name slot-name)))) ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp new file mode 100644 index 0000000..2aa8921 --- /dev/null +++ b/src/code/late-condition.lisp @@ -0,0 +1,21 @@ +;;;; Condition support in target lisp + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-KERNEL") + +(fmakunbound 'install-condition-slot-reader) +(fmakunbound 'install-condition-slot-writer) +(defun install-condition-slot-reader (name condition slot-name) + (eval `(defmethod ,name ((.condition. ,condition)) + (condition-reader-function .condition. ',slot-name)))) +(defun install-condition-slot-writer (name condition slot-name) + (eval `(defmethod ,name (new-value (.condition. ,condition)) + (condition-writer-function .condition. new-value ',slot-name)))) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 546f45b..838b4d2 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -136,6 +136,7 @@ ;; miscellaneous functionality which depends on CLOS "src/code/force-delayed-defbangmethods" + "src/code/late-condition" ;; CLOS-level support for the Gray OO streams ;; extension (which is also supported by various diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index b29ac89..1bdad5b 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -475,7 +475,10 @@ (unless (gethash (continuation-block cont) *seen-blocks*) (barf "~S receives ~S, which is in an unknown block." node cont)) (unless (eq (continuation-dest cont) node) - (barf "DEST for ~S should be ~S." cont node))))) + (barf "DEST for ~S should be ~S." cont node)) + (unless (find-uses cont) + (barf "Continuation ~S has a destinatin, but no uses." + cont))))) (values)) ;;; This function deals with checking for consistency of the @@ -496,25 +499,25 @@ (check-dest (basic-combination-fun node) node) (dolist (arg (basic-combination-args node)) (cond - (arg (check-dest arg node)) - ((not (and (eq (basic-combination-kind node) :local) - (combination-p node))) - (barf "flushed arg not in local call: ~S" node)) - (t - (locally - ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like - ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of - ;; POSITION. It compiles it correctly, but it issues a type - ;; mismatch warning because it can't eliminate the - ;; possibility that control will flow through the - ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15 - (declare (notinline position)) - (let ((fun (ref-leaf (continuation-use - (basic-combination-fun node)))) - (pos (position arg (basic-combination-args node)))) - (declare (type index pos)) - (when (leaf-refs (elt (lambda-vars fun) pos)) - (barf "flushed arg for referenced var in ~S" node))))))) + (arg (check-dest arg node)) + ((not (and (eq (basic-combination-kind node) :local) + (combination-p node))) + (barf "flushed arg not in local call: ~S" node)) + (t + (locally + ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like + ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of + ;; POSITION. It compiles it correctly, but it issues a type + ;; mismatch warning because it can't eliminate the + ;; possibility that control will flow through the + ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15 + (declare (notinline position)) + (let ((fun (ref-leaf (continuation-use + (basic-combination-fun node)))) + (pos (position arg (basic-combination-args node)))) + (declare (type index pos)) + (when (leaf-refs (elt (lambda-vars fun) pos)) + (barf "flushed arg for referenced var in ~S" node))))))) (let ((dest (continuation-dest (node-cont node)))) (when (and (return-p dest) (eq (basic-combination-kind node) :local) @@ -954,6 +957,8 @@ (pprint-logical-block (nil nil) (format t "~:@_IR1 block ~D start c~D" (block-number block) (cont-num (block-start block))) + (when (block-delete-p block) + (format t " ")) (let ((last (block-last block))) (pprint-newline :mandatory) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 90de784..ea581fb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1081,9 +1081,12 @@ (when last (let ((cont (node-cont last))) (delete-continuation-use last) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (reoptimize-continuation cont))))) + (acond ((eq (continuation-kind cont) :unused) + (delete-continuation cont)) + ((and (null (find-uses cont)) + (continuation-dest cont)) + (mark-for-deletion (node-block it))) + ((reoptimize-continuation cont)))))) (dolist (b (block-pred block)) (unlink-blocks b block) @@ -1143,7 +1146,7 @@ (cast (flush-dest (cast-value node)))) - (delete-continuation (node-prev node))) + (delete-continuation (node-prev node))) (remove-from-dfo block) (values)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9435118..a1166ab 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -839,6 +839,12 @@ (list (bar x) (bar x) (bar x)))) (assert (raises-error? (bug249 1.0) type-error)) + +;;; bug reported by ohler on #lisp 2003-07-10 +(defun bug-ohler-2003-07-10 (a b) + (declare (optimize (speed 0) (safety 3) (space 0) + (debug 1) (compilation-speed 0))) + (adjoin a b)) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp new file mode 100644 index 0000000..246a6a8 --- /dev/null +++ b/tests/condition.impure.lisp @@ -0,0 +1,38 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(cl:in-package :cl-user) + +;;; Bug from CLOCC. +(defpackage :p1 + (:use :cl) + (:export #:code #:code-msg #:%code-msg)) +(in-package :p1) +(define-condition code () + ((msg :reader code-msg :reader %code-msg :initarg :msg))) + +(defpackage :p2 + (:use :cl :p1)) +(in-package :p2) +(define-condition code1 (code) + ((msg :accessor code-msg :initarg :msg))) + +(let ((code (make-condition 'code :msg 1))) + (assert (typep code 'code)) + (assert (eql (code-msg code) 1)) + (assert (eql (%code-msg code) 1))) +(let ((code (make-condition 'code1 :msg 1))) + (assert (typep code 'code)) + (assert (eql (code-msg code) 1)) + (assert (eql (%code-msg code) 1)) + (setf (code-msg code) 2) + (assert (eql (code-msg code) 2)) + (assert (eql (%code-msg code) 1))) diff --git a/version.lisp-expr b/version.lisp-expr index d7fc450..312e2a4 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.1.28" +"0.8.1.29" -- 1.7.10.4