Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code alien-type.lisp,1.8,1.9 class.lisp,1.46,1.47 late-type.lisp,1.100,1.101 type-class.lisp,1.20,1.21
|
From: Christophe R. <cr...@us...> - 2003-12-11 13:34:32
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv30981/src/code
Modified Files:
alien-type.lisp class.lisp late-type.lisp type-class.lisp
Log Message:
0.8.6.35:
At the request of the type system's most heavy user...
... refactor NEGATION-TYPEs
... make NEGATE an operation in TYPE-CLASS
... define type methods for :NEGATE, replacing one god-awful
NOT type translator
... define a (cached) TYPE-NEGATION function
... replace too many uses of
(specifier-type `(not ,(type-specifier foo)))
with (type-negation foo)
We pass as many tests as we used to (both here and in PFD's suite)
and we now go faster than we did before 0.8.6 on PFD's random
tester. Sounds good to me.
(This was initially part I of a two part refactor. This stage
turns out to be enough for now; if it hadn't been, it should be
possible to achieve even greater speed by changing the representation
of CONS types to include not just CAR and CDR types but also
their negations; then operations on CONS types such as UNION and NEGATE
would be much much faster, at a slight cost in initialization).
Index: alien-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/alien-type.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- alien-type.lisp 27 May 2003 08:35:53 -0000 1.8
+++ alien-type.lisp 11 Dec 2003 13:34:25 -0000 1.9
@@ -26,6 +26,9 @@
(!define-type-class alien)
+(!define-type-method (alien :negate) (type)
+ (make-negation-type :type type))
+
(!define-type-method (alien :unparse) (type)
`(alien ,(unparse-alien-type (alien-type-type-alien-type type))))
Index: class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- class.lisp 5 Aug 2003 14:11:38 -0000 1.46
+++ class.lisp 11 Dec 2003 13:34:25 -0000 1.47
@@ -871,6 +871,9 @@
(values nil nil)
(invoke-complex-subtypep-arg1-method type1 class2 nil t)))
+(!define-type-method (classoid :negate) (type)
+ (make-negation-type :type type))
+
(!define-type-method (classoid :unparse) (type)
(classoid-proper-name type))
Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -d -r1.100 -r1.101
--- late-type.lisp 30 Nov 2003 16:08:49 -0000 1.100
+++ late-type.lisp 11 Dec 2003 13:34:25 -0000 1.101
@@ -154,6 +154,9 @@
(declare (ignore type1))
(error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2)))
+(!define-type-method (values :negate) (type)
+ (error "NOT VALUES too confusing on ~S" (type-specifier type)))
+
(!define-type-method (values :unparse) (type)
(cons 'values
(let ((unparsed (unparse-args-types type)))
@@ -192,6 +195,9 @@
(defvar *unparse-fun-type-simplify*)
(!cold-init-forms (setq *unparse-fun-type-simplify* nil))
+(!define-type-method (function :negate) (type)
+ (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+
(!define-type-method (function :unparse) (type)
(if *unparse-fun-type-simplify*
'function
@@ -318,6 +324,9 @@
(!define-type-class constant :inherits values)
+(!define-type-method (constant :negate) (type)
+ (error "NOT CONSTANT too confusing on ~S" (type-specifier type)))
+
(!define-type-method (constant :unparse) (type)
`(constant-arg ,(type-specifier (constant-type-type type))))
@@ -898,6 +907,17 @@
(declare (type ctype type))
(funcall (type-class-unparse (type-class-info type)) type))
+(defun-cached (type-negation :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff))
+ :hash-bits 8
+ :values 1
+ :default nil
+ :init-wrapper !cold-init-forms)
+ ((type eq))
+ (declare (type ctype type))
+ (funcall (type-class-negate (type-class-info type)) type))
+
;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
;;; early-type.lisp by WHN ca. 19990201.)
@@ -1119,11 +1139,21 @@
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-union2 type1 type2))
+(!define-type-method (named :negate) (x)
+ (aver (not (eq x *wild-type*)))
+ (cond
+ ((eq x *universal-type*) *empty-type*)
+ ((eq x *empty-type*) *universal-type*)
+ (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+
(!define-type-method (named :unparse) (x)
(named-type-name x))
;;;; hairy and unknown types
+(!define-type-method (hairy :negate) (x)
+ (make-negation-type :type x))
+
(!define-type-method (hairy :unparse) (x)
(hairy-type-specifier x))
@@ -1189,6 +1219,9 @@
;;;; negation types
+(!define-type-method (negation :negate) (x)
+ (negation-type-type x))
+
(!define-type-method (negation :unparse) (x)
`(not ,(type-specifier (negation-type-type x))))
@@ -1341,123 +1374,7 @@
(type= (negation-type-type type1) (negation-type-type type2)))
(!def-type-translator not (typespec)
- (let* ((not-type (specifier-type typespec))
- (spec (type-specifier not-type)))
- (cond
- ;; canonicalize (NOT (NOT FOO))
- ((and (listp spec) (eq (car spec) 'not))
- (specifier-type (cadr spec)))
- ;; canonicalize (NOT NIL) and (NOT T)
- ((eq not-type *empty-type*) *universal-type*)
- ((eq not-type *universal-type*) *empty-type*)
- ((and (numeric-type-p not-type)
- (null (numeric-type-low not-type))
- (null (numeric-type-high not-type)))
- (make-negation-type :type not-type))
- ((numeric-type-p not-type)
- (type-union
- (make-negation-type
- :type (modified-numeric-type not-type :low nil :high nil))
- (cond
- ((null (numeric-type-low not-type))
- (modified-numeric-type
- not-type
- :low (let ((h (numeric-type-high not-type)))
- (if (consp h) (car h) (list h)))
- :high nil))
- ((null (numeric-type-high not-type))
- (modified-numeric-type
- not-type
- :low nil
- :high (let ((l (numeric-type-low not-type)))
- (if (consp l) (car l) (list l)))))
- (t (type-union
- (modified-numeric-type
- not-type
- :low nil
- :high (let ((l (numeric-type-low not-type)))
- (if (consp l) (car l) (list l))))
- (modified-numeric-type
- not-type
- :low (let ((h (numeric-type-high not-type)))
- (if (consp h) (car h) (list h)))
- :high nil))))))
- ((intersection-type-p not-type)
- (apply #'type-union
- (mapcar #'(lambda (x)
- (specifier-type `(not ,(type-specifier x))))
- (intersection-type-types not-type))))
- ((union-type-p not-type)
- (apply #'type-intersection
- (mapcar #'(lambda (x)
- (specifier-type `(not ,(type-specifier x))))
- (union-type-types not-type))))
- ((member-type-p not-type)
- (let ((members (member-type-members not-type)))
- (if (some #'floatp members)
- (let (floats)
- (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
- (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
- #!+long-float
- (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
- (when (member (car pair) members)
- (aver (not (member (cdr pair) members)))
- (push (cdr pair) floats)
- (setf members (remove (car pair) members)))
- (when (member (cdr pair) members)
- (aver (not (member (car pair) members)))
- (push (car pair) floats)
- (setf members (remove (cdr pair) members))))
- (apply #'type-intersection
- (if (null members)
- *universal-type*
- (make-negation-type
- :type (make-member-type :members members)))
- (mapcar
- (lambda (x)
- (let ((type (ctype-of x)))
- (type-union
- (make-negation-type
- :type (modified-numeric-type type
- :low nil :high nil))
- (modified-numeric-type type
- :low nil :high (list x))
- (make-member-type :members (list x))
- (modified-numeric-type type
- :low (list x) :high nil))))
- floats)))
- (make-negation-type :type not-type))))
- ((and (cons-type-p not-type)
- (eq (cons-type-car-type not-type) *universal-type*)
- (eq (cons-type-cdr-type not-type) *universal-type*))
- (make-negation-type :type not-type))
- ((cons-type-p not-type)
- (type-union
- (make-negation-type :type (specifier-type 'cons))
- (cond
- ((and (not (eq (cons-type-car-type not-type) *universal-type*))
- (not (eq (cons-type-cdr-type not-type) *universal-type*)))
- (type-union
- (make-cons-type
- (specifier-type `(not ,(type-specifier
- (cons-type-car-type not-type))))
- *universal-type*)
- (make-cons-type
- *universal-type*
- (specifier-type `(not ,(type-specifier
- (cons-type-cdr-type not-type)))))))
- ((not (eq (cons-type-car-type not-type) *universal-type*))
- (make-cons-type
- (specifier-type `(not ,(type-specifier
- (cons-type-car-type not-type))))
- *universal-type*))
- ((not (eq (cons-type-cdr-type not-type) *universal-type*))
- (make-cons-type
- *universal-type*
- (specifier-type `(not ,(type-specifier
- (cons-type-cdr-type not-type))))))
- (t (bug "Weird CONS type ~S" not-type)))))
- (t (make-negation-type :type not-type)))))
+ (type-negation (specifier-type typespec)))
;;;; numeric types
@@ -1476,6 +1393,37 @@
(equalp (numeric-type-high type1) (numeric-type-high type2)))
t))
+(!define-type-method (number :negate) (type)
+ (if (and (null (numeric-type-low type)) (null (numeric-type-high type)))
+ (make-negation-type :type type)
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type :low nil :high nil))
+ (cond
+ ((null (numeric-type-low type))
+ (modified-numeric-type
+ type
+ :low (let ((h (numeric-type-high type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))
+ ((null (numeric-type-high type))
+ (modified-numeric-type
+ type
+ :low nil
+ :high (let ((l (numeric-type-low type)))
+ (if (consp l) (car l) (list l)))))
+ (t (type-union
+ (modified-numeric-type
+ type
+ :low nil
+ :high (let ((l (numeric-type-low type)))
+ (if (consp l) (car l) (list l))))
+ (modified-numeric-type
+ type
+ :low (let ((h (numeric-type-high type)))
+ (if (consp h) (car h) (list h)))
+ :high nil)))))))
+
(!define-type-method (number :unparse) (type)
(let* ((complexp (numeric-type-complexp type))
(low (numeric-type-low type))
@@ -2157,6 +2105,12 @@
(specialized-element-type-maybe type2)))
t)))
+(!define-type-method (array :negate) (type)
+ ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
+ ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
+ ;; NIL) (ARRAY CHAR) ...) equivalent? -- CSR, 2003-12-10
+ (make-negation-type :type type))
+
(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eltype (type-specifier (array-type-element-type type)))
@@ -2338,6 +2292,42 @@
(!define-type-class member)
+(!define-type-method (member :negate) (type)
+ (let ((members (member-type-members type)))
+ (if (some #'floatp members)
+ (let (floats)
+ (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
+ (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
+ (when (member (car pair) members)
+ (aver (not (member (cdr pair) members)))
+ (push (cdr pair) floats)
+ (setf members (remove (car pair) members)))
+ (when (member (cdr pair) members)
+ (aver (not (member (car pair) members)))
+ (push (car pair) floats)
+ (setf members (remove (cdr pair) members))))
+ (apply #'type-intersection
+ (if (null members)
+ *universal-type*
+ (make-negation-type
+ :type (make-member-type :members members)))
+ (mapcar
+ (lambda (x)
+ (let ((type (ctype-of x)))
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type
+ :low nil :high nil))
+ (modified-numeric-type type
+ :low nil :high (list x))
+ (make-member-type :members (list x))
+ (modified-numeric-type type
+ :low (list x) :high nil))))
+ floats)))
+ (make-negation-type :type type))))
+
(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
(cond
@@ -2452,6 +2442,10 @@
(!define-type-class intersection)
+(!define-type-method (intersection :negate) (type)
+ (apply #'type-union
+ (mapcar #'type-negation (intersection-type-types type))))
+
;;; A few intersection types have special names. The others just get
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
@@ -2572,13 +2566,17 @@
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
- (mapcar #'specifier-type
- type-specifiers)))
+ (mapcar #'specifier-type type-specifiers)))
;;;; union types
(!define-type-class union)
+(!define-type-method (union :negate) (type)
+ (declare (type ctype type))
+ (apply #'type-intersection
+ (mapcar #'type-negation (union-type-types type))))
+
;;; The LIST, FLOAT and REAL types have special names. Other union
;;; types just get mechanically unparsed.
(!define-type-method (union :unparse) (type)
@@ -2747,7 +2745,33 @@
(let ((car-type (single-value-specifier-type car-type-spec))
(cdr-type (single-value-specifier-type cdr-type-spec)))
(make-cons-type car-type cdr-type)))
-
+
+(!define-type-method (cons :negate) (type)
+ (if (and (eq (cons-type-car-type type) *universal-type*)
+ (eq (cons-type-cdr-type type) *universal-type*))
+ (make-negation-type :type type)
+ (type-union
+ (make-negation-type :type (specifier-type 'cons))
+ (cond
+ ((and (not (eq (cons-type-car-type type) *universal-type*))
+ (not (eq (cons-type-cdr-type type) *universal-type*)))
+ (type-union
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*)
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type)))))
+ ((not (eq (cons-type-car-type type) *universal-type*))
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*))
+ ((not (eq (cons-type-cdr-type type) *universal-type*))
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type))))
+ (t (bug "Weird CONS type ~S" type))))))
+
(!define-type-method (cons :unparse) (type)
(let ((car-eltype (type-specifier (cons-type-car-type type)))
(cdr-eltype (type-specifier (cons-type-cdr-type type))))
@@ -2790,8 +2814,7 @@
(type-intersection ,car2
,(if not1p
not1
- `(specifier-type
- `(not ,(type-specifier ,car1)))))
+ `(type-negation ,car1)))
,cdr2))))
(cond ((type= car-type1 car-type2)
(make-cons-type car-type1
@@ -2805,13 +2828,11 @@
(frob-car car-type2 car-type1 cdr-type2 cdr-type1))
;; more general case of the above, but harder to compute
((progn
- (setf car-not1 (specifier-type
- `(not ,(type-specifier car-type1))))
+ (setf car-not1 (type-negation car-type1))
(not (csubtypep car-type2 car-not1)))
(frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
((progn
- (setf car-not2 (specifier-type
- `(not ,(type-specifier car-type2))))
+ (setf car-not2 (type-negation car-type2))
(not (csubtypep car-type1 car-not2)))
(frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
;; Don't put these in -- consider the effect of taking the
Index: type-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/type-class.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- type-class.lisp 5 May 2003 14:09:10 -0000 1.20
+++ type-class.lisp 11 Dec 2003 13:34:25 -0000 1.21
@@ -85,6 +85,8 @@
(complex-intersection2 nil :type (or function null))
(simple-= #'must-supply-this :type function)
(complex-= nil :type (or function null))
+ ;; monadic functions
+ (negate #'must-supply-this :type function)
;; a function which returns a Common Lisp type specifier
;; representing this type
(unparse #'must-supply-this :type function)
@@ -120,6 +122,7 @@
(:complex-intersection2 . type-class-complex-intersection2)
(:simple-= . type-class-simple-=)
(:complex-= . type-class-complex-=)
+ (:negate . type-class-negate)
(:unparse . type-class-unparse))))
(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
|