From: Nikodemus Siivola Date: Tue, 9 Aug 2011 07:57:41 +0000 (+0300) Subject: LOAD-TIME-VALUE improvements X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ed066199124c46998798122cc776e615c9c50372;p=sbcl.git LOAD-TIME-VALUE improvements * Derive the type of :TOPLEVEL lambdas properly. Without this we were never able to utilize the type from COMPILE-LOAD-TIME-STUFF. * Use the source-type whenever it is more accurate than the type from COMPILE-LOAD-TIME-STUFF -- eg. when using a value cell. * Add ALIAS argument to IR1-CONVERT, allowing saving alternate forms into *CURRENT-PATH*: this allows (defparameter *var* 10) (compile nil '(lambda () (the list (load-time-value *var*)))) to give the warning ; Derived type of *VAR* is ; (VALUES (INTEGER 10 10) &OPTIONAL), ; conflicting with its asserted type ; LIST. instead of the much less useful ; Constant 10 conflicts with its asserted type LIST. * Use THE-IN-POLICY directly in LOAD-TIME-VALUE, allowing the file- compiler to report the LOAD-TIME-VALUE form for type-conflicts instead of (TRULY-THE (%LOAD-TIME-VALUE ...)) --- diff --git a/NEWS b/NEWS index 82ae01e..783b9e9 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,7 @@ changes relative to sbcl-1.0.50: 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. @@ -23,6 +24,10 @@ changes relative to sbcl-1.0.50: * 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 diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index adc591a..a921fc8 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -147,7 +147,7 @@ (case (functional-kind fun) (:external (finalize-xep-definition fun)) - ((nil) + ((nil :toplevel) (setf (leaf-type fun) (definition-type fun))))) (maphash #'note-failed-optimization diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index db5bf38..984db31 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -43,6 +43,11 @@ (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))) @@ -531,7 +536,8 @@ ;;;; 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 @@ -560,11 +566,9 @@ ;; 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))) diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp index cbeba89..e733b15 100644 --- a/src/compiler/ltv.lisp +++ b/src/compiler/ltv.lisp @@ -44,6 +44,8 @@ guaranteed to never be modified, so it can be put in read-only storage." ((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. @@ -52,32 +54,33 @@ guaranteed to never be modified, so it can be put in read-only storage." (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)) diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 9da9acf..ade8555 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -531,7 +531,7 @@ (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))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 2c73809..38690b4 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1235,6 +1235,69 @@ (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)))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d88203e..38640aa 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3071,20 +3071,6 @@ (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))