src/code/type-class.lisp

   1 ;;;; stuff related to the TYPE-CLASS structure
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (!begin-collecting-cold-init-forms)
  15
  16 (defvar *type-classes*)
  17 (!cold-init-forms
  18   (unless (boundp '*type-classes*) ; FIXME: How could this be bound?
  19     (setq *type-classes* (make-hash-table :test 'eq))))
  20
  21 (defun type-class-or-lose (name)
  22   (or (gethash name *type-classes*)
  23       (error "~S is not a defined type class." name)))
  24
  25 (defun must-supply-this (&rest foo)
  26   (/show0 "failing in MUST-SUPPLY-THIS")
  27   (error "missing type method for ~S" foo))
  28
  29 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
  30 ;;; contains functions which are methods on that kind of type, but is
  31 ;;; also used in EQ comparisons to determined if two types have the
  32 ;;; "same kind".
  33 (def!struct (type-class
  34              #-no-ansi-print-object
  35              (:print-object (lambda (x stream)
  36                               (print-unreadable-object (x stream :type t)
  37                                 (prin1 (type-class-name x) stream)))))
  38   ;; the name of this type class (used to resolve references at load time)
  39   (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default?
  40   ;; Dyadic type methods. If the classes of the two types are EQ, then
  41   ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
  42   ;; either type's class has a COMPLEX-xxx method, then we call it.
  43   ;;
  44   ;; Although it is undefined which method will get precedence when
  45   ;; both types have a complex method, the complex method can assume
  46   ;; that the second arg always is in its class, and the first always
  47   ;; is not. The arguments to commutative operations will be swapped
  48   ;; if the first argument has a complex method.
  49   ;;
  50   ;; Since SUBTYPEP is not commutative, we have two complex methods.
  51   ;; The ARG1 method is only called when the first argument is in its
  52   ;; class, and the ARG2 method is only called when called when the
  53   ;; second type is. If either is specified, both must be.
  54   (simple-subtypep #'must-supply-this :type function)
  55   (complex-subtypep-arg1 nil :type (or function null))
  56   (complex-subtypep-arg2 nil :type (or function null))
  57   ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
  58   ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
  59   ;; a new type which expresses the result nicely, better than could
  60   ;; be done by just stuffing the two component types into an
  61   ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
  62   ;; failure, or a CTYPE for success.
  63   ;;
  64   ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
  65   ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
  66   ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
  67   ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
  68   ;; wants to simplify unions and intersections by considering all
  69   ;; possible pairwise simplifications (where the CMU CL code only
  70   ;; considered simplifications between types which happened to appear
  71   ;; next to each other the argument sequence).
  72   ;;
  73   ;; Differences in detail from old CMU CL methods:
  74   ;;   * SBCL's methods are more parallel between union and
  75   ;;     intersection forms. Each returns one values, (OR NULL CTYPE).
  76   ;;   * SBCL doesn't use type methods to deal with unions or
  77   ;;     intersections of the COMPOUND-TYPE of the corresponding form.
  78   ;;     Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
  79   ;;     TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
  80   ;;     (and deal with canonicalization/simplification issues at the
  81   ;;     same time).
  82   (simple-union2 #'hierarchical-union2 :type function)
  83   (complex-union2 nil :type (or function null))
  84   (simple-intersection2 #'hierarchical-intersection2 :type function)
  85   (complex-intersection2 nil :type (or function null))
  86   (simple-= #'must-supply-this :type function)
  87   (complex-= nil :type (or function null))
  88   ;; monadic functions
  89   (negate #'must-supply-this :type function)
  90   ;; a function which returns a Common Lisp type specifier
  91   ;; representing this type
  92   (unparse #'must-supply-this :type function)
  93
  94   #|
  95   Not used, and not really right. Probably we want a TYPE= alist for the
  96   unary operations, since there are lots of interesting unary predicates that
  97   aren't equivalent to an entire class
  98   ;; Names of functions used for testing the type of objects in this type
  99   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
 100   ;; passed both the object and the CTYPE. Normally one or the other will be
 101   ;; supplied for any type that can be passed to TYPEP; there is no point in
 102   ;; supplying both.
 103   (unary-typep nil :type (or symbol null))
 104   (typep nil :type (or symbol null))
 105   ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
 106   ;; the type.
 107   (unary-coerce nil :type (or symbol null))
 108   (coerce :type (or symbol null))
 109   |#
 110   )
 111
 112 (eval-when (:compile-toplevel :load-toplevel :execute)
 113   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 114   ;; will have to be tweaked to match. -- WHN 19991021
 115   (defparameter *type-class-fun-slots*
 116     '((:simple-subtypep . type-class-simple-subtypep)
 117       (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 118       (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 119       (:simple-union2 . type-class-simple-union2)
 120       (:complex-union2 . type-class-complex-union2)
 121       (:simple-intersection2 . type-class-simple-intersection2)
 122       (:complex-intersection2 . type-class-complex-intersection2)
 123       (:simple-= . type-class-simple-=)
 124       (:complex-= . type-class-complex-=)
 125       (:negate . type-class-negate)
 126       (:unparse . type-class-unparse))))
 127
 128 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 129 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 130 ;;; Copy TYPE-CLASS object X, using only operations which will work
 131 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 132 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
 133 ;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
 134 ;;; load.)
 135 ;;;
 136 ;;; FIXME: It's nasty having to maintain this hand-written copy
 137 ;;; function. And it seems intrinsically dain-bramaged to have
 138 ;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
 139 ;;; LAYOUT. We should fix this:
 140 ;;;   * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
 141 ;;;   * Rewrite the various CHECK-LAYOUT-related functions so that
 142 ;;;     they check RAW-INDEX and RAW-LENGTH too.
 143 ;;;   * Remove this special hacked copy function, just use
 144 ;;;     COPY-STRUCTURE instead.
 145 ;;; (For even more improvement, it might be good to move the raw slots
 146 ;;; into the same object as the ordinary slots, instead of having the
 147 ;;; unfortunate extra level of indirection. But that'd probably
 148 ;;; require a lot of work, including updating the garbage collector to
 149 ;;; understand it. And it might even hurt overall performance, because
 150 ;;; the positive effect of removing indirection could be cancelled by
 151 ;;; the negative effect of imposing an unnecessary GC write barrier on
 152 ;;; raw data which doesn't actually affect GC.)
 153 (defun copy-type-class-coldly (x)
 154   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
 155   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
 156   ;; have to be hand-tweaked to match. -- WHN 2001-03-19
 157   (make-type-class :name (type-class-name x)
 158                    . #.(mapcan (lambda (type-class-fun-slot)
 159                                  (destructuring-bind (keyword . slot-accessor)
 160                                      type-class-fun-slot
 161                                    `(,keyword (,slot-accessor x))))
 162                                *type-class-fun-slots*)))
 163
 164 (defun class-fun-slot-or-lose (name)
 165   (or (cdr (assoc name *type-class-fun-slots*))
 166       (error "~S is not a defined type class method." name)))
 167 ;;; FIXME: This seems to be called at runtime by cold init code.
 168 ;;; Make sure that it's not being called at runtime anywhere but
 169 ;;; one-time toplevel initialization code.
 170
 171 ) ; EVAL-WHEN
 172
 173 (defmacro !define-type-method ((class method &rest more-methods)
 174                                lambda-list &body body)
 175   (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
 176     `(progn
 177        (defun ,name ,lambda-list
 178          ,@body)
 179        (!cold-init-forms
 180         ,@(mapcar (lambda (method)
 181                     `(setf (,(class-fun-slot-or-lose method)
 182                             (type-class-or-lose ',class))
 183                            #',name))
 184                   (cons method more-methods)))
 185        ',name)))
 186
 187 (defmacro !define-type-class (name &key inherits)
 188   `(!cold-init-forms
 189      ,(once-only ((n-class (if inherits
 190                                `(copy-type-class-coldly (type-class-or-lose
 191                                                          ',inherits))
 192                                '(make-type-class))))
 193         `(progn
 194            (setf (type-class-name ,n-class) ',name)
 195            (setf (gethash ',name *type-classes*) ,n-class)
 196            ',name))))
 197
 198 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
 199 ;;; same class, invoke the simple method. Otherwise, invoke any
 200 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
 201 ;;; then swap the arguments when calling TYPE1's method. If no
 202 ;;; applicable method, return DEFAULT.
 203 ;;;
 204 ;;; KLUDGE: It might be a lot easier to understand this and the rest
 205 ;;; of the type system code if we used CLOS to express it instead of
 206 ;;; trying to maintain this squirrely hand-crufted object system.
 207 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
 208 ;;; all the compilation can get done by the cross-compiler, which I
 209 ;;; suspect is hard, so we'll bear with the old system for the time
 210 ;;; being. -- WHN 2001-03-11
 211 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
 212                                       (default '(values nil t))
 213                                       (complex-arg1 :foo complex-arg1-p))
 214   (declare (type keyword simple complex-arg1 complex-arg2))
 215   `(multiple-value-bind (result-a result-b valid-p)
 216        (%invoke-type-method ',(class-fun-slot-or-lose simple)
 217                             ',(class-fun-slot-or-lose
 218                                (if complex-arg1-p
 219                                    complex-arg1
 220                                    complex-arg2))
 221                             ',(class-fun-slot-or-lose complex-arg2)
 222                             ,complex-arg1-p
 223                             ,type1
 224                             ,type2)
 225      (if valid-p
 226          (values result-a result-b)
 227          ,default)))
 228
 229 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 230 ;;;
 231 ;;; KLUDGE: This function must be INLINE in order for cold init to
 232 ;;; work, because the first three arguments are TYPE-CLASS structure
 233 ;;; accessor functions whose calls have to be compiled inline in order
 234 ;;; to work in calls to this function early in cold init. So don't
 235 ;;; conditionalize this INLINE declaration with #!-SB-FLUID or
 236 ;;; anything, unless you also rearrange things to cause the full
 237 ;;; function definitions of the relevant structure accessors to be
 238 ;;; available sufficiently early in cold init. -- WHN 19991015
 239 (declaim (inline %invoke-type-method))
 240 (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
 241   (declare (type symbol simple cslot1 cslot2))
 242   (multiple-value-bind (result-a result-b)
 243       (let ((class1 (type-class-info type1))
 244             (class2 (type-class-info type2)))
 245         (if (eq class1 class2)
 246             (funcall (the function (funcall simple class1)) type1 type2)
 247             (let ((complex2 (funcall cslot2 class2)))
 248               (declare (type (or function null) complex2))
 249               (if complex2
 250                   (funcall complex2 type1 type2)
 251                   (let ((complex1 (funcall cslot1 class1)))
 252                     (declare (type (or function null) complex1))
 253                     (if complex1
 254                         (if complex-arg1-p
 255                             (funcall complex1 type1 type2)
 256                             (funcall complex1 type2 type1))
 257                         ;; No meaningful result was found: the caller
 258                         ;; should use the default value instead.
 259                         (return-from %invoke-type-method
 260                           (values nil nil nil))))))))
 261     ;; If we get to here (without breaking out by calling RETURN-FROM)
 262     ;; then a meaningful result was found, and we return it.
 263     (values result-a result-b t)))
 264
 265 ;;; This is a very specialized implementation of CLOS-style
 266 ;;; CALL-NEXT-METHOD within our twisty little type class object
 267 ;;; system, which works given that it's called from within a
 268 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
 269 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
 270 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
 271 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
 272 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
 273 ;;;
 274 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
 275 ;;; everything would Just Work without us having to think about it. In
 276 ;;; our goofy type dispatch system, it's messier to express. It's also
 277 ;;; more fragile, since (0) there's no check that it's called from
 278 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
 279 ;;; rely on our global knowledge that the next (and only) relevant
 280 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
 281 ;;; knowledge of the appropriate default for the CSUBTYPEP function
 282 ;;; when no next method exists. -- WHN 2002-04-07
 283 ;;;
 284 ;;; (We miss CLOS! -- CSR and WHN)
 285 (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
 286   (let* ((type-class (type-class-info type1))
 287          (method-fun (type-class-complex-subtypep-arg1 type-class)))
 288     (if method-fun
 289         (funcall (the function method-fun) type1 type2)
 290         (values subtypep win))))
 291
 292 ;;; KLUDGE: This function is dangerous, as its overuse could easily
 293 ;;; cause stack exhaustion through unbounded recursion.  We only use
 294 ;;; it in one place; maybe it ought not to be a function at all?
 295 (defun invoke-complex-=-other-method (type1 type2)
 296   (let* ((type-class (type-class-info type1))
 297          (method-fun (type-class-complex-= type-class)))
 298     (if method-fun
 299         (funcall (the function method-fun) type2 type1)
 300         (values nil t))))
 301
 302 (!defun-from-collected-cold-init-forms !type-class-cold-init)