* 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.
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.
(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)
(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))
(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
(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)))
(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
;;;; 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))
(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)
#-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)
'(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)
'(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)
'(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))
(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)))
(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))))
;;;; 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")
\f
(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)
(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))))
(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))
(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...
(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))
projects / sbcl.git / commitdiff