From 8b1ad2754eff900f83ca41a0ab853d79fc662854 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 4 Aug 2009 10:59:09 +0000 Subject: [PATCH] 1.0.30.34: flushable INITIALIZE-VECTOR * Allows deleting simple unused MAKE-ARRAY and VECTOR combinations. * Move ASSERT-NO-CONSING and ASSERT-CONSING to compiler-test-util.lisp, so that they can be used outside dynamic-extent.impure.lisp. --- NEWS | 1 + src/compiler/generic/vm-fndb.lisp | 2 +- tests/compiler-test-util.lisp | 24 +++++++++++++++++++++++- tests/compiler.pure.lisp | 7 +++++++ tests/dynamic-extent.impure.lisp | 23 +++-------------------- version.lisp-expr | 2 +- 6 files changed, 36 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index 7bdf0e5..7986978 100644 --- a/NEWS +++ b/NEWS @@ -19,6 +19,7 @@ changes relative to sbcl-1.0.30: constant two has been optimized. * optimization: ARRAY-IN-BOUNDS-P is resolved at compile-time when sufficient type information is available. (thanks to Leslie Polzer) + * optimization: unused vector creation can now be optimized away. * improvement: a STYLE-WARNING is signalled when a generic function clobbers an earlier FTYPE proclamation. * improvement: the compiler is able to track the effective type of diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 299f49f..a47798e 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -90,7 +90,7 @@ (defknown initialize-vector ((simple-array * (*)) &rest t) (simple-array * (*)) - (always-translatable) + (always-translatable flushable) :result-arg 0) (defknown vector-fill* (t t t t) vector diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp index 1ed4fa6..66685b9 100644 --- a/tests/compiler-test-util.lisp +++ b/tests/compiler-test-util.lisp @@ -14,7 +14,9 @@ (defpackage :compiler-test-util (:nicknames :ctu) (:use :cl :sb-c :sb-kernel) - (:export #:compiler-derived-type + (:export #:assert-consing + #:assert-no-consing + #:compiler-derived-type #:find-value-cell-values #:find-named-callees)) @@ -46,3 +48,23 @@ (or (not namep) (equal name (sb-impl::fdefn-name c)))))) collect (sb-impl::fdefn-fun c)))) + +(defmacro assert-no-consing (form &optional times) + `(%assert-no-consing (lambda () ,form) ,times)) +(defun %assert-no-consing (thunk &optional times) + (let ((before (sb-ext:get-bytes-consed)) + (times (or times 10000))) + (declare (type (integer 1 *) times)) + (dotimes (i times) + (funcall thunk)) + (assert (< (- (sb-ext:get-bytes-consed) before) times)))) + +(defmacro assert-consing (form &optional times) + `(%assert-consing (lambda () ,form) ,times)) +(defun %assert-consing (thunk &optional times) + (let ((before (sb-ext:get-bytes-consed)) + (times (or times 10000))) + (declare (type (integer 1 *) times)) + (dotimes (i times) + (funcall thunk)) + (assert (not (< (- (sb-ext:get-bytes-consed) before) times))))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 60289eb..b3ef02c 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3225,3 +3225,10 @@ (let ((f (compile nil `(lambda () (labels ((k (&optional x) #'k))))))) (assert (null (funcall f))))) + +(with-test (:name :flush-vector-creation) + (let ((f (compile nil `(lambda () + (dotimes (i 1024) + (vector i i i)) + t)))) + (ctu:assert-no-consing (funcall f)))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 769ce5d..fec3839 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -14,6 +14,9 @@ (when (eq sb-ext:*evaluator-mode* :interpret) (sb-ext:quit :unix-status 104)) +(load "compiler-test-util.lisp") +(use-package :ctu) + (setq sb-c::*check-consistency* t sb-ext:*stack-allocate-dynamic-extent* t) @@ -481,26 +484,6 @@ (setf (gethash 5 *table*) 13) (gethash 5 *table*)) -(defmacro assert-no-consing (form &optional times) - `(%assert-no-consing (lambda () ,form) ,times)) -(defun %assert-no-consing (thunk &optional times) - (let ((before (get-bytes-consed)) - (times (or times 10000))) - (declare (type (integer 1 *) times)) - (dotimes (i times) - (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)) (progn diff --git a/version.lisp-expr b/version.lisp-expr index 3da7221..e822dfe 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.30.33" +"1.0.30.34" -- 1.7.10.4