X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftype-class.lisp;h=992d3e5452ed71f6c07c41d54713f41a44b328c5;hb=82653abf5573c22c691e2243b70647ecdaa6aea8;hp=fb81dedd026fd0228c8adccf13a537fad2d20d7c;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index fb81ded..992d3e5 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -11,9 +11,6 @@ (in-package "SB!KERNEL") -(file-comment - "$Header$") - (!begin-collecting-cold-init-forms) (defvar *type-classes*) @@ -26,18 +23,20 @@ (error "~S is not a defined type class." name))) (defun must-supply-this (&rest foo) + (/show0 "failing in MUST-SUPPLY-THIS") (error "missing type method for ~S" foo)) -;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains -;;; functions which are methods on that kind of type, but is also used in EQ -;;; comparisons to determined if two types have the "same kind". +;;; A TYPE-CLASS object represents the "kind" of a type. It mainly +;;; contains functions which are methods on that kind of type, but is +;;; also used in EQ comparisons to determined if two types have the +;;; "same kind". (def!struct (type-class #-no-ansi-print-object (:print-object (lambda (x stream) (print-unreadable-object (x stream :type t) (prin1 (type-class-name x) stream))))) ;; the name of this type class (used to resolve references at load time) - (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT? + (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default? ;; Dyadic type methods. If the classes of the two types are EQ, then ;; we call the SIMPLE-xxx method. If the classes are not EQ, and ;; either type's class has a COMPLEX-xxx method, then we call it. @@ -55,16 +54,35 @@ (simple-subtypep #'must-supply-this :type function) (complex-subtypep-arg1 nil :type (or function null)) (complex-subtypep-arg2 nil :type (or function null)) - ;; SIMPLE-UNION combines two types of the same class into a single - ;; type of that class. If the result is a two-type union, then - ;; return NIL. VANILLA-UNION returns whichever argument is a - ;; supertype of the other, or NIL. - (simple-union #'vanilla-union :type function) - (complex-union nil :type (or function null)) - ;; The default intersection methods assume that if one type is a - ;; subtype of the other, then that type is the intersection. - (simple-intersection #'vanilla-intersection :type function) - (complex-intersection nil :type (or function null)) + ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and + ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find + ;; a new type which expresses the result nicely, better than could + ;; be done by just stuffing the two component types into an + ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on + ;; failure, or a CTYPE for success. + ;; + ;; Note: These methods are similar to CMU CL's SIMPLE-UNION, + ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods. + ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE + ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL + ;; wants to simplify unions and intersections by considering all + ;; possible pairwise simplifications (where the CMU CL code only + ;; considered simplifications between types which happened to appear + ;; next to each other the argument sequence). + ;; + ;; Differences in detail from old CMU CL methods: + ;; * SBCL's methods are more parallel between union and + ;; intersection forms. Each returns one values, (OR NULL CTYPE). + ;; * SBCL doesn't use type methods to deal with unions or + ;; intersections of the COMPOUND-TYPE of the corresponding form. + ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2, + ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially + ;; (and deal with canonicalization/simplification issues at the + ;; same time). + (simple-union2 #'hierarchical-union2 :type function) + (complex-union2 nil :type (or function null)) + (simple-intersection2 #'hierarchical-intersection2 :type function) + (complex-intersection2 nil :type (or function null)) (simple-= #'must-supply-this :type function) (complex-= nil :type (or function null)) ;; a function which returns a Common Lisp type specifier @@ -82,62 +100,67 @@ ;; supplying both. (unary-typep nil :type (or symbol null)) (typep nil :type (or symbol null)) - ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this - ;; type. + ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to + ;; the type. (unary-coerce nil :type (or symbol null)) (coerce :type (or symbol null)) |# ) (eval-when (:compile-toplevel :load-toplevel :execute) + ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here + ;; will have to be tweaked to match. -- WHN 19991021 + (defparameter *type-class-fun-slots* + '((:simple-subtypep . type-class-simple-subtypep) + (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) + (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) + (:simple-union2 . type-class-simple-union2) + (:complex-union2 . type-class-complex-union2) + (:simple-intersection2 . type-class-simple-intersection2) + (:complex-intersection2 . type-class-complex-intersection2) + (:simple-= . type-class-simple-=) + (:complex-= . type-class-complex-=) + (:unparse . type-class-unparse)))) -;;; Copy TYPE-CLASS object X, using only operations which will work early in -;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs -;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO -;;; isn't initialized early in cold load.) +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; Copy TYPE-CLASS object X, using only operations which will work +;;; early in cold load. (COPY-STRUCTURE won't work early in cold load, +;;; because it needs RAW-INDEX and RAW-LENGTH information from +;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold +;;; load.) ;;; -;;; FIXME: It's nasty having to maintain this hand-written copy function. And -;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in -;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move -;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various -;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH -;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE -;;; instead. (For even more improvement, it'd be good to move the raw slots +;;; FIXME: It's nasty having to maintain this hand-written copy +;;; function. And it seems intrinsically dain-bramaged to have +;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in +;;; LAYOUT. We should fix this: +;;; * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. +;;; * Rewrite the various CHECK-LAYOUT-related functions so that +;;; they check RAW-INDEX and RAW-LENGTH too. +;;; * Remove this special hacked copy function, just use +;;; COPY-STRUCTURE instead. +;;; (For even more improvement, it might be good to move the raw slots ;;; into the same object as the ordinary slots, instead of having the -;;; unfortunate extra level of indirection. But that'd probably require a lot -;;; of work, including updating the garbage collector to understand it.) +;;; unfortunate extra level of indirection. But that'd probably +;;; require a lot of work, including updating the garbage collector to +;;; understand it. And it might even hurt overall performance, because +;;; the positive effect of removing indirection could be cancelled by +;;; the negative effect of imposing an unnecessary GC write barrier on +;;; raw data which doesn't actually affect GC.) (declaim (ftype (function (type-class) type-class) copy-type-class-coldly)) (defun copy-type-class-coldly (x) - ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have - ;; to be hand-tweaked to match. -- WHN 19991021 - (make-type-class :name (type-class-name x) - :simple-subtypep (type-class-simple-subtypep x) - :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x) - :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x) - :simple-union (type-class-simple-union x) - :complex-union (type-class-complex-union x) - :simple-intersection (type-class-simple-intersection x) - :complex-intersection (type-class-complex-intersection x) - :simple-= (type-class-simple-= x) - :complex-= (type-class-complex-= x) - :unparse (type-class-unparse x))) - -;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have to -;;; be tweaked to match. -- WHN 19991021 -(defconstant type-class-function-slots - '((:simple-subtypep . type-class-simple-subtypep) - (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) - (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) - (:simple-union . type-class-simple-union) - (:complex-union . type-class-complex-union) - (:simple-intersection . type-class-simple-intersection) - (:complex-intersection . type-class-complex-intersection) - (:simple-= . type-class-simple-=) - (:complex-= . type-class-complex-=) - (:unparse . type-class-unparse))) - -(defun class-function-slot-or-lose (name) - (or (cdr (assoc name type-class-function-slots)) + ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not + ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will + ;; have to be hand-tweaked to match. -- WHN 2001-03-19 + (make-type-class :name (type-class-name x) + . #.(mapcan (lambda (type-class-fun-slot) + (destructuring-bind (keyword . slot-accessor) + type-class-fun-slot + `(,keyword (,slot-accessor x)))) + *type-class-fun-slots*))) + +(defun class-fun-slot-or-lose (name) + (or (cdr (assoc name *type-class-fun-slots*)) (error "~S is not a defined type class method." name))) ;;; FIXME: This seems to be called at runtime by cold init code. ;;; Make sure that it's not being called at runtime anywhere but @@ -145,22 +168,21 @@ ) ; EVAL-WHEN -(defmacro define-type-method ((class method &rest more-methods) - lambda-list &body body) - #!+sb-doc - "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*" - (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD"))) +(defmacro !define-type-method ((class method &rest more-methods) + lambda-list &body body) + (let ((name (symbolicate class "-" method "-TYPE-METHOD"))) `(progn - (defun ,name ,lambda-list ,@body) + (defun ,name ,lambda-list + ,@body) (!cold-init-forms - ,@(mapcar #'(lambda (method) - `(setf (,(class-function-slot-or-lose method) - (type-class-or-lose ',class)) - #',name)) - (cons method more-methods))) + ,@(mapcar (lambda (method) + `(setf (,(class-fun-slot-or-lose method) + (type-class-or-lose ',class)) + #',name)) + (cons method more-methods))) ',name))) -(defmacro define-type-class (name &key inherits) +(defmacro !define-type-class (name &key inherits) `(!cold-init-forms ,(once-only ((n-class (if inherits `(copy-type-class-coldly (type-class-or-lose @@ -171,21 +193,30 @@ (setf (gethash ',name *type-classes*) ,n-class) ',name)))) -;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same -;;; class, invoke the simple method. Otherwise, invoke any complex method. If -;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when -;;; calling TYPE1's method. If no applicable method, return DEFAULT. -(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key - (default '(values nil t)) - (complex-arg1 :foo complex-arg1-p)) +;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the +;;; same class, invoke the simple method. Otherwise, invoke any +;;; complex method. If there isn't a distinct COMPLEX-ARG1 method, +;;; then swap the arguments when calling TYPE1's method. If no +;;; applicable method, return DEFAULT. +;;; +;;; KLUDGE: It might be a lot easier to understand this and the rest +;;; of the type system code if we used CLOS to express it instead of +;;; trying to maintain this squirrely hand-crufted object system. +;;; Unfortunately that'd require reworking PCL bootstrapping so that +;;; all the compilation can get done by the cross-compiler, which I +;;; suspect is hard, so we'll bear with the old system for the time +;;; being. -- WHN 2001-03-11 +(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key + (default '(values nil t)) + (complex-arg1 :foo complex-arg1-p)) (declare (type keyword simple complex-arg1 complex-arg2)) `(multiple-value-bind (result-a result-b valid-p) - (%invoke-type-method ',(class-function-slot-or-lose simple) - ',(class-function-slot-or-lose + (%invoke-type-method ',(class-fun-slot-or-lose simple) + ',(class-fun-slot-or-lose (if complex-arg1-p complex-arg1 complex-arg2)) - ',(class-function-slot-or-lose complex-arg2) + ',(class-fun-slot-or-lose complex-arg2) ,complex-arg1-p ,type1 ,type2) @@ -193,16 +224,17 @@ (values result-a result-b) ,default))) -;;; most of the implementation of INVOKE-TYPE-METHOD +;;; most of the implementation of !INVOKE-TYPE-METHOD ;;; -;;; KLUDGE: This function must be INLINE in order for cold init to work, -;;; because the first three arguments are TYPE-CLASS structure accessor -;;; functions whose calls have to be compiled inline in order to work in calls -;;; to this function early in cold init. So don't conditionalize this INLINE -;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things -;;; to cause the full function definitions of the relevant structure accessors -;;; to be available sufficiently early in cold init. -- WHN 19991015 -#!-sb-fluid (declaim (inline %invoke-type-method)) +;;; KLUDGE: This function must be INLINE in order for cold init to +;;; work, because the first three arguments are TYPE-CLASS structure +;;; accessor functions whose calls have to be compiled inline in order +;;; to work in calls to this function early in cold init. So don't +;;; conditionalize this INLINE declaration with #!-SB-FLUID or +;;; anything, unless you also rearrange things to cause the full +;;; function definitions of the relevant structure accessors to be +;;; available sufficiently early in cold init. -- WHN 19991015 +(declaim (inline %invoke-type-method)) (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2) (declare (type symbol simple cslot1 cslot2)) (multiple-value-bind (result-a result-b) @@ -218,11 +250,11 @@ (if complex-arg1-p (funcall complex1 type1 type2) (funcall complex1 type2 type1)) - ;; No meaningful result was found: the caller should use the - ;; default value instead. + ;; No meaningful result was found: the caller should + ;; use the default value instead. (return-from %invoke-type-method (values nil nil nil)))))))) - ;; If we get to here (without breaking out by calling RETURN-FROM) then - ;; a meaningful result was found, and we return it. + ;; If we get to here (without breaking out by calling RETURN-FROM) + ;; then a meaningful result was found, and we return it. (values result-a result-b t))) (!defun-from-collected-cold-init-forms !type-class-cold-init)