From 757091b10a73a7f6e2bd673bcf990ac93f23f77c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 6 May 2009 15:50:19 +0000 Subject: [PATCH] 1.0.28.18: better TRULY-DYNAMIC-EXTENT handling Since RECHECK-DYNAMIC-EXTENT-LVARS passes T as the DX type, TRULY-DYNAMIC-EXTENT did not unconditionally allow DX allocation regardless of policy, as was the intention. Save the LVARs initially along with the DX type (T or :TRULY), so that R-D-E-L can use the correct DX type when rechecking. Test case. --- src/compiler/debug.lisp | 7 +++- src/compiler/ir1util.lisp | 2 +- src/compiler/locall.lisp | 6 ++-- src/compiler/node.lisp | 2 -- src/compiler/physenvanal.lisp | 69 +++++++++++++++++++------------------- tests/dynamic-extent.impure.lisp | 8 +++++ version.lisp-expr | 2 +- 7 files changed, 54 insertions(+), 42 deletions(-) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 7e21398..155b847 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -1009,7 +1009,12 @@ (case (cleanup-kind cleanup) ((:dynamic-extent) (format t "entry DX~{ v~D~}" - (mapcar #'cont-num (cleanup-info cleanup)))) + (mapcar (lambda (lvar-or-cell) + (if (consp lvar-or-cell) + (cons (car lvar-or-cell) + (cont-num (cdr lvar-or-cell))) + (cont-num lvar-or-cell))) + (cleanup-info cleanup)))) (t (format t "entry ~S" (entry-exits node)))))) (exit diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 34a9a58..64182a2 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -191,7 +191,7 @@ (setf (lvar-dynamic-extent old) nil) (unless (lvar-dynamic-extent new) (setf (lvar-dynamic-extent new) it) - (setf (cleanup-info it) (substitute new old (cleanup-info it))))) + (setf (cleanup-info it) (subst new old (cleanup-info it))))) (when (lvar-dynamic-extent new) (do-uses (node new) (node-ends-block node)))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index fe8af57..1c6db26 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -65,7 +65,7 @@ (let* ((other (trivial-lambda-var-ref-lvar use))) (unless (eq other lvar) (handle-nested-dynamic-extent-lvars dx other))))))) - (cons lvar + (cons (cons dx lvar) (if (listp uses) (loop for use in uses when (use-good-for-dx-p use dx) @@ -95,8 +95,8 @@ (make-lexenv :default (node-lexenv call) :cleanup cleanup)) (push entry (lambda-entries (node-home-lambda entry))) - (dolist (lvar dx-lvars) - (setf (lvar-dynamic-extent lvar) cleanup))))) + (dolist (cell dx-lvars) + (setf (lvar-dynamic-extent (cdr cell)) cleanup))))) (values)) ;;; This function handles merging the tail sets if CALL is potentially diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 3554d01..cb167fd 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -465,8 +465,6 @@ kind mess-up (info :test info)) -(defmacro cleanup-nlx-info (cleanup) - `(cleanup-info ,cleanup)) ;;; A PHYSENV represents the result of physical environment analysis. ;;; diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index e006827..592c002 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -251,7 +251,7 @@ (setf (nlx-info-target info) new-block) (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit)) (push info (physenv-nlx-info env)) - (push info (cleanup-nlx-info cleanup)) + (push info (cleanup-info cleanup)) (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) (setf (node-lexenv (block-last new-block)) (node-lexenv entry)))) @@ -328,40 +328,41 @@ (declare (type component component)) (dolist (lambda (component-lambdas component)) (loop for entry in (lambda-entries lambda) - for cleanup = (entry-cleanup entry) - do (when (eq (cleanup-kind cleanup) :dynamic-extent) - (collect ((real-dx-lvars)) - (loop for what in (cleanup-info cleanup) - do (etypecase what - (lvar - (if (lvar-good-for-dx-p what t component) - (let ((real (principal-lvar what))) + for cleanup = (entry-cleanup entry) + do (when (eq (cleanup-kind cleanup) :dynamic-extent) + (collect ((real-dx-lvars)) + (loop for what in (cleanup-info cleanup) + do (etypecase what + (cons + (let ((lvar (cdr what))) + (if (lvar-good-for-dx-p lvar (car what) component) + (let ((real (principal-lvar lvar))) (setf (lvar-dynamic-extent real) cleanup) (real-dx-lvars real)) - (setf (lvar-dynamic-extent what) nil))) - (node ; DX closure - (let* ((call what) - (arg (first (basic-combination-args call))) - (funs (lvar-value arg)) - (dx nil)) - (dolist (fun funs) - (binding* ((() (leaf-dynamic-extent fun) - :exit-if-null) - (xep (functional-entry-fun fun) - :exit-if-null) - (closure (physenv-closure - (get-lambda-physenv xep)))) - (cond (closure - (setq dx t)) - (t - (setf (leaf-dynamic-extent fun) nil))))) - (when dx - (setf (lvar-dynamic-extent arg) cleanup) - (real-dx-lvars arg)))))) - (let ((real-dx-lvars (delete-duplicates (real-dx-lvars)))) - (setf (cleanup-info cleanup) real-dx-lvars) - (setf (component-dx-lvars component) - (append real-dx-lvars (component-dx-lvars component)))))))) + (setf (lvar-dynamic-extent lvar) nil)))) + (node ; DX closure + (let* ((call what) + (arg (first (basic-combination-args call))) + (funs (lvar-value arg)) + (dx nil)) + (dolist (fun funs) + (binding* ((() (leaf-dynamic-extent fun) + :exit-if-null) + (xep (functional-entry-fun fun) + :exit-if-null) + (closure (physenv-closure + (get-lambda-physenv xep)))) + (cond (closure + (setq dx t)) + (t + (setf (leaf-dynamic-extent fun) nil))))) + (when dx + (setf (lvar-dynamic-extent arg) cleanup) + (real-dx-lvars arg)))))) + (let ((real-dx-lvars (delete-duplicates (real-dx-lvars)))) + (setf (cleanup-info cleanup) real-dx-lvars) + (setf (component-dx-lvars component) + (append real-dx-lvars (component-dx-lvars component)))))))) (values)) ;;;; cleanup emission @@ -404,7 +405,7 @@ (reanalyze-funs fun) (code `(%funcall ,fun)))) ((:block :tagbody) - (dolist (nlx (cleanup-nlx-info cleanup)) + (dolist (nlx (cleanup-info cleanup)) (code `(%lexical-exit-breakup ',nlx)))) (:dynamic-extent (when (not (null (cleanup-info cleanup))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index aba5a18..ae9a31c 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -153,6 +153,13 @@ (true v) nil)) +(defun force-make-array-on-stack (n) + (declare (optimize safety)) + (let ((v (make-array (min n 1)))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + nil)) + ;;; MAKE-STRUCTURE (declaim (inline make-fp-struct-1)) @@ -477,6 +484,7 @@ (assert-no-consing (dx-value-cell 13)) (assert-no-consing (cons-on-stack 42)) (assert-no-consing (make-array-on-stack)) + (assert-no-consing (force-make-array-on-stack 128)) (assert-no-consing (make-foo1-on-stack 123)) (assert-no-consing (nested-good 42)) (#+raw-instance-init-vops assert-no-consing diff --git a/version.lisp-expr b/version.lisp-expr index b64c0f1..24dc46d 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.28.17" +"1.0.28.18" -- 1.7.10.4