but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0))
does not.
-89:
- The type system doesn't understand the the intersection of the types
- KEYWORD and (OR KEYWORD NULL) is KEYWORD, perhaps because KEYWORD
- is itself an intersection type and that causes technical problems
- with the simplification. Thus, the optimizer can't make some useful
- valid type inferences.
-
90:
a latent cross-compilation/bootstrapping bug: The cross-compilation
host's CL:CHAR-CODE-LIMIT is used in target code in readtable.lisp
(t
(error "can't handle TYPE-OF ~S in cross-compilation"))))))
-;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE
-;;; when instantiated on the target SBCL. Since this is hard to decide
-;;; in some cases, and since in other cases we just haven't bothered
-;;; to try, it needs to return two values, just like SUBTYPEP: the
-;;; first value for its conservative opinion (never T unless it's
-;;; certain) and the second value to tell whether it's certain.
+;;; Is SYMBOL in the CL package? Note that we're testing this on the
+;;; cross-compilation host, which could do things any old way. In
+;;; particular, it might be in the CL package even though
+;;; SYMBOL-PACKAGE is not (FIND-PACKAGE :CL). So we test things
+;;; another way.
+(defun in-cl-package-p (symbol)
+ (eql (find-symbol (symbol-name symbol) :cl)
+ symbol))
+
+;;; This is like TYPEP, except that it asks whether HOST-OBJECT would
+;;; be of TARGET-TYPE when instantiated on the target SBCL. Since this
+;;; is hard to determine in some cases, and since in other cases we
+;;; just haven't bothered to try, it needs to return two values, just
+;;; like SUBTYPEP: the first value for its conservative opinion (never
+;;; T unless it's certain) and the second value to tell whether it's
+;;; certain.
(defun cross-typep (host-object target-type)
(flet ((warn-and-give-up ()
;; We don't have to keep track of this as long as system performance
;; trivial.
(and (every/type #'cross-typep host-object rest))
(or (any/type #'cross-typep host-object rest))
+ ;; If we want to work with the KEYWORD type, we need
+ ;; to grok (SATISFIES KEYWORDP).
+ (satisfies
+ (destructuring-bind (predicate-name) rest
+ (if (and (in-cl-package-p predicate-name)
+ (fboundp predicate-name))
+ ;; Many things like KEYWORDP, ODDP, PACKAGEP,
+ ;; and NULL correspond between host and target.
+ (values (not (null (funcall predicate-name host-object)))
+ t)
+ ;; For symbols not in the CL package, it's not
+ ;; in general clear how things correspond
+ ;; between host and target, so we punt.
+ (warn-and-give-up))))
;; Some complex types are too hard to handle in the positive
;; case, but at least we can be confident in a large fraction of
;; the negative cases..
#!+sb-show
(defvar *hash-caches-initialized-p*)
-;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
-;;; so that caches will be created before top-level forms run.
+;;; Define a hash cache that associates some number of argument values
+;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
+;;; is used to compare the value for that arg in a cache entry with a
+;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
+;;; its first arg, but need not return any particular value.
+;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
+;;;
+;;; NAME is used to define these functions:
+;;; <name>-CACHE-LOOKUP Arg*
+;;; See whether there is an entry for the specified ARGs in the
+;;; cache. If not present, the :DEFAULT keyword (default NIL)
+;;; determines the result(s).
+;;; <name>-CACHE-ENTER Arg* Value*
+;;; Encache the association of the specified args with VALUE.
+;;; <name>-CACHE-CLEAR
+;;; Reinitialize the cache, invalidating all entries and allowing
+;;; the arguments and result values to be GC'd.
+;;;
+;;; These other keywords are defined:
+;;; :HASH-BITS <n>
+;;; The size of the cache as a power of 2.
+;;; :HASH-FUNCTION function
+;;; Some thing that can be placed in CAR position which will compute
+;;; a value between 0 and (1- (expt 2 <hash-bits>)).
+;;; :VALUES <n>
+;;; the number of return values cached for each function call
+;;; :INIT-WRAPPER <name>
+;;; The code for initializing the cache is wrapped in a form with
+;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
+;;; in type system definitions so that caches will be created
+;;; before top-level forms run.)
(defmacro define-hash-cache (name args &key hash-function hash-bits default
(init-wrapper 'progn)
(values 1))
- #!+sb-doc
- "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
- Define a hash cache that associates some number of argument values to a
- result value. The Test-Function paired with each Arg-Name is used to compare
- the value for that arg in a cache entry with a supplied arg. The
- Test-Function must not error when passed NIL as its first arg, but need not
- return any particular value. Test-Function may be any thing that can be
- placed in CAR position.
-
- Name is used to define these functions:
-
- <name>-CACHE-LOOKUP Arg*
- See whether there is an entry for the specified Args in the cache. If
- not present, the :DEFAULT keyword (default NIL) determines the result(s).
-
- <name>-CACHE-ENTER Arg* Value*
- Encache the association of the specified args with Value.
-
- <name>-CACHE-CLEAR
- Reinitialize the cache, invalidating all entries and allowing the
- arguments and result values to be GC'd.
-
- These other keywords are defined:
-
- :HASH-BITS <n>
- The size of the cache as a power of 2.
-
- :HASH-FUNCTION function
- Some thing that can be placed in CAR position which will compute a value
- between 0 and (1- (expt 2 <hash-bits>)).
-
- :VALUES <n>
- The number of values cached.
-
- :INIT-WRAPPER <name>
- The code for initializing the cache is wrapped in a form with the
- specified name. Default PROGN."
-
(let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
(nargs (length args))
(entry-size (+ nargs values))
,@(forms)
',name))))
+;;; some syntactic sugar for defining a function whose values are
+;;; cached by DEFINE-HASH-CACHE
(defmacro defun-cached ((name &rest options &key (values 1) default
&allow-other-keys)
args &body body-decls-doc)
- #!+sb-doc
- "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
- Some syntactic sugar for defining a function whose values are cached by
- DEFINE-HASH-CACHE."
(let ((default-values (if (and (consp default) (eq (car default) 'values))
(cdr default)
(list default)))
(declare (type function fun))
(lambda (x y)
(funcall fun y x)))
+
+;;; like CL:ASSERT, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT
+;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a
+;;; significant amount of code when you multiply them by 400, so
+;;; replacing them with this should reduce the size of the system
+;;; by enough to be worthwhile.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(let ((*package* (find-package :keyword)))
+ (format nil "~S" expr)))))
+(defun %failed-aver (expr)
+ (error "~@<failed AVER: ~2I~_~S~:>" expr))
\f
;;;; utilities for two-VALUES predicates
;;; sort of like ANY and EVERY, except:
-;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And
-;;; if the result is uncertain, then we return (VALUES NIL NIL),
-;;; just like SUBTYPEP.)
+;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
+;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
+;;; as SUBTYPEP does.)
;;; * THING is just an atom, and we apply OP (an arity-2 function)
;;; successively to THING and each element of LIST.
(defun any/type (op thing list)
;;; keywords are defined:
;;;
;;; :PRIN1 Print the value of the expression instead of the slot value.
-;;; :PRINC Like :PRIN1, only princ the value
+;;; :PRINC Like :PRIN1, only PRINC the value
;;; :TEST Only print something if the test is true.
;;;
;;; If no printing thing is specified then the slot value is printed
(if x
x
(cons y y)))
-|#
\ No newline at end of file
+|#
;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
;; between not finding a method and having a method return NIL.
(flet ((1way (x y)
- (let ((result (!invoke-type-method :simple-union2 :complex-union2
- x y
- :default nil)))
- ;; UNION2 type methods are supposed to return results
- ;; which are better than just brute-forcibly smashing the
- ;; terms together into UNION-TYPEs. But they're derived
- ;; from old CMU CL UNION type methods which played by
- ;; somewhat different rules. Here we check to make sure
- ;; we don't get ambushed by diehard old-style code.
- (assert (not (union-type-p result)))
- result)))
+ (!invoke-type-method :simple-union2 :complex-union2
+ x y
+ :default nil)))
(declare (inline 1way))
(or (1way type1 type2)
(1way type2 type1))))
;;
;; (Why yes, CLOS probably *would* be nicer..)
(flet ((1way (x y)
- (let ((result
- (!invoke-type-method :simple-intersection2
- :complex-intersection2
- x y
- :default :no-type-method-found)))
- ;; INTERSECTION2 type methods are supposed to return
- ;; results which are better than just brute-forcibly
- ;; smashing the terms together into INTERSECTION-TYPEs.
- ;; But they're derived from old CMU CL INTERSECTION type
- ;; methods which played by somewhat different rules. Here
- ;; we check to make sure we don't get ambushed by diehard
- ;; old-style code.
- (assert (not (intersection-type-p result)))
- result)))
+ (!invoke-type-method :simple-intersection2 :complex-intersection2
+ x y
+ :default :no-type-method-found)))
(declare (inline 1way))
(let ((xy (1way type1 type2)))
(or (and (not (eql xy :no-type-method-found)) xy)
((union-complex-subtypep-arg1 type2 type1)
type2)
(t
+ ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
+ ;; operations in a particular order, and gives up if any of
+ ;; the sub-unions turn out not to be simple. In other cases
+ ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
+ ;; bad idea, since it can overlook simplifications which
+ ;; might occur if the terms were accumulated in a different
+ ;; order. It's possible that that will be a problem here too.
+ ;; However, I can't think of a good example to demonstrate
+ ;; it, and without an example to demonstrate it I can't write
+ ;; test cases, and without test cases I don't want to
+ ;; complicate the code to address what's still a hypothetical
+ ;; problem. So I punted. -- WHN 2001-03-20
(let ((accumulator *empty-type*))
(dolist (t2 (union-type-types type2) accumulator)
(setf accumulator
(type-union2 accumulator
(type-intersection type1 t2)))
- ;; When our result isn't simple any more
- (when (or
- ;; (TYPE-UNION2 couldn't find a sufficiently simple
- ;; result, so we can't either.)
- (null accumulator)
- ;; (A result containing an intersection isn't
- ;; sufficiently simple for us. FIXME: Maybe it
- ;; should be sufficiently simple for us?
- ;; UNION-TYPEs aren't supposed to be nested inside
- ;; INTERSECTION-TYPEs, so if we punt with NIL,
- ;; we're condemning the expression to become a
- ;; HAIRY-TYPE. If it were possible for us to
- ;; return an INTERSECTION-TYPE, then the
- ;; INTERSECTION-TYPE-TYPES could be merged into
- ;; the outer INTERSECTION-TYPE which may be under
- ;; construction. E.g. if this function could
- ;; return an intersection type, and the calling
- ;; functions were smart enough to handle it, then
- ;; we could simplify (AND (OR FIXNUM KEYWORD)
- ;; SYMBOL) to KEYWORD, even though KEYWORD
- ;; is an intersection type.)
- (intersection-type-p accumulator))
+ ;; When our result isn't simple any more (because
+ ;; TYPE-UNION2 was unable to give us a simple result)
+ (unless accumulator
(return nil)))))))
(!def-type-translator or (&rest type-specifiers)
#!+sb-doc
"Signals an error if the value of test-form is nil. Continuing from this
error using the CONTINUE restart will allow the user to alter the value of
- some locations known to SETF, starting over with test-form. Returns nil."
+ some locations known to SETF, starting over with test-form. Returns NIL."
`(do () (,test-form)
(assert-error ',test-form ',places ,datum ,@arguments)
,@(mapcar #'(lambda (place)
(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not
(start1 0) end1 (start2 0) end2 key)
#!+sb-doc
- "The specified subsequences of Sequence1 and Sequence2 are compared
+ "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
element-wise. If they are of equal length and match in every element, the
result is Nil. Otherwise, the result is a non-negative integer, the index
- within Sequence1 of the leftmost position at which they fail to match; or,
+ within SEQUENCE1 of the leftmost position at which they fail to match; or,
if one is shorter than and a matching prefix of the other, the index within
- Sequence1 beyond the last position tested is returned. If a non-NIL
+ SEQUENCE1 beyond the last position tested is returned. If a non-NIL
:FROM-END argument is given, then one plus the index of the rightmost
position in which the sequences differ is returned."
(declare (fixnum start1 start2))
(if (lisp-stream-p stream)
(or (/= (the fixnum (lisp-stream-in-index stream)) +in-buffer-length+)
;; Test for T explicitly since misc methods return :EOF sometimes.
- (eq (funcall (lisp-stream-misc stream) stream :listen) at))
+ (eq (funcall (lisp-stream-misc stream) stream :listen) t))
;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
;; stuff for byte compilation. Note that although byte code is
;; "portable", it'd be hard to make it work on the cross-compilation
;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are
- ;; implemented as FUNCALLABLE-INSTANCEs, and it's
- ;; not obvious how to make those portable.
+ ;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious
+ ;; how to emulate those in a vanilla ANSI Common Lisp.
("code/byte-types" :not-host)
("compiler/byte-comp")
("compiler/target-byte-comp" :not-host)
(assert (null (type-intersection2 (specifier-type 'symbol)
(specifier-type '(satisfies foo)))))
(assert (intersection-type-p (specifier-type '(and symbol (satisfies foo)))))
+(assert (ctypep :x86 (specifier-type '(satisfies keywordp))))
+(assert (type= (specifier-type '(member :x86))
+ (specifier-type '(and (member :x86) (satisfies keywordp)))))
(let* ((type1 (specifier-type '(member :x86)))
(type2 (specifier-type '(or keyword null)))
(isect (type-intersection type1 type2)))
(assert (type= isect (type-intersection type2 type1 type2)))
(assert (type= isect (type-intersection type1 type1 type2 type1)))
(assert (type= isect (type-intersection type1 type2 type1 type2))))
-;;; FIXME: As of sbcl-0.6.11.19, the system doesn't know how to do the
-;;; type simplifications which would let these tests work. (bug 89)
-#|
(let* ((type1 (specifier-type 'keyword))
(type2 (specifier-type '(or keyword null)))
(isect (type-intersection type1 type2)))
(assert (type= isect (type-intersection type2 type1 type2)))
(assert (type= isect (type-intersection type1 type1 type2 type1)))
(assert (type= isect (type-intersection type1 type2 type1 type2))))
-|#
(/show "done with tests/type.before-xc.lisp")
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.20"
+"0.6.11.21"
projects / sbcl.git / commitdiff