From faafcfc8d751c0f549f8d30ff2ea4bc7342a7329 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 30 Jun 2008 08:35:58 +0000 Subject: [PATCH] 1.0.18.1: correct handling of SATISFIES types in the compiler * CTYPEP used to retur a secondary value of true in cases where the function in question was not foldable. * Slightly sleazily extent SB-C::CONSTANT-FUNCTION-CALL-P (part of CONSTANTP) to return the primary result of the call as the secondary value, so CTYPEP can use it. * Test-case. --- NEWS | 4 ++++ src/code/target-type.lisp | 29 +++++------------------------ src/compiler/constantp.lisp | 32 ++++++++++++++++---------------- tests/compiler.impure.lisp | 9 +++++++++ version.lisp-expr | 2 +- 5 files changed, 35 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index 71373b6..48e1ed6 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.19 relative to 1.0.18: + * bug fix: compiler no longer makes erronous assumptions in the + presense of non-foldable SATISFIES types. + changes in sbcl-1.0.18 relative to 1.0.17: * minor incompatible change: SB-SPROF:WITH-PROFILING now by default profiles only the current thread. diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 665b453..a3775fb 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -85,30 +85,11 @@ (values (not res) t) (values nil nil)))) (satisfies - (let ((predicate-name (second hairy-spec))) - (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES - (if (fboundp predicate-name) - (let* (;; "Is OBJ of the SATISFIES type?" represented - ;; as a generalized boolean. - ;; - ;; (Why IGNORE-ERRORS? This code is used to try to - ;; check type relationships at compile time. - ;; Passing only-slightly-twisted types like - ;; (AND INTEGER (SATISFIES ODDP)) into the - ;; rather-significantly-twisted type dispatch - ;; system can easily give rise to oddities like - ;; calling predicates like ODDP on values they - ;; don't like. (E.g. on OBJ=#\NEWLINE when the - ;; above type is tested for TYPE= against - ;; STANDARD-CHAR, represented as a - ;; MEMBER-TYPE.) In such cases, NIL seems to be - ;; an appropriate answer to "is OBJ of the - ;; SATISFIES type?") - (gbool (ignore-errors (funcall predicate-name obj))) - ;; RAW coerced to a pure BOOLEAN value - (bool (not (not gbool)))) - (values bool t)) - (values nil nil))))))))) + ;; If the SATISFIES function is not foldable, we cannot answer! + (let* ((form `(,(second hairy-spec) ',obj))) + (multiple-value-bind (ok result) + (sb!c::constant-function-call-p form nil nil) + (values (not (null result)) ok))))))))) ;;; Return the layout for an object. This is the basic operation for ;;; finding out the "type" of an object, and is used for generic diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp index 29252c2..85bb5b8 100644 --- a/src/compiler/constantp.lisp +++ b/src/compiler/constantp.lisp @@ -40,7 +40,7 @@ (list (or (constant-special-form-p form environment envp) #-sb-xc-host - (constant-function-call-p form environment envp))) + (values (constant-function-call-p form environment envp)))) (t t)))) (defun %constant-form-value (form environment envp) @@ -76,21 +76,21 @@ ;;; too. (defun constant-function-call-p (form environment envp) (let ((name (car form))) - (and (legal-fun-name-p name) - (eq :function (info :function :kind name)) - (let ((info (info :function :info name))) - (and info (ir1-attributep (fun-info-attributes info) - foldable))) - (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)))))) + (if (and (legal-fun-name-p name) + (eq :function (info :function :kind name)) + (let ((info (info :function :info name))) + (and info (ir1-attributep (fun-info-attributes info) + foldable))) + (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 + (values t (constant-function-call-value form environment envp)) + (error () + (values nil nil))) + (values nil nil)))) (defun constant-function-call-value (form environment envp) (apply (fdefinition (car form)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 21b4171..84dd848 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1669,4 +1669,13 @@ (test f1 f2) (test f1 c2)))) +;;; user-defined satisfies-types cannot be folded +(deftype mystery () '(satisfies mysteryp)) +(defvar *mystery* nil) +(defun mysteryp (x) (eq x *mystery*)) +(defstruct thing (slot (error "missing") :type mystery)) +(defun test-mystery (m) (when (eq :mystery (thing-slot m)) :ok)) +(setf *mystery* :mystery) +(assert (eq :ok (test-mystery (make-thing :slot :mystery)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index dce91e1..1071b41 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".) -"1.0.18" +"1.0.18.1" -- 1.7.10.4