From 697f4d1bd284ed6b72d24f416dfb09c2779b12df Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 27 Sep 2007 15:43:25 +0000 Subject: [PATCH] 1.0.10.8: correct nested DX implementation * Instead of just checking for BASIC-COMBINATION-P, HANDLE-NESTED-DYNAMIC-EXTENT needs to do the same check for each USE as RECHECK-DYNAMIC-EXTENT-LVARS does. * Tests. --- src/compiler/ir1util.lisp | 7 +++++++ src/compiler/locall.lisp | 28 +++++++++++++++------------- src/compiler/physenvanal.lisp | 17 ++++++----------- tests/dynamic-extent.impure.lisp | 33 +++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 62 insertions(+), 25 deletions(-) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 9658ac820..cba2914f7 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -382,6 +382,13 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) +(defun use-good-for-dx-p (use) + (and (combination-p use) + (eq (combination-kind use) :known) + (awhen (fun-info-stack-allocate-result + (combination-fun-info use)) + (funcall it use)))) + (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) (or (block-delete-p block) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index f9b8849b5..d3eadd816 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,23 +43,25 @@ (setf (car args) nil))) (values)) - -(defun handle-nested-dynamic-extent-lvars (arg) - (let ((uses (lvar-uses arg))) +(defun handle-nested-dynamic-extent-lvars (lvar) + (let ((uses (lvar-uses lvar))) ;; Stack analysis wants DX value generators to end their ;; blocks. Uses of mupltiple used LVARs already end their blocks, ;; so we just need to process used-once LVARs. (when (node-p uses) - (node-ends-block uses) - (setf uses (list uses))) - ;; If the function result is DX, so are its arguments... This - ;; assumes that all our DX functions do not store their arguments - ;; anywhere -- just use, and maybe return. - (cons arg - (loop for use in uses - when (basic-combination-p use) - nconc (loop for a in (basic-combination-args use) - append (handle-nested-dynamic-extent-lvars a)))))) + (node-ends-block uses)) + ;; If this LVAR's USE is good for DX, it must be a regular + ;; combination, and its arguments are potentially DX as well. + (flet ((recurse (use) + (loop for arg in (combination-args use) + append (handle-nested-dynamic-extent-lvars arg)))) + (cons lvar + (if (listp uses) + (loop for use in uses + when (use-good-for-dx-p use) + nconc (recurse use)) + (when (use-good-for-dx-p uses) + (recurse uses))))))) (defun recognize-dynamic-extent-lvars (call fun) (declare (type combination call) (type clambda fun)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index af8fec3ab..835c7c5d7 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -334,17 +334,12 @@ (loop for what in (cleanup-info cleanup) do (etypecase what (lvar - (let* ((lvar what) - (uses (lvar-uses lvar))) - (if (every (lambda (use) - (and (combination-p use) - (eq (basic-combination-kind use) :known) - (awhen (fun-info-stack-allocate-result - (basic-combination-fun-info use)) - (funcall it use)))) - (if (listp uses) uses (list uses))) - (real-dx-lvars lvar) - (setf (lvar-dynamic-extent lvar) nil)))) + (if (let ((uses (lvar-uses what))) + (if (listp uses) + (every #'use-good-for-dx-p uses) + (use-good-for-dx-p uses))) + (real-dx-lvars what) + (setf (lvar-dynamic-extent what) nil))) (node ; DX closure (let* ((call what) (arg (first (basic-combination-args call))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 78923f371..d22342d51 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -160,6 +160,25 @@ (true dx) nil)) +(defun-with-dx nested-dx-not-used (x) + (declare (list x)) + (let ((l (setf (car x) (list x x x)))) + (declare (dynamic-extent l)) + (true l) + (true (length l)) + nil)) + +(defun-with-dx nested-evil-dx-used (x) + (declare (list x)) + (let ((l (list x x x))) + (declare (dynamic-extent l)) + (unwind-protect + (progn + (setf (car x) l) + (true l)) + (setf (car x) nil)) + nil)) + ;;; multiple uses for dx lvar (defun-with-dx multiple-dx-uses () @@ -196,6 +215,18 @@ (funcall thunk)) (assert (< (- (get-bytes-consed) before) times)))) +(defmacro assert-consing (form &optional times) + `(%assert-consing (lambda () ,form) ,times)) +(defun %assert-consing (thunk &optional times) + (let ((before (get-bytes-consed)) + (times (or times 10000))) + (declare (type (integer 1 *) times)) + (dotimes (i times) + (funcall thunk)) + (assert (not (< (- (get-bytes-consed) before) times))))) + +(defvar *a-cons* (cons nil nil)) + #+(or x86 x86-64 alpha ppc sparc mips) (progn (assert-no-consing (dxclosure 42)) @@ -211,6 +242,8 @@ (assert-no-consing (cons-on-stack 42)) (assert-no-consing (nested-dx-conses)) (assert-no-consing (nested-dx-lists)) + (assert-consing (nested-dx-not-used *a-cons*)) + (assert-no-consing (nested-evil-dx-used *a-cons*)) (assert-no-consing (multiple-dx-uses)) ;; Not strictly DX.. (assert-no-consing (test-hash-table)) diff --git a/version.lisp-expr b/version.lisp-expr index a98686cba..4cea42f85 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.10.7" +"1.0.10.8" -- 2.11.4.GIT