0.7.6.28:
authorWilliam Harold Newman <william.newman@airmail.net>
Tue, 20 Aug 2002 19:17:00 +0000 (19:17 +0000)
committerWilliam Harold Newman <william.newman@airmail.net>
Tue, 20 Aug 2002 19:17:00 +0000 (19:17 +0000)
merged APD "Let-converting recursive lambdas" patch (sbcl-devel
2002-08-19), fixing bugs 65, 70, and 109

BUGS
src/compiler/ir1util.lisp
src/compiler/locall.lisp
tests/compiler.impure.lisp
version.lisp-expr

diff --git a/BUGS b/BUGS
index 48a6a4b..6fd716f 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -380,59 +380,6 @@ WORKAROUND:
   the new output block should start indented 2 or more characters
   rightward of the correct location.
 
-65:
-  (probably related to bug #70; maybe related to bug #109)
-  As reported by Carl Witty on submit@bugs.debian.org 1999-05-08,
-  compiling this file
-(in-package "CL-USER")
-(defun equal-terms (termx termy)
-  (labels
-    ((alpha-equal-bound-term-lists (listx listy)
-       (or (and (null listx) (null listy))
-          (and listx listy
-               (let ((bindings-x (bindings-of-bound-term (car listx)))
-                     (bindings-y (bindings-of-bound-term (car listy))))
-                 (if (and (null bindings-x) (null bindings-y))
-                     (alpha-equal-terms (term-of-bound-term (car listx))
-                                        (term-of-bound-term (car listy)))
-                     (and (= (length bindings-x) (length bindings-y))
-                          (prog2
-                              (enter-binding-pairs (bindings-of-bound-term (car listx))
-                                                   (bindings-of-bound-term (car listy)))
-                              (alpha-equal-terms (term-of-bound-term (car listx))
-                                                 (term-of-bound-term (car listy)))
-                            (exit-binding-pairs (bindings-of-bound-term (car listx))
-                                                (bindings-of-bound-term (car listy)))))))
-               (alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
-
-     (alpha-equal-terms (termx termy)
-       (if (and (variable-p termx)
-               (variable-p termy))
-          (equal-bindings (id-of-variable-term termx)
-                          (id-of-variable-term termy))
-          (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
-               (alpha-equal-bound-term-lists (bound-terms-of-term termx)
-                                             (bound-terms-of-term termy))))))
-
-    (or (eq termx termy)
-       (and termx termy
-            (with-variable-invocation (alpha-equal-terms termx termy))))))
-  causes an assertion failure
-    The assertion (EQ (C::LAMBDA-TAIL-SET C::CALLER)
-                      (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE))) failed.
-
-  Bob Rogers reports (1999-07-28 on cmucl-imp@cons.org) a smaller test
-  case with the same problem:
-(defun parse-fssp-alignment ()
-  ;; Given an FSSP alignment file named by the argument . . .
-  (labels ((get-fssp-char ()
-            (get-fssp-char))
-          (read-fssp-char ()
-            (get-fssp-char)))
-    ;; Stub body, enough to tickle the bug.
-    (list (read-fssp-char)
-         (read-fssp-char))))
-
 66:
   ANSI specifies that the RESULT-TYPE argument of CONCATENATE must be
   a subtype of SEQUENCE, but CONCATENATE doesn't check this properly:
@@ -459,27 +406,6 @@ WORKAROUND:
   crashes SBCL. In general tracing anything which is used in the 
   implementation of TRACE is likely to have the same problem.
 
-70:
-  (probably related to bug #65; maybe related to bug #109)
-  The compiler doesn't like &OPTIONAL arguments in LABELS and FLET
-  forms. E.g.
-    (DEFUN FIND-BEFORE (ITEM SEQUENCE &KEY (TEST #'EQL))
-      (LABELS ((FIND-ITEM (OBJ SEQ TEST &OPTIONAL (VAL NIL))
-                 (LET ((ITEM (FIRST SEQ)))
-                  (COND ((NULL SEQ)
-                         (VALUES NIL NIL))
-                        ((FUNCALL TEST OBJ ITEM)
-                         (VALUES VAL SEQ))
-                        (T     
-                         (FIND-ITEM OBJ (REST SEQ) TEST (NCONC VAL `(,ITEM))))))))
-      (FIND-ITEM ITEM SEQUENCE TEST)))
-  from David Young's bug report on cmucl-help@cons.org 30 Nov 2000
-  causes sbcl-0.6.9 to fail with
-    error in function SB-KERNEL:ASSERT-ERROR:
-       The assertion (EQ (SB-C::LAMBDA-TAIL-SET SB-C::CALLER)
-                         (SB-C::LAMBDA-TAIL-SET
-                          (SB-C::LAMBDA-HOME SB-C::CALLEE))) failed.
-
 72:
   (DECLAIM (OPTIMIZE ..)) doesn't work properly inside LOCALLY forms.
 
@@ -638,25 +564,6 @@ WORKAROUND:
   time trying to GC afterwards. Surely there's some more economical
   way to implement (ROOM T).
 
-109:
-  reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs
-  collection:
-    ;;; This file fails to compile.
-    ;;; Maybe this bug is related to bugs #65, #70 in the BUGS file.
-    (in-package :cl-user)
-    (defun tst2 ()
-      (labels 
-          ((eff (&key trouble)
-             (eff)
-             ;; nil
-             ;; Uncomment and it works
-             ))
-        (eff)))
-  In SBCL 0.6.12.42, the problem is
-    internal error, failed AVER:
-      "(COMMON-LISP:EQ (SB!C::LAMBDA-TAIL-SET SB!C::CALLER)
-                  (SB!C::LAMBDA-TAIL-SET (SB!C::LAMBDA-HOME SB!C::CALLEE)))"
-
 110:
   reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs
   collection:
index c1c1db8..7dd4459 100644 (file)
        (let* ((bind-block (node-block bind))
               (component (block-component bind-block))
               (return (lambda-return clambda)))
-         (aver (null (leaf-refs clambda)))
+          (dolist (ref (lambda-refs clambda))
+            (let ((home (node-home-lambda ref)))
+              (aver (eq home clambda))))
          (unless (leaf-ever-used clambda)
            (let ((*compiler-error-context* bind))
              (compiler-note "deleting unused function~:[.~;~:*~%  ~S~]"
index 2a2bd49..cc552d3 100644 (file)
   (let* ((home (node-home-lambda call))
         (home-env (lambda-physenv home)))
 
+    (aver (not (eq home clambda)))
+
     ;; CLAMBDA belongs to HOME now.
     (push clambda (lambda-lets home))
     (setf (lambda-home clambda) home)
     ;; All of CLAMBDA's LETs belong to HOME now.
     (let ((lets (lambda-lets clambda)))
       (dolist (let lets)
-       (setf (lambda-home let) home)
-       (setf (lambda-physenv let) home-env))
+        (setf (lambda-home let) home)
+        (setf (lambda-physenv let) home-env))
       (setf (lambda-lets home) (nconc lets (lambda-lets home))))
     ;; CLAMBDA no longer has an independent existence as an entity
     ;; which has LETs.
     ;; HOME no longer calls CLAMBDA, and owns all of CLAMBDA's old
     ;; DFO dependencies.
     (setf (lambda-calls-or-closes home)
-         (delete clambda
-                 (nunion (lambda-calls-or-closes clambda)
-                         (lambda-calls-or-closes home))))
+          (delete clambda
+                  (nunion (lambda-calls-or-closes clambda)
+                          (lambda-calls-or-closes home))))
     ;; CLAMBDA no longer has an independent existence as an entity
     ;; which calls things or has DFO dependencies.
     (setf (lambda-calls-or-closes clambda) nil)
 
     ;; All of CLAMBDA's ENTRIES belong to HOME now.
     (setf (lambda-entries home)
-         (nconc (lambda-entries clambda)
-                (lambda-entries home)))
+          (nconc (lambda-entries clambda)
+                 (lambda-entries home)))
     ;; CLAMBDA no longer has an independent existence as an entity
     ;; with ENTRIES.
     (setf (lambda-entries clambda) nil))
                 (null (rest refs))
                 (member (functional-kind clambda) '(nil :assignment))
                 (not (functional-entry-fun clambda)))
-       (let* ((ref-cont (node-cont (first refs)))
+       (let* ((ref (first refs))
+               (ref-cont (node-cont ref))
               (dest (continuation-dest ref-cont)))
          (when (and dest
                     (basic-combination-p dest)
                           (t
                            (reoptimize-continuation ref-cont)
                            nil)))
+            (when (eq clambda (node-home-lambda dest))
+              (delete-lambda clambda)
+              (return-from maybe-let-convert nil))
            (unless (eq (functional-kind clambda) :assignment)
-             (let-convert clambda dest))
+              (let-convert clambda dest))
            (reoptimize-call dest)
            (setf (functional-kind clambda)
                  (if (mv-combination-p dest) :mv-let :let))))
   (declare (type clambda clambda))
   (when (and (not (functional-kind clambda))
             (not (functional-entry-fun clambda)))
-    (let ((non-tail nil)
-         (call-fun nil))
+    (let ((outside-non-tail-call nil)
+         (outside-call nil))
       (when (and (dolist (ref (leaf-refs clambda) t)
                   (let ((dest (continuation-dest (node-cont ref))))
                     (when (or (not dest)
                        (return nil))
                     (let ((home (node-home-lambda ref)))
                       (unless (eq home clambda)
-                        (when call-fun
+                        (when outside-call
                           (return nil))
-                        (setq call-fun home))
+                        (setq outside-call dest))
                       (unless (node-tail-p dest)
-                        (when (or non-tail (eq home clambda))
+                        (when (or outside-non-tail-call (eq home clambda))
                           (return nil))
-                        (setq non-tail dest)))))
+                        (setq outside-non-tail-call dest)))))
                 (ok-initial-convert-p clambda))
-       (setf (functional-kind clambda) :assignment)
-       (let-convert clambda
-                    (or non-tail
-                        (continuation-dest
-                         (node-cont (first (leaf-refs clambda))))))
-       (when non-tail
-         (reoptimize-call non-tail))
-       t))))
+        (cond (outside-call (setf (functional-kind clambda) :assignment)
+                            (let-convert clambda outside-call)
+                            (when outside-non-tail-call
+                              (reoptimize-call outside-non-tail-call))
+                            t)
+              (t (delete-lambda clambda)
+                 nil))))))
index af77b04..02cda0e 100644 (file)
    ;; a call to prevent the other arguments from being optimized away
    (logand a1 a2 a3 a4 a5 a6 a7 a8 a9)))
 
-;;; bug 192, reported by Einar Floystad Dorum: Compiling this in 0.7.6
-;;; caused the compiler to try to constant-fold DATA-VECTOR-REF, which
-;;; is OK, except that there was no non-VOP definition of
-;;; DATA-VECTOR-REF, so it would fail.
+;;; bug 192, reported by Einar Floystad Dorum sbcl-devel 2002-08-14,
+;;; fixed in sbcl-0.7.6.26: Compiling this function in 0.7.6 caused
+;;; the compiler to try to constant-fold DATA-VECTOR-REF, which is OK,
+;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so
+;;; it would fail.
 (defun bug192 ()
       (funcall 
        (LAMBDA (TEXT I L )
                                   (WHEN T I))))))
                       INDEX)))
            (G908 I))) "abcdefg" 0 (length "abcdefg")))
+
+;;; bugs #65, #70, and #109, closed by APD's patch sbcl-devel 2002-08-17
+;;;
+;;; This was "YA code deletion bug" whose symptom was the failure of
+;;; the assertion
+;;;   (EQ (C::LAMBDA-TAIL-SET C::CALLER)
+;;;       (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE)))
+;;; at compile time.
+(defun bug65-1 (termx termy) ; from Carl Witty on submit bugs list, debian.org
+  (labels
+    ((alpha-equal-bound-term-lists (listx listy)
+       (or (and (null listx) (null listy))
+          (and listx listy
+               (let ((bindings-x (bindings-of-bound-term (car listx)))
+                     (bindings-y (bindings-of-bound-term (car listy))))
+                 (if (and (null bindings-x) (null bindings-y))
+                     (alpha-equal-terms (term-of-bound-term (car listx))
+                                        (term-of-bound-term (car listy)))
+                     (and (= (length bindings-x) (length bindings-y))
+                          (prog2
+                              (enter-binding-pairs (bindings-of-bound-term (car listx))
+                                                   (bindings-of-bound-term (car listy)))
+                              (alpha-equal-terms (term-of-bound-term (car listx))
+                                                 (term-of-bound-term (car listy)))
+                            (exit-binding-pairs (bindings-of-bound-term (car listx))
+                                                (bindings-of-bound-term (car listy)))))))
+               (alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
+
+     (alpha-equal-terms (termx termy)
+       (if (and (variable-p termx)
+               (variable-p termy))
+          (equal-bindings (id-of-variable-term termx)
+                          (id-of-variable-term termy))
+          (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
+               (alpha-equal-bound-term-lists (bound-terms-of-term termx)
+                                             (bound-terms-of-term termy))))))
+
+    (or (eq termx termy)
+       (and termx termy
+            (with-variable-invocation (alpha-equal-terms termx termy))))))
+(defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28
+  ;; Given an FSSP alignment file named by the argument . . .
+  (labels ((get-fssp-char ()
+            (get-fssp-char))
+          (read-fssp-char ()
+            (get-fssp-char)))
+    ;; Stub body, enough to tickle the bug.
+    (list (read-fssp-char)
+         (read-fssp-char))))
+(defun bug70 ; from David Young cmucl-help 30 Nov 2000
+    (item sequence &key (test #'eql))
+  (labels ((find-item (obj seq test &optional (val nil))
+                     (let ((item (first seq)))
+                       (cond ((null seq)
+                              (values nil nil))
+                             ((funcall test obj item)
+                              (values val seq))
+                             (t        
+                              (find-item obj
+                                         (rest seq)
+                                         test
+                                         (nconc val `(,item))))))))
+    (find-item item sequence test)))
+(defun bug109 () ; originally from CMU CL bugs collection, reported as
+                 ; SBCL bug by MNA 2001-06-25
+  (labels 
+      ((eff (&key trouble)
+           (eff)
+           ;; nil
+           ;; Uncomment and it works
+           ))
+    (eff)))
 \f
 ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
 ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
index 312f71e..626bd8b 100644 (file)
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.6.27"
+"0.7.6.28"