* DELETE-LAMBDA: delete also contained lambdas.
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>
- (())
- (let* ()
- (multiple-value-call
- #'(lambda (&optional g2740 g2741 &rest g2742)
- (declare (ignore g2742))
- (catch 'foo ; <CLEANUP>
- (values (setq string g2740) (setq underhang g2741))))
- (foo)))
- (setf (dis-line-old-chars cc) chars)))))))
-
- Compiler deletes unreachable BIND node of <LET>, but its body,
- including reference to the variable CHARS, remains reachable through
- NLX from <CLEANUP>.
+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).
(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.
;;
(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))
(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))
;; 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
(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))
+
\f
(sb-ext:quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff