From 09ba205d5ff72b9f4b1ffcf8743809c01a9c69e5 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 5 Jun 2009 13:08:35 +0000 Subject: [PATCH] 1.0.29.3: better reporting for failure to stack allocate * If the LVAR has no uses left, it is not good for DX. * When flushing the destination of a DX lvar, note that its uses will not be stack allocated. * Pull out the failure to stack allocate reporting into NOTE-NO-STACK-ALLOCATION, relax the filter to allow complaints about non-constant REFs, and omit notes for flushed and flushable combinations. TODO: the compiler should know about non-consing functions, so that it can avoid inane notes like "could not stack allocate the result of (CAR X)" should someone declare that DX. * Muffle compiler notes from WITH-PINNED-OBJECTS, since our paranoid use of DX-LET there is liable to cause lots of confusing "unable to stack allocate" notes. --- NEWS | 3 ++ src/compiler/ir1opt.lisp | 16 ++------- src/compiler/ir1util.lisp | 37 +++++++++++++++++++-- src/compiler/physenvanal.lisp | 6 +--- src/compiler/x86-64/macros.lisp | 1 + src/compiler/x86/macros.lisp | 1 + tests/dynamic-extent.impure.lisp | 70 ++++++++++++++++++++++++++++++---------- version.lisp-expr | 2 +- 8 files changed, 96 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 9e4f26528..f90c7201c 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- * optimization: more efficient type-checks for FIXNUMs when the value is known to be a signed word on x86 and x86-64. + * improvement: failure to provide requested stack allocation compiler notes + provided in all cases (requested stack allocation not happening without a + note being issued is now considered a bug.) * bug fix: on 64 bit platforms FILL worked incorrectly on arrays with upgraded element type (COMPLEX SINGLE-FLOAT), regression from 1.0.28.55. (thanks to Paul Khuong) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 860496043..b26cb6513 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -510,20 +510,8 @@ (delete-ref node) (unlink-node node)) (combination - (let ((kind (combination-kind node)) - (info (combination-fun-info node))) - (when (and (eq kind :known) (fun-info-p info)) - (let ((attr (fun-info-attributes info))) - (when (and (not (ir1-attributep attr call)) - ;; ### For now, don't delete potentially - ;; flushable calls when they have the CALL - ;; attribute. Someday we should look at the - ;; functional args to determine if they have - ;; any side effects. - (if (policy node (= safety 3)) - (ir1-attributep attr flushable) - (ir1-attributep attr unsafely-flushable))) - (flush-combination node)))))) + (when (flushable-combination-p node) + (flush-combination node))) (mv-combination (when (eq (basic-combination-kind node) :local) (let ((fun (combination-lambda node))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index d501d6708..d79da6b24 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -391,6 +391,34 @@ (awhen (node-lvar node) (lvar-dynamic-extent it))) +(defun flushable-combination-p (call) + (declare (combination call)) + (let ((kind (combination-kind call)) + (info (combination-fun-info call))) + (when (and (eq kind :known) (fun-info-p info)) + (let ((attr (fun-info-attributes info))) + (when (and (not (ir1-attributep attr call)) + ;; FIXME: For now, don't consider potentially flushable + ;; calls flushable when they have the CALL attribute. + ;; Someday we should look at the functional args to + ;; determine if they have any side effects. + (if (policy call (= safety 3)) + (ir1-attributep attr flushable) + (ir1-attributep attr unsafely-flushable))) + t))))) + +(defun note-no-stack-allocation (lvar &key flush) + (do-uses (use (principal-lvar lvar)) + (unless (or + ;; Don't complain about not being able to stack allocate constants. + (and (ref-p use) (constant-p (ref-leaf use))) + ;; If we're flushing, don't complain if we can flush the combination. + (and flush (combination-p use) (flushable-combination-p use))) + (let ((*compiler-error-context* use)) + (compiler-notify "could not stack allocate the result of ~S" + (find-original-source (node-source-path use))))))) + + (declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component)) boolean) use-good-for-dx-p)) (declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component)) @@ -415,9 +443,10 @@ (defun lvar-good-for-dx-p (lvar dx &optional component) (let ((uses (lvar-uses lvar))) (if (listp uses) - (every (lambda (use) - (use-good-for-dx-p use dx component)) - uses) + (when uses + (every (lambda (use) + (use-good-for-dx-p use dx component)) + uses)) (use-good-for-dx-p uses dx component)))) (defun known-dx-combination-p (use dx) @@ -1198,6 +1227,8 @@ (defun flush-dest (lvar) (declare (type (or lvar null) lvar)) (unless (null lvar) + (when (lvar-dynamic-extent lvar) + (note-no-stack-allocation lvar :flush t)) (setf (lvar-dest lvar) nil) (flush-lvar-externally-checkable-type lvar) (do-uses (use lvar) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index e43bf9e85..ec527cf97 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -340,11 +340,7 @@ (setf (lvar-dynamic-extent real) cleanup) (real-dx-lvars real))) (t - (do-uses (use lvar) - (unless (ref-p use) - (let ((*compiler-error-context* use)) - (compiler-notify "could not stack allocate the result of ~S" - (find-original-source (node-source-path use)))))) + (note-no-stack-allocation lvar) (setf (lvar-dynamic-extent lvar) nil))))) (node ; DX closure (let* ((call what) diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 771113023..a80b73e8f 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -521,6 +521,7 @@ collection." ;; BODY is stuffed in a function to preserve the lexical ;; environment. `(flet ((,wpo () (progn ,@body))) + (declare (muffle-conditions compiler-note)) ;; PINS are dx-allocated in case the compiler for some ;; unfathomable reason decides to allocate value-cells ;; for them -- since we have DX value-cells on x86oid diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index aa6f1e707..29d30093a 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -544,6 +544,7 @@ collection." ;; BODY is stuffed in a function to preserve the lexical ;; environment. `(flet ((,wpo () (progn ,@body))) + (declare (muffle-conditions compiler-note)) ;; PINS are dx-allocated in case the compiler for some ;; unfathomable reason decides to allocate value-cells ;; for them -- since we have DX value-cells on x86oid diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 0d1992d44..3620c6d0b 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -730,22 +730,58 @@ (serious-condition (c) (handle-loadtime-error c dest)))))))))) +(declaim (inline foovector barvector)) +(defun foovector (x y z) + (let ((v (make-array 3))) + (setf (aref v 0) x + (aref v 1) y + (aref v 2) z) + v)) +(defun barvector (x y z) + (make-array 3 :initial-contents (list x y z))) (with-test (:name :dx-compiler-notes) - (let ((n 0)) - (handler-bind ((compiler-note (lambda (c) - (declare (ignore cc)) - (incf n)))) - (compile nil `(lambda (x) - (let ((v (make-array x))) - (declare (dynamic-extent v)) - (length v)))) - (assert (= 1 n)) - (compile nil `(lambda (x) - (let ((y (if (plusp x) - (true x) - (true (- x))))) - (declare (dynamic-extent y)) - (print y) - nil))) - (assert (= 3 n))))) + (flet ((assert-notes (j lambda) + (let ((n 0)) + (handler-bind ((compiler-note (lambda (c) + (declare (ignore cc)) + (incf n)))) + (compile nil lambda) + (unless (= j n) + (error "Wanted ~S notes, got ~S for~% ~S" + j n lambda)))))) + ;; These ones should complain. + (assert-notes 1 `(lambda (x) + (let ((v (make-array x))) + (declare (dynamic-extent v)) + (length v)))) + (assert-notes 2 `(lambda (x) + (let ((y (if (plusp x) + (true x) + (true (- x))))) + (declare (dynamic-extent y)) + (print y) + nil))) + (assert-notes 1 `(lambda (x) + (let ((y (foovector x x x))) + (declare (sb-int:truly-dynamic-extent y)) + (print y) + nil))) + ;; These ones should not complain. + (assert-notes 0 `(lambda (name) + (with-alien + ((posix-getenv (function c-string c-string) + :EXTERN "getenv")) + (values + (alien-funcall posix-getenv name))))) + (assert-notes 0 `(lambda (x) + (let ((y (barvector x x x))) + (declare (dynamic-extent y)) + (print y) + nil))) + (assert-notes 0 `(lambda (list) + (declare (optimize (space 0))) + (sort list #'<))) + (assert-notes 0 `(lambda (other) + #'(lambda (s c n) + (ignore-errors (funcall other s c n))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 9f9e8bfaa..4c4695bc6 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.29.2" +"1.0.29.3" -- 2.11.4.GIT