From f2f24807c969eeab86a4daa7f1fc611e7bd27594 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 18 Jul 2008 20:07:58 +0000 Subject: [PATCH] 1.0.18.22: DX arguments in non-let-converted local calls * When a non-let function has dynamic extent arguments, the combination must end its block, or stack analysis will miss the cleanup, and stack will be popped too soon. --- NEWS | 2 ++ src/compiler/locall.lisp | 5 +++++ tests/dynamic-extent.impure.lisp | 29 +++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 37 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 382cc2e..a0ee21d 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes in sbcl-1.0.19 relative to 1.0.18: * bug fix: compiler no longer makes erronous assumptions in the presense of non-foldable SATISFIES types. + * bug fix: stack analysis missed cleanups of dynamic-extent + arguments in non-let-converted calls to local functions. * fixed some bugs revealed by Paul Dietz' test suite: ** interval arithmetic during type derivation used inexact integer to single-float coercions. diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 31e8136..d6235cd 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -76,6 +76,11 @@ (not (lvar-dynamic-extent arg))) append (handle-nested-dynamic-extent-lvars arg) into dx-lvars finally (when dx-lvars + ;; A call to non-LET with DX args must end its block, + ;; otherwise stack analysis will not see the combination and + ;; the associated cleanup/entry. + (unless (eq :let (functional-kind fun)) + (node-ends-block call)) (binding* ((before-ctran (node-prev call)) (nil (ensure-block-start before-ctran)) (block (ctran-block before-ctran)) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index da58dbf..4eb2db3 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -534,4 +534,33 @@ (declare (dynamic-extent #'mget #'mset)) ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset))))) (assert (equal (bug419 42) '(1 2 3 4 5 6))) + +;;; Multiple DX arguments in a local function call +(defun test-dx-flet-test (fun n f1 f2 f3) + (let ((res (with-output-to-string (s) + (assert (eql n (ignore-errors (funcall fun s))))))) + (multiple-value-bind (x pos) (read-from-string res nil) + (assert (equalp f1 x)) + (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos) + (assert (equalp f2 y)) + (assert (equalp f3 (read-from-string res nil nil :start pos2)))))) + (assert-no-consing (assert (eql n (funcall fun nil))))) +(macrolet ((def (n f1 f2 f3) + (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n))) + `(progn + (defun-with-dx ,name (s) + (flet ((f (x) + (declare (dynamic-extent x)) + (when s + (print x s) + (finish-output s)) + nil)) + (f ,f1) + (f ,f2) + (f ,f3) + ,n)) + (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3))))) + (def 0 (list :one) (list :two) (list :three)) + (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list)) + (def 2 (list 1) (list 2 3) (list 4 5 6 7))) diff --git a/version.lisp-expr b/version.lisp-expr index d3d5033..05cf14a 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".) -"1.0.18.21" +"1.0.18.22" -- 1.7.10.4