From dc4be57ff0baeee18d43fbee1bfc1af4af50e522 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 13 Apr 2005 21:08:25 +0000 Subject: [PATCH] 0.8.21.37: fix bug 305 * annotate the inline/notinline fun with type-restrictions from the environment. --- BUGS | 11 ---------- NEWS | 2 ++ src/compiler/ir1tran.lisp | 48 +++++++++++++++++++++----------------------- tests/compiler.impure.lisp | 31 ++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 57 insertions(+), 37 deletions(-) diff --git a/BUGS b/BUGS index 0b795f0..ba4e1f1 100644 --- a/BUGS +++ b/BUGS @@ -1073,17 +1073,6 @@ WORKAROUND: The problem is that both EVALs sequentially write to the same LVAR. -305: - (Reported by Dave Roberts.) - Local INLINE/NOTINLINE declaration removes local FTYPE declaration: - - (defun quux (x) - (declare (ftype (function () (integer 0 10)) fee) - (inline fee)) - (1+ (fee))) - - uses generic arithmetic with INLINE and fixnum without. - 306: "Imprecise unions of array types" a.(defun foo (x) (declare (optimize speed) diff --git a/NEWS b/NEWS index 9fc6eaf..0692ab7 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21: *ERROR-OUTPUT*, not *STANDARD-OUTPUT*. * fixed inference of the upper bound of an iteration variable. (reported by Rajat Datta). + * fixed bug 305: INLINE/NOTINLINE declaration no longer causes local + ftype declaration to be disregarded. (reported by Dave Roberts) * fixed bug 373: caused by erronous compilation of references to alien variables in the runtime on ppc/darwin. * fixed bug 376: CONJUGATE type deriver. diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index d7cb33b..5f37066 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -66,7 +66,6 @@ (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) - (let ((where (info :function :where-from name))) (when (and (eq where :assumed) ;; In the ordinary target Lisp, it's silly to report @@ -988,11 +987,9 @@ (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked name - "declaring the ftype of ~A")) - (let ((found (find name fvars - :key #'leaf-source-name - :test #'equal))) + (compiler-assert-symbol-home-package-unlocked + name "declaring the ftype of ~A")) + (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found (setf (leaf-type found) type) @@ -1039,17 +1036,20 @@ res))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP -;;; (and TYPE if notinline). -(defun make-new-inlinep (var inlinep) +;;; (and TYPE if notinline), plus type-restrictions from the lexenv. +(defun make-new-inlinep (var inlinep local-type) (declare (type global-var var) (type inlinep inlinep)) - (let ((res (make-defined-fun - :%source-name (leaf-source-name var) - :where-from (leaf-where-from var) - :type (if (and (eq inlinep :notinline) - (not (eq (leaf-where-from var) :declared))) - (specifier-type 'function) - (leaf-type var)) - :inlinep inlinep))) + (let* ((type (if (and (eq inlinep :notinline) + (not (eq (leaf-where-from var) :declared))) + (specifier-type 'function) + (leaf-type var))) + (res (make-defined-fun + :%source-name (leaf-source-name var) + :where-from (leaf-where-from var) + :type (if local-type + (type-intersection local-type type) + type) + :inlinep inlinep))) (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) (defined-fun-inline-expansion var)) @@ -1063,14 +1063,11 @@ (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) - (let ((fvar (find name fvars - :key #'leaf-source-name - :test #'equal))) + (let ((fvar (find name fvars :key #'leaf-source-name :test #'equal))) (if fvar (setf (functional-inlinep fvar) sense) - (let ((found - (find-lexically-apparent-fun - name "in an inline or notinline declaration"))) + (let ((found (find-lexically-apparent-fun + name "in an inline or notinline declaration"))) (etypecase found (functional (when (policy *lexenv* (>= speed inhibit-warnings)) @@ -1078,9 +1075,10 @@ definition of local function:~% ~S" sense name))) (global-var - (push (cons name (make-new-inlinep found sense)) - new-fenv))))))) - + (let ((type + (cdr (assoc found (lexenv-type-restrictions res))))) + (push (cons name (make-new-inlinep found sense type)) + new-fenv)))))))) (if new-fenv (make-lexenv :default res :funs new-fenv) res))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index cf2a75e..94fa639 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -998,5 +998,36 @@ (print output) (assert (zerop (length output)))) +;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost + +(define-condition optimization-error (error) ()) + +(labels ((compile-lambda (type sense) + (handler-bind ((compiler-note (lambda (_) + (declare (ignore _)) + (error 'optimization-error)))) + (values + (compile + nil + `(lambda () + (declare + ,@(when type '((ftype (function () (integer 0 10)) bug-305))) + (,sense bug-305) + (optimize speed)) + (1+ (bug-305)))) + nil))) + (expect-error (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense)) + (assert (not f)) + (assert (typep e 'optimization-error)))) + (expect-pass (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense)) + (assert f) + (assert (not e))))) + (expect-error 'inline) + (expect-error 'notinline) + (expect-pass 'inline) + (expect-pass 'notinline)) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 3583ac7..665fecf 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".) -"0.8.21.36" +"0.8.21.37" -- 1.7.10.4