From f8c2f73dea06d9728cae4d2e8dc28c682ac2ecd2 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 17 Sep 2003 06:45:45 +0000 Subject: [PATCH] 0.8.3.73: * DELETE-LAMBDA: delete also contained lambdas. --- BUGS | 44 +++++++++-------------------------- src/compiler/ir1tran-lambda.lisp | 4 ++++ src/compiler/ir1util.lisp | 22 +++++++++++++----- src/compiler/node.lisp | 5 +++- tests/compiler.impure-cload.lisp | 47 ++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 83 insertions(+), 41 deletions(-) diff --git a/BUGS b/BUGS index cb7b79b..3319a10 100644 --- a/BUGS +++ b/BUGS @@ -1256,36 +1256,14 @@ WORKAROUND: the control word; however, this clobbers any change the user might have made. -291: "bugs in deletion of embedded functions" - - Python fails to compile (simplified version of the problem reported - by Nikodemus Siivola) - - (defstruct (line) - (%chars "")) - - (defun update-window-imag (line) - (tagbody - TOP - (if (null line) - (go DONE) - (go TOP)) - DONE - (unless (eq current the-sentinel) - (let* ((cc (car current)) - (old-line (dis-line-line cc))) - (if (eq old-line line) - (do ((chars (line-%chars line) nil)) ; - (()) - (let* () - (multiple-value-call - #'(lambda (&optional g2740 g2741 &rest g2742) - (declare (ignore g2742)) - (catch 'foo ; - (values (setq string g2740) (setq underhang g2741)))) - (foo))) - (setf (dis-line-old-chars cc) chars))))))) - - Compiler deletes unreachable BIND node of , but its body, - including reference to the variable CHARS, remains reachable through - NLX from . +292: + (COMPILE NIL + `(LAMBDA (C) + (DECLARE (TYPE (INTEGER -5945502333 12668542) C) + (OPTIMIZE (SPEED 3))) + (LET ((V2 (* C 12))) + (- (MAX (IF (/= 109335113 V2) -26479 V2) + (DEPOSIT-FIELD 311 + (BYTE 14 28) + (MIN (MAX 521326 C) -51))))))) + causes compiler failure (reported by Paul Dietz). diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 6971a72..1f4b91d 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -293,6 +293,10 @@ (result-ctran (make-ctran)) (result-lvar (make-lvar))) + (awhen (lexenv-lambda *lexenv*) + (push lambda (lambda-children it)) + (setf (lambda-parent lambda) it)) + ;; just to check: This function should fail internal assertions if ;; we didn't set up a valid debug name above. ;; diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index fc17e19..41d7a58 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -772,12 +772,12 @@ (clambda (delete-lambda fun))) (values)) -;;; Deal with deleting the last reference to a CLAMBDA. Since there is -;;; only one way into a CLAMBDA, deleting the last reference to a -;;; CLAMBDA ensures that there is no way to reach any of the code in -;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to -;;; :DELETED, causing IR1 optimization to delete blocks in that -;;; CLAMBDA. +;;; 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 +;;; 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. (defun delete-lambda (clambda) (declare (type clambda clambda)) (let ((original-kind (functional-kind clambda)) @@ -786,6 +786,16 @@ (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 + (labels ((delete-children (lambda) + (dolist (child (lambda-children lambda)) + (if (eq (functional-kind child) :deleted) + (delete-children child) + (delete-lambda child)) + (setf (lambda-children lambda) nil)) + (setf (lambda-parent lambda) nil))) + (delete-children clambda))) (dolist (let (lambda-lets clambda)) (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 0025ca5..1c1528e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -918,7 +918,10 @@ ;; retain it so that if the LET is deleted (due to a lack of vars), ;; we will still have caller's lexenv to figure out which cleanup is ;; in effect. - (call-lexenv nil :type (or lexenv null))) + (call-lexenv nil :type (or lexenv null)) + ;; list of embedded lambdas + (children nil :type list) + (parent nil :type (or clambda null))) (defprinter (clambda :conc-name lambda- :identity t) %source-name %debug-name diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index a1592a6..4c14ce6 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -187,5 +187,52 @@ (progn (truly-the integer x) (1+ x))) +;;; bug 291 reported by Nikodemus Siivola (modified version) +(defstruct line + (%chars "")) +(defun update-window-imag (line) + (tagbody + TOP + (if (null line) + (go DONE) + (go TOP)) + DONE + (unless (eq current the-sentinel) + (let* ((cc (car current)) + (old-line (dis-line-line cc))) + (if (eq old-line line) + (do ((chars (line-%chars line) nil)) + (()) + (let* () + (multiple-value-call + #'(lambda (&optional g2740 g2741 &rest g2742) + (declare (ignore g2742)) + (catch 'foo + (values (setq string g2740) (setq underhang g2741)))) + (foo))) + (setf (dis-line-old-chars cc) chars))))))) + +;;; and similar cases found by Paul Dietz +(defun #:foo (a b c) + (declare (optimize (speed 0) (safety 3) (debug 3))) + (FLET ((%F11 () + (BLOCK B6 + (LET ((V2 B)) + (IF (LDB-TEST (BYTE 27 14) V2) + (LET ((V6 + (FLET ((%F7 () + B)) + -1))) + (RETURN-FROM B6 V2)) + C))))) + A)) +(defun #:foo (a b c) + (declare (optimize (speed 0) (safety 3) (debug 3))) + (FLET ((%F15 () + (BLOCK B8 + (LET ((V5 B)) + (MIN A (RETURN-FROM B8 C)))))) + C)) + (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 3d711d5..30555b3 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.72" +"0.8.3.73" -- 1.7.10.4