From: Nikodemus Siivola Date: Sun, 28 Jun 2009 21:18:44 +0000 (+0000) Subject: 1.0.29.53: some LOAD-TIME-VALUE smartness X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f09f67b4233004079affc70de2ef2d49f27ca91a;p=sbcl.git 1.0.29.53: some LOAD-TIME-VALUE smartness * Implicit READ-ONLY-P for obviously immutable values. * Annotate the result with a derived type -- in practice the obvious declarared type of the function, if any. * In the test suite organize compiler tests a bit: ** compiler-test-util.lisp has some general-purpose tools for determining if the compiled code passes muster. ** Move some pure tests from compiler.impure.lisp to the pure file: they were in the impure file because they defined utils which are now in the COMPILER-TEST-UTIL (aka CUA) package. --- diff --git a/NEWS b/NEWS index 1c3a7af..5e77bc5 100644 --- a/NEWS +++ b/NEWS @@ -28,6 +28,7 @@ callees. * optimization: several character functions are now compiled somewhat more efficiently. (reported by Lynn Quam) + * optimization: the compiler now derives simple types for LOAD-VALUE-FORMs. * improvement: less unsafe constant folding in floating point arithmetic, especially for mixed complex/real -float operations. * improvement: complex float division is slightly more stable. diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp index e64cc8a..b7c705c 100644 --- a/src/compiler/ltv.lisp +++ b/src/compiler/ltv.lisp @@ -16,21 +16,54 @@ (def-ir1-translator load-time-value ((form &optional read-only-p) start next result) #!+sb-doc - "Arrange for FORM to be evaluated at load-time and use the value produced - as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant - object is guaranteed to never be modified, so it can be put in read-only - storage." - (let ((*allow-instrumenting* nil)) + "Arrange for FORM to be evaluated at load-time and use the value produced as +if it were a constant. If READ-ONLY-P is non-NIL, then the resultant object is +guaranteed to never be modified, so it can be put in read-only storage." + (let ((*allow-instrumenting* nil) + ;; First derive an approximate type from the source form, because it allows + ;; us to use READ-ONLY-P implicitly. + ;; + ;; We also use this type to augment whatever COMPILE-LOAD-TIME-VALUE + ;; returns -- in practice it returns *WILD-TYPE* all the time, but + ;; theoretically it could return something useful for the READ-ONLY-P case. + (source-type (single-value-type + (cond ((consp form) + (let ((op (car form))) + (cond ((member op '(the truly-the)) + (specifier-type (second form))) + ((eq 'function op) + (specifier-type 'function)) + ((and (legal-fun-name-p op) + (eq :declared (info :function :where-from op))) + (fun-type-returns (info :function :type op))) + (t + *wild-type*)))) + ((and (symbolp form) + (eq :declared (info :variable :where-from form))) + (info :variable :type form)) + (t + *universal-type*))))) + ;; Implictly READ-ONLY-P for immutable objects. + (when (and (not read-only-p) + (csubtypep source-type (specifier-type '(or character number)))) + (setf read-only-p t)) (if (producing-fasl-file) (multiple-value-bind (handle type) + ;; Value cells are allocated for non-READ-ONLY-P stop the compiler + ;; from complaining about constant modification -- it seems that + ;; we should be able to elide them all the time if we had a way + ;; of telling the compiler that "this object isn't really a constant + ;; the way you think". --NS 2009-06-28 (compile-load-time-value (if read-only-p form `(make-value-cell ,form))) - (declare (ignore type)) - (ir1-convert start next result - (if read-only-p - `(%load-time-value ',handle) - `(value-cell-ref (%load-time-value ',handle))))) + (when (eq *wild-type* type) + (setf type source-type)) + (let ((value-form + (if read-only-p + `(%load-time-value ',handle) + `(value-cell-ref (%load-time-value ',handle))))) + (ir1-convert start next result `(truly-the ,type ,value-form)))) (let ((value (handler-case (eval form) (error (condition) @@ -39,7 +72,9 @@ (ir1-convert start next result (if read-only-p `',value - `(value-cell-ref ',(make-value-cell value)))))))) + `(truly-the ,(ctype-of value) + (value-cell-ref + ',(make-value-cell value))))))))) (defoptimizer (%load-time-value ir2-convert) ((handle) node block) (aver (constant-lvar-p handle)) diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index f2a5d3d..bf6231e 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -1,5 +1,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (load "assertoid.lisp") + (load "compiler-test-util.lisp") + (load "test-util.lisp") (use-package "ASSERTOID")) ;;; bug 254: compiler falure @@ -517,3 +519,18 @@ (write-line "foo-0")) (foo) + +;;; LOAD-TIME-VALUE smartness +(defun load-time-value-type-derivation-test-1 () + (ctu:compiler-derived-type (load-time-value (cons 'foo 0)))) +(defun load-time-value-type-derivation-test-2 () + (ctu:compiler-derived-type (load-time-value (+ (or *print-length* 0) 10)))) +(defun load-time-value-auto-read-only-p () + (load-time-value (random most-positive-fixnum))) +(defun load-time-value-boring () + (load-time-value (cons t t))) +(test-util:with-test (:name (load-time-value :type-smartness/cload)) + (assert (eq 'cons (load-time-value-type-derivation-test-1))) + (assert (eq 'number (load-time-value-type-derivation-test-2))) + (assert (not (ctu:find-value-cell-values #'load-time-value-auto-read-only-p))) + (assert (ctu:find-value-cell-values #'load-time-value-boring))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9b509c2..6795171 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1850,37 +1850,4 @@ (setf *mystery* :mystery) (assert (eq :ok (test-mystery (make-thing :slot :mystery)))) -;;; optimizing make-array -(defun count-code-callees (f) - (let ((code (sb-kernel:fun-code-header f)) - (n 0)) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) - do (when (typep c 'fdefn) - (print c) - (incf n))) - n)) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '(3) :initial-contents (list x y z))))))) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '3 :initial-contents (vector x y z))))))) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '3 :initial-contents `(,x ,y ,z))))))) - -;;; optimizing (EXPT -1 INTEGER) -(test-util:with-test (:name (expt minus-one integer)) - (dolist (x '(-1 -1.0 -1.0d0)) - (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x)))))) - (assert (zerop (count-code-callees fun))) - (dotimes (i 12) - (if (oddp i) - (assert (eql x (funcall fun i))) - (assert (eql (- x) (funcall fun i)))))))) - ;;; success diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 801db54..afe9767 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -11,18 +11,10 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(cl:in-package :sb-c) - -(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe)) - -(deftransform compiler-derived-type ((x)) - `(values ',(type-specifier (lvar-type x)) t)) - -(defun compiler-derived-type (x) - (values t nil)) - (cl:in-package :cl-user) +(load "compiler-test-util.lisp") + ;; The tests in this file assume that EVAL will use the compiler (when (eq sb-ext:*evaluator-mode* :interpret) (invoke-restart 'run-tests::skip-file)) @@ -2585,7 +2577,7 @@ (assert (eq 'character (funcall (compile nil '(lambda (s) - (sb-c::compiler-derived-type (aref (the string s) 0)))) + (ctu:compiler-derived-type (aref (the string s) 0)))) "foo")))) (with-test (:name :base-string-aref-type) @@ -2593,7 +2585,7 @@ #-sb-unicode 'character (funcall (compile nil '(lambda (s) - (sb-c::compiler-derived-type (aref (the base-string s) 0)))) + (ctu:compiler-derived-type (aref (the base-string s) 0)))) (coerce "foo" 'base-string))))) (with-test (:name :dolist-constant-type-derivation) @@ -2602,7 +2594,7 @@ '(lambda (x) (dolist (y '(1 2 3)) (when x - (return (sb-c::compiler-derived-type y)))))) + (return (ctu:compiler-derived-type y)))))) t)))) (with-test (:name :dolist-simple-list-type-derivation) @@ -2611,7 +2603,7 @@ '(lambda (x) (dolist (y (list 1 2 3)) (when x - (return (sb-c::compiler-derived-type y)))))) + (return (ctu:compiler-derived-type y)))))) t)))) (with-test (:name :dolist-dotted-constant-list-type-derivation) @@ -2621,7 +2613,7 @@ '(lambda (x) (dolist (y '(1 2 3 . 4) :foo) (when x - (return (sb-c::compiler-derived-type y))))))))) + (return (ctu:compiler-derived-type y))))))))) (assert (equal '(integer 1 3) (funcall fun t))) (assert (= 1 (length warned))) (multiple-value-bind (res err) (ignore-errors (funcall fun nil)) @@ -2679,7 +2671,7 @@ (with-test (:name :rest-list-type-derivation) (multiple-value-bind (type derivedp) (funcall (compile nil `(lambda (&rest args) - (sb-c::compiler-derived-type args))) + (ctu:compiler-derived-type args))) nil) (assert (eq 'list type)) (assert derivedp))) @@ -2941,3 +2933,42 @@ (compile nil `(lambda (x y) (declare (character x y) (optimize speed)) (,name x y))))))) + +;;; optimizing make-array +(with-test (:name (make-array :open-code-initial-contents)) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '(3) :initial-contents (list x y z))))))) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '3 :initial-contents (vector x y z))))))) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '3 :initial-contents `(,x ,y ,z)))))))) + +;;; optimizing (EXPT -1 INTEGER) +(test-util:with-test (:name (expt minus-one integer)) + (dolist (x '(-1 -1.0 -1.0d0)) + (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x)))))) + (assert (not (ctu:find-named-callees fun))) + (dotimes (i 12) + (if (oddp i) + (assert (eql x (funcall fun i))) + (assert (eql (- x) (funcall fun i)))))))) + +(with-test (:name (load-time-value :type-derivation)) + (flet ((test (type form value-cell-p) + (let ((derived (funcall (compile + nil + `(lambda () + (ctu:compiler-derived-type + (load-time-value ,form))))))) + (unless (equal type derived) + (error "wanted ~S, got ~S" type derived))))) + (let ((* 10)) + (test '(integer 11 11) '(+ * 1) nil)) + (let ((* "fooo")) + (test '(integer 4 4) '(length *) t)))) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index 953314d..08a41c6 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -12,9 +12,10 @@ ;;;; more information. (load "test-util.lisp") +(load "compiler-test-util.lisp") (defpackage "CTOR-TEST" - (:use "CL" "TEST-UTIL")) + (:use "CL" "TEST-UTIL" "COMPILER-TEST-UTIL")) (in-package "CTOR-TEST") @@ -87,27 +88,10 @@ (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4)) ;;; Tests for CTOR optimization of non-constant class args and constant class object args -(defun find-ctor-cache (f) - (let ((code (sb-kernel:fun-code-header f))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) - do (when (= sb-vm::value-cell-header-widetag (sb-kernel:widetag-of c)) - (let ((c (sb-vm::value-cell-ref c))) - (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c))) - (return c))))))) - -;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this -;;; as well. -(defun find-callee (f &key (type t) (name nil namep)) - (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun f)))) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) - do (when (typep c 'sb-impl::fdefn) - (let ((fun (sb-impl::fdefn-fun c))) - (when (and (typep fun type) - (or (not namep) - (equal name (sb-impl::fdefn-name c)))) - (return fun))))))) +(defun find-ctor-caches (fun) + (remove-if-not (lambda (value) + (and (consp value) (eq 'sb-pcl::ctor-cache (car value)))) + (find-value-cell-values fun))) (let* ((cmacro (compiler-macro-function 'make-instance)) (opt 0) @@ -124,25 +108,25 @@ (assert (= 0 opt)) (let ((f (compile nil `(lambda (class) (make-instance class :b t))))) - (assert (find-ctor-cache f)) + (assert (= 1 (length (find-ctor-caches f)))) (assert (= 1 opt)) (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass)))) (with-test (:name (make-instance :constant-class-object)) (let ((f (compile nil `(lambda () (make-instance ,(find-class 'one-slot-subclass) :b t))))) - (assert (not (find-ctor-cache f))) + (assert (not (find-ctor-caches f))) (assert (= 2 opt)) (assert (typep (funcall f) 'one-slot-subclass)))) (with-test (:name (make-instance :constant-non-std-class-object)) (let ((f (compile nil `(lambda () (make-instance ,(find-class 'structure-object)))))) - (assert (not (find-ctor-cache f))) + (assert (not (find-ctor-caches f))) (assert (= 3 opt)) (assert (typep (funcall f) 'structure-object)))) (with-test (:name (make-instance :constant-non-std-class-name)) (let ((f (compile nil `(lambda () (make-instance 'structure-object))))) - (assert (not (find-ctor-cache f))) + (assert (not (find-ctor-caches f))) (assert (= 4 opt)) (assert (typep (funcall f) 'structure-object))))) (setf (compiler-macro-function 'make-instance) cmacro)))) @@ -152,8 +136,10 @@ (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+) collect (class-name (eval `(defclass ,(gentemp) () ()))))) (count 0) - (cache (find-ctor-cache f))) + (caches (find-ctor-caches f)) + (cache (pop caches))) (assert cache) + (assert (not caches)) (assert (not (cdr cache))) (dolist (class classes) (assert (typep (funcall f (if (oddp count) class (find-class class))) class)) @@ -186,8 +172,10 @@ (let ((fun (compile nil `(lambda () (make-instance 'some-class))))) (assert (aroundp (funcall fun))) ;; make sure we tested what we think we tested... - (let ((ctor (find-callee fun :type 'sb-pcl::ctor))) - (assert (find-callee ctor :name 'sb-pcl::fast-make-instance))))) + (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor))) + (assert ctors) + (assert (not (cdr ctors))) + (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance))))) ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs ;;; in more interesting cases as well... @@ -213,8 +201,10 @@ (assert (aroundp (funcall fun))) (assert (= 2 *some-counter*)) ;; make sure we tested what we think we tested... - (let ((ctor (find-callee fun :type 'sb-pcl::ctor))) - (assert (find-callee ctor :name 'sb-pcl::fast-make-instance))))) + (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor))) + (assert ctors) + (assert (not (cdr ctors))) + (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance))))) ;;; No compiler notes, please (locally (declare (optimize safety))