From 0ca182b2e0fd9a7fc8005bef9d21000b326208fc Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 6 Mar 2006 17:48:10 +0000 Subject: [PATCH] 0.9.10.17: fix bug #400, aka more correct CONSTANTP * To know that a function call is a constant we need to check that it doesn't signal an error in addition to knowing that the function is foldable. * To know that a THE form is constant we need to check that the value is of the right type and be prepared to deal with malformed type specifiers. * Tests, tests, tests. ...all in all, I'm starting to miss the evaluator branch. --- BUGS | 10 ++-------- src/compiler/constantp.lisp | 28 +++++++++++++++++----------- tests/compiler.pure.lisp | 4 ++++ tests/eval.impure.lisp | 10 ++++++++++ version.lisp-expr | 2 +- 5 files changed, 34 insertions(+), 20 deletions(-) diff --git a/BUGS b/BUGS index b5f60a6..1960b90 100644 --- a/BUGS +++ b/BUGS @@ -2074,9 +2074,6 @@ WORKAROUND: the right fix is to remove the abstraction violation in the compiler's type deriver. -392: slot-accessor for subclass misses obsoleted superclass - (fixed in sbcl-0.9.7.9) - 393: Wrong error from methodless generic function (DEFGENERIC FOO (X)) (FOO 1 2) @@ -2151,9 +2148,6 @@ WORKAROUND: For some more details see comments for (define-alien-type-method (c-string :deport-gen) ...) in host-c-call.lisp. -399: LOOP FOR ACROSS and full call to DATA-VECTOR-REF - (fixed in sbcl-0.9.9.x) - 400: "aggressive constant folding" - (compile nil '(lambda () (or t (the integer (/ 1 0))))) - signals an error. + (fixed in sbcl-0.9.10.17) + diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp index 97e27a9..0e2f4af 100644 --- a/src/compiler/constantp.lisp +++ b/src/compiler/constantp.lisp @@ -81,9 +81,16 @@ (let ((info (info :function :info name))) (and info (ir1-attributep (fun-info-attributes info) foldable))) - (every (lambda (arg) - (%constantp arg environment envp)) - (cdr form))))) + (and (every (lambda (arg) + (%constantp arg environment envp)) + (cdr form)) + ;; Even though the function may be marked as foldable + ;; the call may still signal an error -- eg: (CAR 1). + (handler-case + (progn + (constant-function-call-value form environment envp) + t) + (error () nil)))))) (defun constant-function-call-value (form environment envp) (apply (fdefinition (car form)) @@ -172,14 +179,13 @@ constantness of the FORM in ENVIRONMENT." :test (every #'constantp* (cons protected-form cleanup-forms)) :eval (constant-form-value* protected-form)) - (defconstantp the (value-type form) - :test (constantp* form) - :eval (let ((value (constant-form-value* form))) - (if (typep value value-type) - value - (error 'type-error - :datum value - :expected-type value-type)))) + (defconstantp the (type form) + :test (and (constantp* form) + (handler-case + ;; in case the type-spec is malformed! + (typep (constant-form-value* form) type) + (error () nil))) + :eval (constant-form-value* form)) (defconstantp block (name &body forms) ;; We currently fail to detect cases like diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 282cdb0..e0b1f61 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1988,3 +1988,7 @@ (space 2) (safety 0) (compilation-speed 0))) (unwind-protect 0 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))))) + +;; aggressive constant folding (bug #400) +(assert + (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0)))))))) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 3708433..da75fb0 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -136,6 +136,16 @@ ((the integer 1) t 1) ((the integer (+ 1 1)) t 2) ((the integer (foo)) nil) + ((the symbol 1) nil) + ((the "bad type" 1) nil) + ((multiple-value-prog1 + (+ 1 1) + :nada) t 2) + ((multiple-value-prog1 + :nada + (/ 1 0)) nil) + ((/ 1 0) nil) + ((/ 1 1) t 1) ((+ 1 2) t 3))) (destructuring-bind (form c &optional v) test (assert (eql (constantp form) c)) diff --git a/version.lisp-expr b/version.lisp-expr index 16174f8..0744e3b 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.9.10.16" +"0.9.10.17" -- 1.7.10.4