From 5af8c2ae56df139842270bd9c9605c5d4b2d5148 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 21 Sep 2003 09:58:07 +0000 Subject: [PATCH] 0.8.3.84: * fix bug reported by Nicodemus Siivola: ... FIND-RESULT-TYPE: ignore uses in deleted blocks/functions; ... DELETE-LAMBDA: work with :OPTIONAL; * DELETE-BLOCK: when deleting ENTRY, delete it from LAMBDA-ENTRIES and delete all its EXITs. * add DERIVE-TYPE optimizer for ISQRT (thanks to Robert E. Brown). --- NEWS | 1 + src/code/numbers.lisp | 1 - src/compiler/ir1opt.lisp | 23 +++++++++++++---------- src/compiler/ir1util.lisp | 20 +++++++++++++------- src/compiler/node.lisp | 1 + src/compiler/srctran.lisp | 9 +++++++++ tests/compiler.impure-cload.lisp | 23 +++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 61 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 6032c17..ff90fba 100644 --- a/NEWS +++ b/NEWS @@ -2073,6 +2073,7 @@ changes in sbcl-0.8.4 relative to sbcl-0.8.3: * incompatible change: ICR structure is changed; the value part of CONTINUATION is now called LVAR; corresponding functions are renamed (e.g. SB-C::CONTINUATION-TYPE has become SB-C::LVAR-TYPE). + * added type deriver for ISQRT (thanks to Robert E. Brown). * fixed some bugs revealed by Paul Dietz' test suite: ** the RETURN clause in LOOP is now equivalent to DO (RETURN ...). ** ROUND and FROUND now give the right answer when given very diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 3632cd6..283cd4a 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1365,7 +1365,6 @@ (declare (integer x)) (etypecase x ((unsigned-byte ,width) x) - (bignum-element-type (logand x ,pattern)) (fixnum (logand x ,pattern)) (bignum (logand (%bignum-ref x 0) ,pattern))))) (,name ,@(loop for arg in lambda-list diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index cb198bd..618b3d7 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -446,21 +446,24 @@ (let ((result (return-result node))) (collect ((use-union *empty-type* values-type-union)) (do-uses (use result) - (cond ((and (basic-combination-p use) - (eq (basic-combination-kind use) :local)) - (aver (eq (lambda-tail-set (node-home-lambda use)) - (lambda-tail-set (combination-lambda use)))) - (when (combination-p use) - (when (nth-value 1 (maybe-convert-tail-local-call use)) - (return-from find-result-type (values))))) - (t - (use-union (node-derived-type use))))) + (let ((use-home (node-home-lambda use))) + (cond ((or (eq (functional-kind use-home) :deleted) + (block-delete-p (node-block use)))) + ((and (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (aver (eq (lambda-tail-set use-home) + (lambda-tail-set (combination-lambda use)))) + (when (combination-p use) + (when (nth-value 1 (maybe-convert-tail-local-call use)) + (return-from find-result-type (values))))) + (t + (use-union (node-derived-type use)))))) (let ((int ;; (values-type-intersection ;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26 (use-union) ;; ) - )) + )) (setf (return-result-type node) int)))) (values)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 5ac3a6a..57caf17 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -774,7 +774,7 @@ ;;; Deal with deleting the last reference to a CLAMBDA. It is called ;;; in two situations: when the lambda is unreachable (so that its -;;; body mey be deleted), and when it is an effectless LET (in this +;;; 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. @@ -782,17 +782,18 @@ (declare (type clambda clambda)) (let ((original-kind (functional-kind clambda)) (bind (lambda-bind clambda))) - (aver (not (member original-kind '(:deleted :optional :toplevel)))) + (aver (not (member original-kind '(:deleted :toplevel)))) (aver (not (functional-has-external-references-p clambda))) (setf (functional-kind clambda) :deleted) (setf (lambda-bind clambda) nil) - (when bind ; CLAMBDA is deleted due to unreachability + (when bind ; CLAMBDA is deleted due to unreachability (labels ((delete-children (lambda) (dolist (child (lambda-children lambda)) - (if (eq (functional-kind child) :deleted) - (delete-children child) - (delete-lambda child))) + (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))) @@ -1005,7 +1006,7 @@ (do-nodes-carefully (node block) (when (valued-node-p node) (delete-lvar-use node)) - (typecase node + (etypecase node (ref (delete-ref node)) (cif (flush-dest (if-test node))) ;; The next two cases serve to maintain the invariant that a LET @@ -1038,6 +1039,11 @@ (when entry (setf (entry-exits entry) (delq node (entry-exits entry)))))) + (entry + (dolist (exit (entry-exits node)) + (mark-for-deletion (node-block exit))) + (let ((home (node-home-lambda node))) + (setf (lambda-entries home) (delq node (lambda-entries home))))) (creturn (flush-dest (return-result node)) (delete-return node)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 1c1528e..5988f86 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -926,6 +926,7 @@ %source-name %debug-name #!+sb-show id + kind (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) (vars :prin1 (mapcar #'leaf-source-name vars))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a403e28..bee1713 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2287,6 +2287,15 @@ (setf min-len 0)) (specifier-type `(integer ,(or min-len '*) ,(or max-len '*)))))))) +(defoptimizer (isqrt derive-type) ((x)) + (let ((x-type (lvar-type x))) + (when (numeric-type-p x-type) + (let* ((lo (numeric-type-low x-type)) + (hi (numeric-type-high x-type)) + (lo-res (if lo (isqrt lo) '*)) + (hi-res (if hi (isqrt hi) '*))) + (specifier-type `(integer ,lo-res ,hi-res)))))) + (defoptimizer (code-char derive-type) ((code)) (specifier-type 'base-char)) diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 4f275bd..661c184 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -263,5 +263,28 @@ c))) (if (<= 11 c) (%f5) c)))) +;;; two bugs: "aggressive" deletion of optional entries and problems +;;; of FIND-RESULT-TYPE in dealing with deleted code; reported by +;;; Nikodemus Siivola (simplified version) +(defun lisp-error-error-handler (condition) + (invoke-debugger condition) + (handler-bind () + (unwind-protect + (with-simple-restart + (continue "return to hemlock's debug loop.") + (invoke-debugger condition)) + (device)))) + +;;; +(defun foo () + (labels ((foo (x) + (return-from foo x) + (block u + (labels ((bar (x &optional (y (return-from u))) + (list x y (apply #'bar (fee))))) + (list (bar 1) (bar 1 2)))) + (1+ x))) + #'foo)) + (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index af13694..1f20576 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.3.83" +"0.8.3.84" -- 1.7.10.4