chroot. (Use "SBCL_ARCH=x86 sh make.sh" to build.)
* optimization: unsigned integer divisions by a constant are implemented
using multiplication (affects CEILING, FLOOR, TRUNCATE, MOD, and REM.)
+ * optimization: improved type-derivation for LOAD-TIME-VALUE.
* bug fix: correct RIP offset calculation in SSE comparison and shuffle
instructions. (lp#814688)
* bug fix: COERCE to unfinalized extended sequence classes now works.
* bug fix: SSE comparison instructions can be disassembled even when one
operand is in memory. (lp#814702)
* bug fix: incomplete writes when not using SERVE-EVENTS. (lp#820599)
+ * bug fix: MULTIPLE-VALUE-BIND + VALUES -> LET conversion could lose derived
+ type information associated with the VALUES form.
+ * bug fix: broken warnings/errors for type-errors involving LOAD-TIME-VALUE
+ forms. (lp#823014)
changes in sbcl-1.0.50 relative to sbcl-1.0.49:
* enhancement: errors from FD handlers now provide a restart to remove
(case (functional-kind fun)
(:external
(finalize-xep-definition fun))
- ((nil)
+ ((nil :toplevel)
(setf (leaf-type fun) (definition-type fun)))))
(maphash #'note-failed-optimization
(when (source-form-has-path-p form)
(gethash form *source-paths*)))
+(defun ensure-source-path (form)
+ (or (get-source-path form)
+ (cons (simplify-source-path-form form)
+ *current-path*)))
+
(defun simplify-source-path-form (form)
(if (consp form)
(let ((op (car form)))
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
-(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t &optional t)
+ (values))
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a condition signalling form
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (defun ir1-convert (start next result form)
+ (defun ir1-convert (start next result form &optional alias)
(ir1-error-bailout (start next result form)
- (let* ((*current-path* (or (get-source-path form)
- (cons (simplify-source-path-form form)
- *current-path*)))
+ (let* ((*current-path* (ensure-source-path (or alias form)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
((and (symbolp form)
(eq :declared (info :variable :where-from form)))
(info :variable :type form))
+ ((constantp form)
+ (ctype-of (eval form)))
(t
*universal-type*)))))
;; Implictly READ-ONLY-P for immutable objects.
(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
+ ;; 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)))
- (when (eq *wild-type* type)
+ (unless (csubtypep type source-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)
- (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
- condition)))))
- (ir1-convert start next result
- (if read-only-p
- `',value
- `(truly-the ,(ctype-of value)
- (value-cell-ref
- ',(make-value-cell value)))))))))
+ (if read-only-p
+ `(%load-time-value ',handle)
+ `(value-cell-ref (%load-time-value ',handle)))))
+ (the-in-policy type value-form '((type-check . 0))
+ start next result)))
+ (let* ((value
+ (handler-case (eval form)
+ (error (condition)
+ (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
+ condition)))))
+ (if read-only-p
+ (ir1-convert start next result `',value nil)
+ (the-in-policy (ctype-of value) `(value-cell-ref ,(make-value-cell value))
+ '((type-check . 0))
+ start next result))))))
(defoptimizer (%load-time-value ir2-convert) ((handle) node block)
(aver (constant-lvar-p handle))
(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 (equal '(integer 10) (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)))
(assert (macro-function 'bug-795705))
(fmakunbound 'bug-795705)
(assert (not (macro-function 'bug-795705))))
+
+(with-test (:name (load-time-value :type-derivation))
+ (let ((name 'load-time-value-type-derivation-test))
+ (labels ((funtype (fun)
+ (sb-kernel:type-specifier
+ (sb-kernel:single-value-type
+ (sb-kernel:fun-type-returns
+ (sb-kernel:specifier-type
+ (sb-kernel:%simple-fun-type fun))))))
+ (test (type1 type2 form value-cell-p)
+ (let* ((lambda-form `(lambda ()
+ (load-time-value ,form)))
+ (core-fun (compile nil lambda-form))
+ (core-type (funtype core-fun))
+ (core-cell (ctu:find-value-cell-values core-fun))
+ (defun-form `(defun ,name ()
+ (load-time-value ,form)))
+ (file-fun (progn
+ (ctu:file-compile (list defun-form) :load t)
+ (symbol-function name)))
+ (file-type (funtype file-fun))
+ (file-cell (ctu:find-value-cell-values file-fun)))
+ (if value-cell-p
+ (assert (and core-cell file-cell))
+ (assert (not (or core-cell file-cell))))
+ (unless (subtypep core-type type1)
+ (error "core: wanted ~S, got ~S" type1 core-type))
+ (unless (subtypep file-type type2)
+ (error "file: wanted ~S, got ~S" type2 file-type)))))
+ (let ((* 10))
+ (test '(integer 11 11) 'number
+ '(+ * 1) nil))
+ (let ((* "fooo"))
+ (test '(integer 4 4) 'unsigned-byte
+ '(length *) nil))
+ (test '(integer 10 10) '(integer 10 10) 10 nil)
+ (test 'cons 'cons '(cons t t) t))))
+
+(with-test (:name (load-time-value :errors))
+ (multiple-value-bind (warn fail)
+ (ctu:file-compile
+ `((defvar *load-time-value-error-value* 10)
+ (declaim (fixnum *load-time-value-error-value*))
+ (defun load-time-value-error-test-1 ()
+ (the list (load-time-value *load-time-value-error-value*))))
+ :load t)
+ (assert warn)
+ (assert fail))
+ (handler-case (load-time-value-error-test-1)
+ (type-error (e)
+ (and (eql 10 (type-error-datum e))
+ (eql 'list (type-error-expected-type e)))))
+ (multiple-value-bind (warn2 fail2)
+ (ctu:file-compile
+ `((defun load-time-value-error-test-2 ()
+ (the list (load-time-value 10))))
+ :load t)
+ (assert warn2)
+ (assert fail2))
+ (handler-case (load-time-value-error-test-2)
+ (type-error (e)
+ (and (eql 10 (type-error-datum e))
+ (eql 'list (type-error-expected-type e))))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(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))))
-
(with-test (:name :float-division-using-exact-reciprocal)
(flet ((test (lambda-form arg res &key (check-insts t))
(let* ((fun (compile nil lambda-form))
projects / sbcl.git / commitdiff