From 9347abeb5f42dc83d372c19b14e86204a6a588dd Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 20 Aug 2002 19:17:00 +0000 Subject: [PATCH] 0.7.6.28: merged APD "Let-converting recursive lambdas" patch (sbcl-devel 2002-08-19), fixing bugs 65, 70, and 109 --- BUGS | 93 -------------------------------------------- src/compiler/ir1util.lisp | 4 +- src/compiler/locall.lisp | 51 +++++++++++++----------- tests/compiler.impure.lisp | 81 ++++++++++++++++++++++++++++++++++++-- version.lisp-expr | 2 +- 5 files changed, 109 insertions(+), 122 deletions(-) diff --git a/BUGS b/BUGS index 48a6a4b..6fd716f 100644 --- 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: diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c1c1db8..7dd4459 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -662,7 +662,9 @@ (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~]" diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 2a2bd49..cc552d3 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -790,6 +790,8 @@ (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) @@ -798,8 +800,8 @@ ;; 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. @@ -808,17 +810,17 @@ ;; 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)) @@ -1026,7 +1028,8 @@ (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) @@ -1037,8 +1040,11 @@ (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)))) @@ -1117,8 +1123,8 @@ (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) @@ -1126,19 +1132,18 @@ (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)))))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index af77b04..02cda0e 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -160,10 +160,11 @@ ;; 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 ) @@ -196,6 +197,78 @@ (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))) ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. diff --git a/version.lisp-expr b/version.lisp-expr index 312f71e..626bd8b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4