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   ;; a function which returns a Common Lisp type specifier
  89   ;; representing this type
  90   (unparse #'must-supply-this :type function)
  91
  92   #|
  93   Not used, and not really right. Probably we want a TYPE= alist for the
  94   unary operations, since there are lots of interesting unary predicates that
  95   aren't equivalent to an entire class
  96   ;; Names of functions used for testing the type of objects in this type
  97   ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
  98   ;; passed both the object and the CTYPE. Normally one or the other will be
  99   ;; supplied for any type that can be passed to TYPEP; there is no point in
 100   ;; supplying both.
 101   (unary-typep nil :type (or symbol null))
 102   (typep nil :type (or symbol null))
 103   ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
 104   ;; the type.
 105   (unary-coerce nil :type (or symbol null))
 106   (coerce :type (or symbol null))
 107   |#
 108   )
 109
 110 (eval-when (:compile-toplevel :load-toplevel :execute)
 111   ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
 112   ;; will have to be tweaked to match. -- WHN 19991021
 113   (defparameter *type-class-fun-slots*
 114     '((:simple-subtypep . type-class-simple-subtypep)
 115       (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
 116       (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
 117       (:simple-union2 . type-class-simple-union2)
 118       (:complex-union2 . type-class-complex-union2)
 119       (:simple-intersection2 . type-class-simple-intersection2)
 120       (:complex-intersection2 . type-class-complex-intersection2)
 121       (:simple-= . type-class-simple-=)
 122       (:complex-= . type-class-complex-=)
 123       (:unparse . type-class-unparse))))
 124
 125 (eval-when (:compile-toplevel :load-toplevel :execute)
 126
 127 ;;; Copy TYPE-CLASS object X, using only operations which will work
 128 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 129 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
 130 ;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
 131 ;;; load.)
 132 ;;;
 133 ;;; FIXME: It's nasty having to maintain this hand-written copy
 134 ;;; function. And it seems intrinsically dain-bramaged to have
 135 ;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
 136 ;;; LAYOUT. We should fix this:
 137 ;;;   * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
 138 ;;;   * Rewrite the various CHECK-LAYOUT-related functions so that
 139 ;;;     they check RAW-INDEX and RAW-LENGTH too.
 140 ;;;   * Remove this special hacked copy function, just use
 141 ;;;     COPY-STRUCTURE instead.
 142 ;;; (For even more improvement, it might be good to move the raw slots
 143 ;;; into the same object as the ordinary slots, instead of having the
 144 ;;; unfortunate extra level of indirection. But that'd probably
 145 ;;; require a lot of work, including updating the garbage collector to
 146 ;;; understand it. And it might even hurt overall performance, because
 147 ;;; the positive effect of removing indirection could be cancelled by
 148 ;;; the negative effect of imposing an unnecessary GC write barrier on
 149 ;;; raw data which doesn't actually affect GC.)
 150 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 151 (defun copy-type-class-coldly (x)
 152   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
 153   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
 154   ;; have to be hand-tweaked to match. -- WHN 2001-03-19
 155   (make-type-class :name (type-class-name x)
 156                    . #.(mapcan (lambda (type-class-fun-slot)
 157                                  (destructuring-bind (keyword . slot-accessor)
 158                                      type-class-fun-slot
 159                                    `(,keyword (,slot-accessor x))))
 160                                *type-class-fun-slots*)))
 161
 162 (defun class-fun-slot-or-lose (name)
 163   (or (cdr (assoc name *type-class-fun-slots*))
 164       (error "~S is not a defined type class method." name)))
 165 ;;; FIXME: This seems to be called at runtime by cold init code.
 166 ;;; Make sure that it's not being called at runtime anywhere but
 167 ;;; one-time toplevel initialization code.
 168
 169 ) ; EVAL-WHEN
 170
 171 (defmacro !define-type-method ((class method &rest more-methods)
 172                                lambda-list &body body)
 173   (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
 174     `(progn
 175        (defun ,name ,lambda-list
 176          ,@body)
 177        (!cold-init-forms
 178         ,@(mapcar (lambda (method)
 179                     `(setf (,(class-fun-slot-or-lose method)
 180                             (type-class-or-lose ',class))
 181                            #',name))
 182                   (cons method more-methods)))
 183        ',name)))
 184
 185 (defmacro !define-type-class (name &key inherits)
 186   `(!cold-init-forms
 187      ,(once-only ((n-class (if inherits
 188                                `(copy-type-class-coldly (type-class-or-lose
 189                                                          ',inherits))
 190                                '(make-type-class))))
 191         `(progn
 192            (setf (type-class-name ,n-class) ',name)
 193            (setf (gethash ',name *type-classes*) ,n-class)
 194            ',name))))
 195
 196 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
 197 ;;; same class, invoke the simple method. Otherwise, invoke any
 198 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
 199 ;;; then swap the arguments when calling TYPE1's method. If no
 200 ;;; applicable method, return DEFAULT.
 201 ;;;
 202 ;;; KLUDGE: It might be a lot easier to understand this and the rest
 203 ;;; of the type system code if we used CLOS to express it instead of
 204 ;;; trying to maintain this squirrely hand-crufted object system.
 205 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
 206 ;;; all the compilation can get done by the cross-compiler, which I
 207 ;;; suspect is hard, so we'll bear with the old system for the time
 208 ;;; being. -- WHN 2001-03-11
 209 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
 210                                       (default '(values nil t))
 211                                       (complex-arg1 :foo complex-arg1-p))
 212   (declare (type keyword simple complex-arg1 complex-arg2))
 213   `(multiple-value-bind (result-a result-b valid-p)
 214        (%invoke-type-method ',(class-fun-slot-or-lose simple)
 215                             ',(class-fun-slot-or-lose
 216                                (if complex-arg1-p
 217                                    complex-arg1
 218                                    complex-arg2))
 219                             ',(class-fun-slot-or-lose complex-arg2)
 220                             ,complex-arg1-p
 221                             ,type1
 222                             ,type2)
 223      (if valid-p
 224          (values result-a result-b)
 225          ,default)))
 226
 227 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 228 ;;;
 229 ;;; KLUDGE: This function must be INLINE in order for cold init to
 230 ;;; work, because the first three arguments are TYPE-CLASS structure
 231 ;;; accessor functions whose calls have to be compiled inline in order
 232 ;;; to work in calls to this function early in cold init. So don't
 233 ;;; conditionalize this INLINE declaration with #!-SB-FLUID or
 234 ;;; anything, unless you also rearrange things to cause the full
 235 ;;; function definitions of the relevant structure accessors to be
 236 ;;; available sufficiently early in cold init. -- WHN 19991015
 237 (declaim (inline %invoke-type-method))
 238 (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
 239   (declare (type symbol simple cslot1 cslot2))
 240   (multiple-value-bind (result-a result-b)
 241       (let ((class1 (type-class-info type1))
 242             (class2 (type-class-info type2)))
 243         (if (eq class1 class2)
 244             (funcall (funcall simple class1) type1 type2)
 245             (let ((complex2 (funcall cslot2 class2)))
 246               (if complex2
 247                   (funcall complex2 type1 type2)
 248                   (let ((complex1 (funcall cslot1 class1)))
 249                     (if complex1
 250                         (if complex-arg1-p
 251                             (funcall complex1 type1 type2)
 252                             (funcall complex1 type2 type1))
 253                         ;; No meaningful result was found: the caller
 254                         ;; should use the default value instead.
 255                         (return-from %invoke-type-method
 256                           (values nil nil nil))))))))
 257     ;; If we get to here (without breaking out by calling RETURN-FROM)
 258     ;; then a meaningful result was found, and we return it.
 259     (values result-a result-b t)))
 260
 261 ;;; This is a very specialized implementation of CLOS-style
 262 ;;; CALL-NEXT-METHOD within our twisty little type class object
 263 ;;; system, which works given that it's called from within a
 264 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
 265 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
 266 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
 267 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
 268 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
 269 ;;;
 270 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
 271 ;;; everything would Just Work without us having to think about it. In
 272 ;;; our goofy type dispatch system, it's messier to express. It's also
 273 ;;; more fragile, since (0) there's no check that it's called from
 274 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
 275 ;;; rely on our global knowledge that the next (and only) relevant
 276 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
 277 ;;; knowledge of the appropriate default for the CSUBTYPEP function
 278 ;;; when no next method exists. -- WHN 2002-04-07
 279 ;;;
 280 ;;; (We miss CLOS! -- CSR and WHN)
 281 (defun invoke-complex-subtypep-arg1-method (type1 type2)
 282   (let* ((type-class (type-class-info type1))
 283          (method-fun (type-class-complex-subtypep-arg1 type-class)))
 284     (if method-fun
 285         (funcall (the function method-fun) type1 type2)
 286         (values nil nil))))
 287
 288 (!defun-from-collected-cold-init-forms !type-class-cold-init)