1;;;; This software is part of the SBCL system. See the README file for 2;;;; more information. 3 4;;;; This software is derived from software originally released by Xerox 5;;;; Corporation. Copyright and release statements follow. Later modifications 6;;;; to the software are in the public domain and are provided with 7;;;; absolutely no warranty. See the COPYING and CREDITS files for more 8;;;; information. 9 10;;;; copyright information from original PCL sources: 11;;;; 12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 13;;;; All rights reserved. 14;;;; 15;;;; Use and copying of this software and preparation of derivative works based 16;;;; upon this software are permitted. Any distribution of this software or 17;;;; derivative works must comply with all applicable United States export 18;;;; control laws. 19;;;; 20;;;; This software is made available AS IS, and Xerox Corporation makes no 21;;;; warranty about the software, its performance or its conformity to any 22;;;; specification. 23 24(in-package "SB-PCL") 25 26#| 27 28This implementation of method lookup was redone in early August of 89. 29 30It has the following properties: 31 32 - Its modularity makes it easy to modify the actual caching algorithm. 33 The caching algorithm is almost completely separated into the files 34 cache.lisp and dlap.lisp. This file just contains the various uses 35 of it. There will be more tuning as we get more results from Luis' 36 measurements of caching behavior. 37 38 - The metacircularity issues have been dealt with properly. All of 39 PCL now grounds out properly. Moreover, it is now possible to have 40 metaobject classes which are themselves not instances of standard 41 metaobject classes. 42 43** Modularity of the code ** 44 45The actual caching algorithm is isolated in a modest number of functions. 46The code which generates cache lookup code is all found in cache.lisp and 47dlap.lisp. Certain non-wrapper-caching special cases are in this file. 48 49** Handling the metacircularity ** 50 51In CLOS, method lookup is the potential source of infinite metacircular 52regress. The metaobject protocol specification gives us wide flexibility 53in how to address this problem. PCL uses a technique which handles the 54problem not only for the metacircular language described in Chapter 3, but 55also for the PCL protocol which includes additional generic functions 56which control more aspects of the CLOS implementation. 57 58The source of the metacircular regress can be seen in a number of ways. 59One is that the specified method lookup protocol must, as part of doing 60the method lookup (or at least the cache miss case), itself call generic 61functions. It is easy to see that if the method lookup for a generic 62function ends up calling that same generic function there can be trouble. 63 64Fortunately, there is an easy solution at hand. The solution is based on 65the restriction that portable code cannot change the class of a specified 66metaobject. This restriction implies that for specified generic functions, 67the method lookup protocol they follow is fixed. 68 69More precisely, for such specified generic functions, most generic functions 70that are called during their own method lookup will not run portable methods. 71This allows the implementation to usurp the actual generic function call in 72this case. In short, method lookup of a standard generic function, in the 73case where the only applicable methods are themselves standard doesn't 74have to do any method lookup to implement itself. 75 76And so, we are saved. 77 78Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 79 80|# 81 82;;; an alist in which each entry is of the form 83;;; (<generator> . (<subentry> ...)). 84;;; Each subentry is of the form 85;;; (<args> <constructor> <system>). 86(defvar *dfun-constructors* ()) 87 88;;; If this is NIL, then the whole mechanism for caching dfun constructors is 89;;; turned off. The only time that makes sense is when debugging LAP code. 90(defvar *enable-dfun-constructor-caching* t) 91 92(defun show-dfun-constructors () 93 (format t "~&DFUN constructor caching is ~A." 94 (if *enable-dfun-constructor-caching* 95 "enabled" "disabled")) 96 (dolist (generator-entry *dfun-constructors*) 97 (dolist (args-entry (cdr generator-entry)) 98 (format t "~&~S ~S" 99 (cons (car generator-entry) (caar args-entry)) 100 (caddr args-entry))))) 101 102(defvar *raise-metatypes-to-class-p* t) 103 104(defun get-dfun-constructor (generator &rest args) 105 (when (and *raise-metatypes-to-class-p* 106 (member generator '(emit-checking emit-caching 107 emit-in-checking-cache-p emit-constant-value))) 108 (setq args (cons (mapcar (lambda (mt) 109 (if (eq mt t) 110 mt 111 'class)) 112 (car args)) 113 (cdr args)))) 114 (let* ((generator-entry (assq generator *dfun-constructors*)) 115 (args-entry (assoc args (cdr generator-entry) :test #'equal))) 116 (if (null *enable-dfun-constructor-caching*) 117 (apply (fdefinition generator) args) 118 (or (cadr args-entry) 119 (multiple-value-bind (new not-best-p) 120 (apply (symbol-function generator) args) 121 (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) 122 not-best-p))) 123 (if generator-entry 124 (push entry (cdr generator-entry)) 125 (push (list generator entry) 126 *dfun-constructors*))) 127 (values new not-best-p)))))) 128 129(defun load-precompiled-dfun-constructor (generator args system constructor) 130 (let* ((generator-entry (assq generator *dfun-constructors*)) 131 (args-entry (assoc args (cdr generator-entry) :test #'equal))) 132 (if args-entry 133 (when (fourth args-entry) 134 (let* ((dfun-type (case generator 135 (emit-checking 'checking) 136 (emit-caching 'caching) 137 (emit-constant-value 'constant-value) 138 (emit-default-only 'default-method-only))) 139 (metatypes (car args)) 140 (gfs (when dfun-type (gfs-of-type dfun-type)))) 141 (dolist (gf gfs) 142 (when (and (equal metatypes 143 (arg-info-metatypes (gf-arg-info gf))) 144 (let ((gf-name (generic-function-name gf))) 145 (and (not (eq gf-name 'slot-value-using-class)) 146 (not (equal gf-name 147 '(setf slot-value-using-class))) 148 (not (eq gf-name 'slot-boundp-using-class))))) 149 (update-dfun gf))) 150 (setf (second args-entry) constructor) 151 (setf (third args-entry) system) 152 (setf (fourth args-entry) nil))) 153 (let ((entry (list args constructor system nil))) 154 (if generator-entry 155 (push entry (cdr generator-entry)) 156 (push (list generator entry) *dfun-constructors*)))))) 157 158(defmacro precompile-dfun-constructors (&optional system) 159 (let ((*precompiling-lap* t)) 160 `(progn 161 ,@(let (collect) 162 (dolist (generator-entry *dfun-constructors*) 163 (dolist (args-entry (cdr generator-entry)) 164 (when (or (null (caddr args-entry)) 165 (eq (caddr args-entry) system)) 166 (when system (setf (caddr args-entry) system)) 167 (push `(load-precompiled-dfun-constructor 168 ',(car generator-entry) 169 ',(car args-entry) 170 ',system 171 ,(apply (fdefinition (car generator-entry)) 172 (car args-entry))) 173 collect)))) 174 (nreverse collect))))) 175 176;;; Standardized class slot access: when trying to break vicious 177;;; metacircles, we need a way to get at the values of slots of some 178;;; standard classes without going through the whole meta machinery, 179;;; because that would likely enter the vicious circle again. The 180;;; following are helper functions that short-circuit the generic 181;;; lookup machinery. 182 183(defvar *standard-classes* 184 ;; KLUDGE: order matters! finding effective slot definitions 185 ;; involves calling slot-definition-name, and we need to do that to 186 ;; break metacycles, so STANDARD-EFFECTIVE-SLOT-DEFINITION must 187 ;; precede STANDARD-DIRECT-SLOT-DEFINITION in this list, at least 188 ;; until ACCESSES-STANDARD-CLASS-SLOT-P is generalized 189 '(standard-method standard-generic-function standard-class 190 standard-effective-slot-definition standard-direct-slot-definition)) 191 192(defvar *standard-slot-locations* (make-hash-table :test 'equal)) 193 194(defun compute-standard-slot-locations () 195 (let ((new (make-hash-table :test 'equal))) 196 (dolist (class-name *standard-classes*) 197 (let ((class (find-class class-name))) 198 (dolist (slot (class-slots class)) 199 (setf (gethash (cons class (slot-definition-name slot)) new) 200 (slot-definition-location slot))))) 201 (setf *standard-slot-locations* new))) 202 203(defun maybe-update-standard-slot-locations (class) 204 (when (and (eq **boot-state** 'complete) 205 (memq (class-name class) *standard-classes*)) 206 (compute-standard-slot-locations))) 207 208(defun standard-slot-value (object slot-name class) 209 (declare (notinline standard-instance-access 210 funcallable-standard-instance-access)) 211 (let ((location (gethash (cons class slot-name) *standard-slot-locations*))) 212 (if location 213 (let ((value (if (funcallable-instance-p object) 214 (funcallable-standard-instance-access object location) 215 (standard-instance-access object location)))) 216 (when (eq +slot-unbound+ value) 217 (error "~@<slot ~S of class ~S is unbound in object ~S~@:>" 218 slot-name class object)) 219 value) 220 (error "~@<cannot get standard value of slot ~S of class ~S ~ 221 in object ~S~@:>" 222 slot-name class object)))) 223 224(defun standard-slot-value/gf (gf slot-name) 225 (standard-slot-value gf slot-name *the-class-standard-generic-function*)) 226 227(defun standard-slot-value/method (method slot-name) 228 (standard-slot-value method slot-name *the-class-standard-method*)) 229 230(defun standard-slot-value/eslotd (slotd slot-name) 231 (standard-slot-value slotd slot-name 232 *the-class-standard-effective-slot-definition*)) 233 234(defun standard-slot-value/dslotd (slotd slot-name) 235 (standard-slot-value slotd slot-name 236 *the-class-standard-direct-slot-definition*)) 237 238(defun standard-slot-value/class (class slot-name) 239 (standard-slot-value class slot-name *the-class-standard-class*)) 240 241;;; When all the methods of a generic function are automatically 242;;; generated reader or writer methods a number of special 243;;; optimizations are possible. These are important because of the 244;;; large number of generic functions of this type. 245;;; 246;;; There are a number of cases: 247;;; 248;;; ONE-CLASS-ACCESSOR 249;;; In this case, the accessor generic function has only been 250;;; called with one class of argument. There is no cache vector, 251;;; the wrapper of the one class, and the slot index are stored 252;;; directly as closure variables of the discriminating function. 253;;; This case can convert to either of the next kind. 254;;; 255;;; TWO-CLASS-ACCESSOR 256;;; Like above, but two classes. This is common enough to do 257;;; specially. There is no cache vector. The two classes are 258;;; stored a separate closure variables. 259;;; 260;;; ONE-INDEX-ACCESSOR 261;;; In this case, the accessor generic function has seen more than 262;;; one class of argument, but the index of the slot is the same 263;;; for all the classes that have been seen. A cache vector is 264;;; used to store the wrappers that have been seen, the slot index 265;;; is stored directly as a closure variable of the discriminating 266;;; function. This case can convert to the next kind. 267;;; 268;;; N-N-ACCESSOR 269;;; This is the most general case. In this case, the accessor 270;;; generic function has seen more than one class of argument and 271;;; more than one slot index. A cache vector stores the wrappers 272;;; and corresponding slot indexes. 273 274(defstruct (dfun-info (:constructor nil) 275 (:copier nil)) 276 (cache nil)) 277 278(defstruct (no-methods (:constructor no-methods-dfun-info ()) 279 (:include dfun-info) 280 (:copier nil))) 281 282(defstruct (initial (:constructor initial-dfun-info ()) 283 (:include dfun-info) 284 (:copier nil))) 285 286(defstruct (dispatch (:constructor dispatch-dfun-info ()) 287 (:include dfun-info) 288 (:copier nil))) 289 290(defstruct (default-method-only (:constructor default-method-only-dfun-info ()) 291 (:include dfun-info) 292 (:copier nil))) 293 294;without caching: 295; dispatch one-class two-class default-method-only 296 297;with caching: 298; one-index n-n checking caching 299 300;accessor: 301; one-class two-class one-index n-n 302(defstruct (accessor-dfun-info (:constructor nil) 303 (:include dfun-info) 304 (:copier nil)) 305 accessor-type) ; (member reader writer) 306 307(defmacro dfun-info-accessor-type (di) 308 `(accessor-dfun-info-accessor-type ,di)) 309 310(defstruct (one-index-dfun-info (:constructor nil) 311 (:include accessor-dfun-info) 312 (:copier nil)) 313 index) 314 315(defmacro dfun-info-index (di) 316 `(one-index-dfun-info-index ,di)) 317 318(defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) 319 (:include accessor-dfun-info) 320 (:copier nil))) 321 322(defstruct (one-class (:constructor one-class-dfun-info 323 (accessor-type index wrapper0)) 324 (:include one-index-dfun-info) 325 (:copier nil)) 326 wrapper0) 327 328(defmacro dfun-info-wrapper0 (di) 329 `(one-class-wrapper0 ,di)) 330 331(defstruct (two-class (:constructor two-class-dfun-info 332 (accessor-type index wrapper0 wrapper1)) 333 (:include one-class) 334 (:copier nil)) 335 wrapper1) 336 337(defmacro dfun-info-wrapper1 (di) 338 `(two-class-wrapper1 ,di)) 339 340(defstruct (one-index (:constructor one-index-dfun-info 341 (accessor-type index cache)) 342 (:include one-index-dfun-info) 343 (:copier nil))) 344 345(defstruct (checking (:constructor checking-dfun-info (function cache)) 346 (:include dfun-info) 347 (:copier nil)) 348 function) 349 350(defmacro dfun-info-function (di) 351 `(checking-function ,di)) 352 353(defstruct (caching (:constructor caching-dfun-info (cache)) 354 (:include dfun-info) 355 (:copier nil))) 356 357(defstruct (constant-value (:constructor constant-value-dfun-info (cache)) 358 (:include dfun-info) 359 (:copier nil))) 360 361(defmacro dfun-update (generic-function function &rest args) 362 `(multiple-value-bind (dfun cache info) 363 (funcall ,function ,generic-function ,@args) 364 (update-dfun ,generic-function dfun cache info))) 365 366(defun accessor-miss-function (gf dfun-info) 367 (ecase (dfun-info-accessor-type dfun-info) 368 ((reader boundp) 369 (lambda (arg) 370 (accessor-miss gf nil arg dfun-info))) 371 (writer 372 (lambda (new arg) 373 (accessor-miss gf new arg dfun-info))))) 374 375#-sb-fluid (declaim (sb-ext:freeze-type dfun-info)) 376 377(defun make-one-class-accessor-dfun (gf type wrapper index) 378 (let ((emit (ecase type 379 (reader 'emit-one-class-reader) 380 (boundp 'emit-one-class-boundp) 381 (writer 'emit-one-class-writer))) 382 (dfun-info (one-class-dfun-info type index wrapper))) 383 (values 384 (funcall (get-dfun-constructor emit (consp index)) 385 wrapper index 386 (accessor-miss-function gf dfun-info)) 387 nil 388 dfun-info))) 389 390(defun make-two-class-accessor-dfun (gf type w0 w1 index) 391 (let ((emit (ecase type 392 (reader 'emit-two-class-reader) 393 (boundp 'emit-two-class-boundp) 394 (writer 'emit-two-class-writer))) 395 (dfun-info (two-class-dfun-info type index w0 w1))) 396 (values 397 (funcall (get-dfun-constructor emit (consp index)) 398 w0 w1 index 399 (accessor-miss-function gf dfun-info)) 400 nil 401 dfun-info))) 402 403;;; std accessors same index dfun 404(defun make-one-index-accessor-dfun (gf type index &optional cache) 405 (let* ((emit (ecase type 406 (reader 'emit-one-index-readers) 407 (boundp 'emit-one-index-boundps) 408 (writer 'emit-one-index-writers))) 409 (cache (or cache (make-cache :key-count 1 :value nil :size 4))) 410 (dfun-info (one-index-dfun-info type index cache))) 411 (declare (type cache cache)) 412 (values 413 (funcall (get-dfun-constructor emit (consp index)) 414 cache 415 index 416 (accessor-miss-function gf dfun-info)) 417 cache 418 dfun-info))) 419 420(defun make-n-n-accessor-dfun (gf type &optional cache) 421 (let* ((emit (ecase type 422 (reader 'emit-n-n-readers) 423 (boundp 'emit-n-n-boundps) 424 (writer 'emit-n-n-writers))) 425 (cache (or cache (make-cache :key-count 1 :value t :size 2))) 426 (dfun-info (n-n-dfun-info type cache))) 427 (declare (type cache cache)) 428 (values 429 (funcall (get-dfun-constructor emit) 430 cache 431 (accessor-miss-function gf dfun-info)) 432 cache 433 dfun-info))) 434 435(defun make-checking-dfun (generic-function function &optional cache) 436 (unless cache 437 (when (use-caching-dfun-p generic-function) 438 (return-from make-checking-dfun (make-caching-dfun generic-function))) 439 (when (use-dispatch-dfun-p generic-function) 440 (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) 441 (multiple-value-bind (nreq applyp metatypes nkeys) 442 (get-generic-fun-info generic-function) 443 (declare (ignore nreq)) 444 (if (every (lambda (mt) (eq mt t)) metatypes) 445 (let ((dfun-info (default-method-only-dfun-info))) 446 (values 447 (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) 448 function) 449 nil 450 dfun-info)) 451 (let* ((cache (or cache (make-cache :key-count nkeys :value nil :size 2))) 452 (dfun-info (checking-dfun-info function cache))) 453 (values 454 (funcall (get-dfun-constructor 'emit-checking metatypes applyp) 455 cache 456 function 457 (lambda (&rest args) 458 (checking-miss generic-function args dfun-info))) 459 cache 460 dfun-info))))) 461 462(defun make-final-checking-dfun (generic-function function classes-list new-class) 463 (multiple-value-bind (nreq applyp metatypes nkeys) 464 (get-generic-fun-info generic-function) 465 (declare (ignore nreq applyp nkeys)) 466 (if (every (lambda (mt) (eq mt t)) metatypes) 467 (values (lambda (&rest args) 468 (invoke-emf function args)) 469 nil (default-method-only-dfun-info)) 470 (let ((cache (make-final-ordinary-dfun-cache 471 generic-function nil classes-list new-class))) 472 (make-checking-dfun generic-function function cache))))) 473 474(defun use-default-method-only-dfun-p (generic-function) 475 (multiple-value-bind (nreq applyp metatypes nkeys) 476 (get-generic-fun-info generic-function) 477 (declare (ignore nreq applyp nkeys)) 478 (every (lambda (mt) (eq mt t)) metatypes))) 479 480(defun use-caching-dfun-p (generic-function) 481 (some (lambda (method) (method-plist-value method :slot-name-lists)) 482 ;; KLUDGE: As of sbcl-0.6.4, it's very important for 483 ;; efficiency to know the type of the sequence argument to 484 ;; quantifiers (SOME/NOTANY/etc.) at compile time, but 485 ;; the compiler isn't smart enough to understand the :TYPE 486 ;; slot option for DEFCLASS, so we just tell 487 ;; it the type by hand here. 488 (the list 489 (if (early-gf-p generic-function) 490 (early-gf-methods generic-function) 491 (generic-function-methods generic-function))))) 492 493(defun make-caching-dfun (generic-function &optional cache) 494 (unless cache 495 (when (use-constant-value-dfun-p generic-function) 496 (return-from make-caching-dfun 497 (make-constant-value-dfun generic-function))) 498 (when (use-dispatch-dfun-p generic-function) 499 (return-from make-caching-dfun 500 (make-dispatch-dfun generic-function)))) 501 (multiple-value-bind (nreq applyp metatypes nkeys) 502 (get-generic-fun-info generic-function) 503 (declare (ignore nreq)) 504 (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) 505 (dfun-info (caching-dfun-info cache))) 506 (values 507 (funcall (get-dfun-constructor 'emit-caching metatypes applyp) 508 cache 509 (lambda (&rest args) 510 (caching-miss generic-function args dfun-info))) 511 cache 512 dfun-info)))) 513 514(defun make-final-caching-dfun (generic-function classes-list new-class) 515 (let ((cache (make-final-ordinary-dfun-cache 516 generic-function t classes-list new-class))) 517 (make-caching-dfun generic-function cache))) 518 519(defun insure-caching-dfun (gf) 520 (multiple-value-bind (nreq applyp metatypes nkeys) 521 (get-generic-fun-info gf) 522 (declare (ignore nreq nkeys)) 523 (when (and metatypes 524 (not (null (car metatypes))) 525 (dolist (mt metatypes nil) 526 (unless (eq mt t) (return t)))) 527 (get-dfun-constructor 'emit-caching metatypes applyp)))) 528 529(defun use-constant-value-dfun-p (gf &optional boolean-values-p) 530 (multiple-value-bind (nreq applyp metatypes nkeys) 531 (get-generic-fun-info gf) 532 (declare (ignore nreq metatypes nkeys)) 533 (let* ((early-p (early-gf-p gf)) 534 (methods (if early-p 535 (early-gf-methods gf) 536 (generic-function-methods gf))) 537 (default '(unknown))) 538 (and (null applyp) 539 (or (not (eq **boot-state** 'complete)) 540 ;; If COMPUTE-APPLICABLE-METHODS is specialized, we 541 ;; can't use this, of course, because we can't tell 542 ;; which methods will be considered applicable. 543 ;; 544 ;; Also, don't use this dfun method if the generic 545 ;; function has a non-standard method combination, 546 ;; because if it has, it's not sure that method 547 ;; functions are used directly as effective methods, 548 ;; which CONSTANT-VALUE-MISS depends on. The 549 ;; pre-defined method combinations like LIST are 550 ;; examples of that. 551 (and (compute-applicable-methods-emf-std-p gf) 552 (eq (generic-function-method-combination gf) 553 *standard-method-combination*))) 554 ;; Check that no method is eql-specialized, and that all 555 ;; methods return a constant value. If BOOLEAN-VALUES-P, 556 ;; check that all return T or NIL. Also, check that no 557 ;; method has qualifiers, to make sure that emfs are really 558 ;; method functions; see above. 559 (dolist (method methods t) 560 (when (eq **boot-state** 'complete) 561 (when (or (some #'eql-specializer-p 562 (safe-method-specializers method)) 563 (safe-method-qualifiers method)) 564 (return nil))) 565 (let ((value (method-plist-value method :constant-value default))) 566 (when (or (eq value default) 567 (and boolean-values-p 568 (not (member value '(t nil))))) 569 (return nil)))))))) 570 571(defun make-constant-value-dfun (generic-function &optional cache) 572 (multiple-value-bind (nreq applyp metatypes nkeys) 573 (get-generic-fun-info generic-function) 574 (declare (ignore nreq applyp)) 575 (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) 576 (dfun-info (constant-value-dfun-info cache))) 577 (declare (type cache cache)) 578 (values 579 (funcall (get-dfun-constructor 'emit-constant-value metatypes) 580 cache 581 (lambda (&rest args) 582 (constant-value-miss generic-function args dfun-info))) 583 cache 584 dfun-info)))) 585 586(defun make-final-constant-value-dfun (generic-function classes-list new-class) 587 (let ((cache (make-final-ordinary-dfun-cache 588 generic-function :constant-value classes-list new-class))) 589 (make-constant-value-dfun generic-function cache))) 590 591(defun gf-has-method-with-nonstandard-specializer-p (gf) 592 (let ((methods (generic-function-methods gf))) 593 (dolist (method methods nil) 594 (unless (every (lambda (s) (standard-specializer-p s)) 595 (method-specializers method)) 596 (return t))))) 597 598(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) 599 (when (eq **boot-state** 'complete) 600 (unless (or caching-p 601 (gf-requires-emf-keyword-checks gf) 602 ;; DISPATCH-DFUN-COST will error if it encounters a 603 ;; method with a non-standard specializer. 604 (gf-has-method-with-nonstandard-specializer-p gf)) 605 ;; This should return T when almost all dispatching is by 606 ;; eql specializers or built-in classes. In other words, 607 ;; return NIL if we might ever need to do more than 608 ;; one (non built-in) typep. 609 ;; Otherwise, it is probably at least as fast to use 610 ;; a caching dfun first, possibly followed by secondary dispatching. 611 612 #||;;; Original found in cmu 17f -- S L O W 613 (< (dispatch-dfun-cost gf) (caching-dfun-cost gf)) 614 ||# 615 ;; This uses improved dispatch-dfun-cost below 616 (let ((cdc (caching-dfun-cost gf))) ; fast 617 (> cdc (dispatch-dfun-cost gf cdc)))))) 618 619(defparameter *non-system-typep-cost* 100) 620(defparameter *structure-typep-cost* 15) 621(defparameter *system-typep-cost* 5) 622 623;;; According to comments in the original CMU CL version of PCL, 624;;; the cost LIMIT is important to cut off exponential growth for 625;;; large numbers of gf methods and argument lists. 626(defun dispatch-dfun-cost (gf &optional limit) 627 (generate-discrimination-net-internal 628 gf (generic-function-methods gf) nil 629 (lambda (methods known-types) 630 (declare (ignore methods known-types)) 631 0) 632 (lambda (position type true-value false-value) 633 (declare (ignore position)) 634 (let* ((type-test-cost 635 (if (eq 'class (car type)) 636 (let* ((metaclass (class-of (cadr type))) 637 (mcpl (class-precedence-list metaclass))) 638 (cond ((memq *the-class-system-class* mcpl) 639 *system-typep-cost*) 640 ((memq *the-class-structure-class* mcpl) 641 *structure-typep-cost*) 642 (t *non-system-typep-cost*))) 643 0)) 644 (max-cost-so-far 645 (+ (max true-value false-value) type-test-cost))) 646 (when (and limit (<= limit max-cost-so-far)) 647 (return-from dispatch-dfun-cost max-cost-so-far)) 648 max-cost-so-far)) 649 #'identity)) 650 651(defparameter *cache-lookup-cost* 30) 652(defparameter *wrapper-of-cost* 15) 653(defparameter *secondary-dfun-call-cost* 30) 654 655(defun caching-dfun-cost (gf) 656 (let ((nreq (get-generic-fun-info gf))) 657 (+ *cache-lookup-cost* 658 (* *wrapper-of-cost* nreq) 659 (if (methods-contain-eql-specializer-p 660 (generic-function-methods gf)) 661 *secondary-dfun-call-cost* 662 0)))) 663 664(declaim (inline make-callable)) 665(defun make-callable (gf methods generator method-alist wrappers) 666 (declare (ignore gf)) 667 (let* ((*applicable-methods* methods) 668 (callable (function-funcall generator method-alist wrappers))) 669 callable)) 670 671(defun make-dispatch-dfun (gf) 672 (values (get-dispatch-function gf) nil (dispatch-dfun-info))) 673 674(defun get-dispatch-function (gf) 675 (let* ((methods (generic-function-methods gf)) 676 (generator (get-secondary-dispatch-function1 677 gf methods nil nil nil nil nil t))) 678 (make-callable gf methods generator nil nil))) 679 680(defun make-final-dispatch-dfun (gf) 681 (make-dispatch-dfun gf)) 682 683(defun update-dispatch-dfuns () 684 (dolist (gf (gfs-of-type '(dispatch))) 685 (dfun-update gf #'make-dispatch-dfun))) 686 687(defun make-final-ordinary-dfun-cache 688 (generic-function valuep classes-list new-class) 689 (let* ((arg-info (gf-arg-info generic-function)) 690 (nkeys (arg-info-nkeys arg-info)) 691 (new-class (and new-class 692 (equal (type-of (gf-dfun-info generic-function)) 693 (cond ((eq valuep t) 'caching) 694 ((eq valuep :constant-value) 'constant-value) 695 ((null valuep) 'checking))) 696 new-class)) 697 (cache (if new-class 698 (copy-cache (gf-dfun-cache generic-function)) 699 (make-cache :key-count nkeys :value (not (null valuep)) 700 :size 4)))) 701 (make-emf-cache generic-function valuep cache classes-list new-class))) 702 703(defvar *dfun-miss-gfs-on-stack* ()) 704 705(defmacro dfun-miss ((gf args wrappers invalidp nemf 706 &optional type index caching-p applicable) 707 &body body) 708 (unless applicable (setq applicable (gensym))) 709 `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp 710 ,@(when type `(,type ,index))) 711 (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) 712 (type 'accessor) 713 (t 'checking))) 714 (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) 715 (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) 716 ,@body)) 717 ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached 718 ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is, 719 ;; does not signal a SLOT-UNBOUND error for a boundp test. 720 ,@(if type 721 ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated 722 ;; slots?) 723 `((if (and (eq ,type 'boundp) (integerp ,nemf)) 724 (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) 725 (invoke-emf ,nemf ,args))) 726 `((invoke-emf ,nemf ,args))))) 727 728;;; The dynamically adaptive method lookup algorithm is implemented is 729;;; implemented as a kind of state machine. The kinds of 730;;; discriminating function is the state, the various kinds of reasons 731;;; for a cache miss are the state transitions. 732;;; 733;;; The code which implements the transitions is all in the miss 734;;; handlers for each kind of dfun. Those appear here. 735;;; 736;;; Note that within the states that cache, there are dfun updates 737;;; which simply select a new cache or cache field. Those are not 738;;; considered as state transitions. 739(defvar *lazy-dfun-compute-p* t) 740(defvar *early-p* nil) 741 742(defun make-initial-dfun (gf) 743 (let ((initial-dfun #'(lambda (&rest args) (initial-dfun gf args)))) 744 (multiple-value-bind (dfun cache info) 745 (if (eq **boot-state** 'complete) 746 (values initial-dfun nil (initial-dfun-info)) 747 (let ((arg-info (if (early-gf-p gf) 748 (early-gf-arg-info gf) 749 (gf-arg-info gf))) 750 (type nil)) 751 (if (and (gf-precompute-dfun-and-emf-p arg-info) 752 (setq type (final-accessor-dfun-type gf))) 753 (if *early-p* 754 (values (make-early-accessor gf type) nil nil) 755 (make-final-accessor-dfun gf type)) 756 (values initial-dfun nil (initial-dfun-info))))) 757 (set-dfun gf dfun cache info)))) 758 759(defun make-early-accessor (gf type) 760 (let* ((methods (early-gf-methods gf)) 761 (slot-name (early-method-standard-accessor-slot-name (car methods)))) 762 (ecase type 763 (reader #'(lambda (instance) 764 (let* ((class (class-of instance)) 765 (class-name (!bootstrap-get-slot 'class class 'name))) 766 (!bootstrap-get-slot class-name instance slot-name)))) 767 (boundp #'(lambda (instance) 768 (let* ((class (class-of instance)) 769 (class-name (!bootstrap-get-slot 'class class 'name))) 770 (not (eq +slot-unbound+ 771 (!bootstrap-get-slot class-name 772 instance slot-name)))))) 773 (writer #'(lambda (new-value instance) 774 (let* ((class (class-of instance)) 775 (class-name (!bootstrap-get-slot 'class class 'name))) 776 (!bootstrap-set-slot class-name instance slot-name new-value))))))) 777 778(defun initial-dfun (gf args) 779 (dfun-miss (gf args wrappers invalidp nemf ntype nindex) 780 (cond (invalidp) 781 ((and ntype nindex) 782 (dfun-update 783 gf #'make-one-class-accessor-dfun ntype wrappers nindex)) 784 ((use-caching-dfun-p gf) 785 (dfun-update gf #'make-caching-dfun)) 786 (t 787 (dfun-update gf #'make-checking-dfun 788 ;; nemf is suitable only for caching, have to do this: 789 (cache-miss-values gf args 'checking)))))) 790 791(defun make-final-dfun (gf &optional classes-list) 792 (multiple-value-bind (dfun cache info) 793 (make-final-dfun-internal gf classes-list) 794 (set-dfun gf dfun cache info))) 795 796;;; FIXME: What is this? 797(defvar *new-class* nil) 798 799(defun final-accessor-dfun-type (gf) 800 (let ((methods (if (early-gf-p gf) 801 (early-gf-methods gf) 802 (generic-function-methods gf)))) 803 (cond ((every (lambda (method) 804 (if (consp method) 805 (let ((class (early-method-class method))) 806 (or (eq class *the-class-standard-reader-method*) 807 (eq class *the-class-global-reader-method*))) 808 (or (standard-reader-method-p method) 809 (global-reader-method-p method)))) 810 methods) 811 'reader) 812 ((every (lambda (method) 813 (if (consp method) 814 (let ((class (early-method-class method))) 815 (or (eq class *the-class-standard-boundp-method*) 816 (eq class *the-class-global-boundp-method*))) 817 (or (standard-boundp-method-p method) 818 (global-boundp-method-p method)))) 819 methods) 820 'boundp) 821 ((every (lambda (method) 822 (if (consp method) 823 (let ((class (early-method-class method))) 824 (or (eq class *the-class-standard-writer-method*) 825 (eq class *the-class-global-writer-method*))) 826 (and 827 (or (standard-writer-method-p method) 828 (global-writer-method-p method)) 829 (not (safe-p 830 (slot-definition-class 831 (accessor-method-slot-definition method))))))) 832 methods) 833 'writer)))) 834 835(defun make-final-accessor-dfun (gf type &optional classes-list new-class) 836 (let ((table (make-hash-table :test #'eq))) 837 (multiple-value-bind (table all-index first second size no-class-slots-p) 838 (make-accessor-table gf type table) 839 (if table 840 (cond ((= size 1) 841 (let ((w (class-wrapper first))) 842 (make-one-class-accessor-dfun gf type w all-index))) 843 ((and (= size 2) (or (integerp all-index) (consp all-index))) 844 (let ((w0 (class-wrapper first)) 845 (w1 (class-wrapper second))) 846 (make-two-class-accessor-dfun gf type w0 w1 all-index))) 847 ((or (integerp all-index) (consp all-index)) 848 (let ((cache (hash-table-to-cache table :value nil :key-count 1))) 849 (make-one-index-accessor-dfun gf type all-index cache))) 850 (no-class-slots-p 851 (let ((cache (hash-table-to-cache table :value t :key-count 1))) 852 (make-n-n-accessor-dfun gf type cache))) 853 (t 854 (make-final-caching-dfun gf classes-list new-class))) 855 (make-final-caching-dfun gf classes-list new-class))))) 856 857(defun make-final-dfun-internal (gf &optional classes-list) 858 (let ((methods (generic-function-methods gf)) type 859 (new-class *new-class*) (*new-class* nil) 860 specls all-same-p) 861 (cond ((null methods) 862 (values 863 #'(lambda (&rest args) 864 (call-no-applicable-method gf args)) 865 nil 866 (no-methods-dfun-info))) 867 ((setq type (final-accessor-dfun-type gf)) 868 (make-final-accessor-dfun gf type classes-list new-class)) 869 ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) 870 (setq specls 871 (method-specializers (car methods)))) 872 (setq all-same-p 873 (every (lambda (method) 874 (and (equal specls 875 (method-specializers 876 method)))) 877 methods)))) 878 (use-constant-value-dfun-p gf)) 879 (make-final-constant-value-dfun gf classes-list new-class)) 880 ((use-dispatch-dfun-p gf) 881 (make-final-dispatch-dfun gf)) 882 ((and all-same-p (not (use-caching-dfun-p gf))) 883 (let ((emf (get-secondary-dispatch-function gf methods nil))) 884 (make-final-checking-dfun gf emf classes-list new-class))) 885 (t 886 (make-final-caching-dfun gf classes-list new-class))))) 887 888(defvar *pcl-misc-random-state* (make-random-state)) 889 890(defun accessor-miss (gf new object dfun-info) 891 (let* ((ostate (type-of dfun-info)) 892 (otype (dfun-info-accessor-type dfun-info)) 893 oindex ow0 ow1 cache 894 (args (ecase otype 895 ((reader boundp) (list object)) 896 (writer (list new object))))) 897 (dfun-miss (gf args wrappers invalidp nemf ntype nindex) 898 ;; The following lexical functions change the state of the 899 ;; dfun to that which is their name. They accept arguments 900 ;; which are the parameters of the new state, and get other 901 ;; information from the lexical variables bound above. 902 (flet ((two-class (index w0 w1) 903 (when (zerop (random 2 *pcl-misc-random-state*)) 904 (psetf w0 w1 w1 w0)) 905 (dfun-update gf 906 #'make-two-class-accessor-dfun 907 ntype 908 w0 909 w1 910 index)) 911 (one-index (index &optional cache) 912 (dfun-update gf 913 #'make-one-index-accessor-dfun 914 ntype 915 index 916 cache)) 917 (n-n (&optional cache) 918 (if (consp nindex) 919 (dfun-update gf #'make-checking-dfun nemf) 920 (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) 921 (caching () ; because cached accessor emfs are much faster 922 ; for accessors 923 (dfun-update gf #'make-caching-dfun)) 924 (do-fill (update-fn) 925 (let ((ncache (fill-cache cache wrappers nindex))) 926 (unless (eq ncache cache) 927 (funcall update-fn ncache))))) 928 (cond ((null ntype) 929 (caching)) 930 ((or invalidp 931 (null nindex))) 932 ((not (pcl-instance-p object)) 933 (caching)) 934 ((or (neq ntype otype) (listp wrappers)) 935 (caching)) 936 (t 937 (ecase ostate 938 (one-class 939 (setq oindex (dfun-info-index dfun-info)) 940 (setq ow0 (dfun-info-wrapper0 dfun-info)) 941 (unless (eq ow0 wrappers) 942 (if (eql nindex oindex) 943 (two-class nindex ow0 wrappers) 944 (n-n)))) 945 (two-class 946 (setq oindex (dfun-info-index dfun-info)) 947 (setq ow0 (dfun-info-wrapper0 dfun-info)) 948 (setq ow1 (dfun-info-wrapper1 dfun-info)) 949 (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) 950 (if (eql nindex oindex) 951 (one-index nindex) 952 (n-n)))) 953 (one-index 954 (setq oindex (dfun-info-index dfun-info)) 955 (setq cache (dfun-info-cache dfun-info)) 956 (if (eql nindex oindex) 957 (do-fill (lambda (ncache) 958 (one-index nindex ncache))) 959 (n-n))) 960 (n-n 961 (setq cache (dfun-info-cache dfun-info)) 962 (if (consp nindex) 963 (caching) 964 (do-fill #'n-n)))))))))) 965 966(defun checking-miss (generic-function args dfun-info) 967 (let ((oemf (dfun-info-function dfun-info)) 968 (cache (dfun-info-cache dfun-info))) 969 (dfun-miss (generic-function args wrappers invalidp nemf) 970 (cond (invalidp) 971 ((eq oemf nemf) 972 ;; The cache of a checking dfun doesn't hold any values, 973 ;; so this NIL appears to be just a dummy-value we use in 974 ;; order to insert the wrappers into the cache. 975 (let ((ncache (fill-cache cache wrappers nil))) 976 (unless (eq ncache cache) 977 (dfun-update generic-function #'make-checking-dfun 978 nemf ncache)))) 979 (t 980 (dfun-update generic-function #'make-caching-dfun)))))) 981 982(defun caching-miss (generic-function args dfun-info) 983 (let ((ocache (dfun-info-cache dfun-info))) 984 (dfun-miss (generic-function args wrappers invalidp emf nil nil t) 985 (cond (invalidp) 986 (t 987 (let ((ncache (fill-cache ocache wrappers emf))) 988 (unless (eq ncache ocache) 989 (dfun-update generic-function 990 #'make-caching-dfun ncache)))))))) 991 992(defun constant-value-miss (generic-function args dfun-info) 993 (let ((ocache (dfun-info-cache dfun-info))) 994 (dfun-miss (generic-function args wrappers invalidp emf nil nil t) 995 (unless invalidp 996 (let* ((value 997 (typecase emf 998 (constant-fast-method-call 999 (constant-fast-method-call-value emf)) 1000 (constant-method-call 1001 (constant-method-call-value emf)) 1002 (t 1003 (bug "~S with non-constant EMF ~S" 'constant-value-miss emf)))) 1004 (ncache (fill-cache ocache wrappers value))) 1005 (unless (eq ncache ocache) 1006 (dfun-update generic-function 1007 #'make-constant-value-dfun ncache))))))) 1008 1009;;; Given a generic function and a set of arguments to that generic 1010;;; function, return a mess of values. 1011;;; 1012;;; <function> The compiled effective method function for this set of 1013;;; arguments. 1014;;; 1015;;; <applicable> Sorted list of applicable methods. 1016;;; 1017;;; <wrappers> Is a single wrapper if the generic function has only 1018;;; one key, that is arg-info-nkeys of the arg-info is 1. 1019;;; Otherwise a list of the wrappers of the specialized 1020;;; arguments to the generic function. 1021;;; 1022;;; Note that all these wrappers are valid. This function 1023;;; does invalid wrapper traps when it finds an invalid 1024;;; wrapper and then returns the new, valid wrapper. 1025;;; 1026;;; <invalidp> True if any of the specialized arguments had an invalid 1027;;; wrapper, false otherwise. 1028;;; 1029;;; <type> READER or WRITER when the only method that would be run 1030;;; is a standard reader or writer method. To be specific, 1031;;; the value is READER when the method combination is eq to 1032;;; *standard-method-combination*; there are no applicable 1033;;; :before, :after or :around methods; and the most specific 1034;;; primary method is a standard reader method. 1035;;; 1036;;; <index> If <type> is READER or WRITER, and the slot accessed is 1037;;; an :instance slot, this is the index number of that slot 1038;;; in the object argument. 1039(defvar *cache-miss-values-stack* ()) 1040 1041(defun cache-miss-values (gf args state) 1042 (multiple-value-bind (nreq applyp metatypes nkeys arg-info) 1043 (get-generic-fun-info gf) 1044 (declare (ignore nreq applyp nkeys)) 1045 (with-dfun-wrappers (args metatypes) 1046 (dfun-wrappers invalid-wrapper-p wrappers classes types) 1047 (error-need-at-least-n-args gf (length metatypes)) 1048 (multiple-value-bind (emf methods accessor-type index) 1049 (cache-miss-values-internal 1050 gf arg-info wrappers classes types state) 1051 (values emf methods 1052 dfun-wrappers 1053 invalid-wrapper-p 1054 accessor-type index))))) 1055 1056(defun cache-miss-values-internal (gf arg-info wrappers classes types state) 1057 (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*)))) 1058 (break-vicious-metacircle gf classes arg-info) 1059 (let ((*cache-miss-values-stack* 1060 (acons gf classes *cache-miss-values-stack*)) 1061 (cam-std-p (or (null arg-info) 1062 (gf-info-c-a-m-emf-std-p arg-info)))) 1063 (multiple-value-bind (methods all-applicable-and-sorted-p) 1064 (if cam-std-p 1065 (compute-applicable-methods-using-types gf types) 1066 (compute-applicable-methods-using-classes gf classes)) 1067 1068 (let* ((for-accessor-p (eq state 'accessor)) 1069 (for-cache-p (or (eq state 'caching) (eq state 'accessor))) 1070 (emf (if (or cam-std-p all-applicable-and-sorted-p) 1071 (let ((generator 1072 (get-secondary-dispatch-function1 1073 gf methods types nil (and for-cache-p wrappers) 1074 all-applicable-and-sorted-p))) 1075 (make-callable gf methods generator 1076 nil (and for-cache-p wrappers))) 1077 (default-secondary-dispatch-function gf)))) 1078 (multiple-value-bind (index accessor-type) 1079 (and for-accessor-p all-applicable-and-sorted-p methods 1080 (accessor-values gf arg-info classes methods)) 1081 (values (if (integerp index) index emf) 1082 methods accessor-type index))))))) 1083 1084;;; Try to break a vicious circle while computing a cache miss. 1085;;; GF is the generic function, CLASSES are the classes of actual 1086;;; arguments, and ARG-INFO is the generic functions' arg-info. 1087;;; 1088;;; A vicious circle can be entered when the computation of the cache 1089;;; miss values itself depends on the values being computed. For 1090;;; instance, adding a method which is an instance of a subclass of 1091;;; STANDARD-METHOD leads to cache misses for slot accessors of 1092;;; STANDARD-METHOD like METHOD-SPECIALIZERS, and METHOD-SPECIALIZERS 1093;;; is itself used while we compute cache miss values. 1094(defun break-vicious-metacircle (gf classes arg-info) 1095 (when (typep gf 'standard-generic-function) 1096 (multiple-value-bind (class slotd accessor-type) 1097 (accesses-standard-class-slot-p gf) 1098 (when class 1099 (let ((method (find-standard-class-accessor-method 1100 gf class accessor-type)) 1101 (index (standard-slot-value/eslotd slotd 'location)) 1102 (type (gf-info-simple-accessor-type arg-info))) 1103 (when (and method 1104 (subtypep (ecase accessor-type 1105 ((reader) (car classes)) 1106 ((writer) (cadr classes))) 1107 class)) 1108 (return-from break-vicious-metacircle 1109 (values index (list method) type index))))))) 1110 (error "~@<vicious metacircle: The computation of an ~ 1111 effective method of ~s for arguments of types ~s uses ~ 1112 the effective method being computed.~@:>" 1113 gf classes)) 1114 1115;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic 1116;;; function GF accesses a slot of some class in *STANDARD-CLASSES*. 1117;;; CLASS is the class accessed, SLOTD is the effective slot definition 1118;;; object of the slot accessed, and ACCESSOR-TYPE is one of the symbols 1119;;; READER or WRITER describing the slot access. 1120(defun accesses-standard-class-slot-p (gf) 1121 (labels 1122 ((all-dslotds (class &aux done) 1123 (labels ((all-dslotds-aux (class) 1124 (if (or (member class done) (not (eq (class-of class) *the-class-standard-class*))) 1125 nil 1126 (progn 1127 (push class done) 1128 (append (standard-slot-value/class class 'direct-slots) 1129 (mapcan #'(lambda (c) 1130 (copy-list (all-dslotds-aux c))) 1131 (standard-slot-value/class class 'direct-superclasses))))))) 1132 (all-dslotds-aux class))) 1133 (standard-class-slot-access (gf class) 1134 1135 (loop with gf-name = (standard-slot-value/gf gf 'name) 1136 with eslotds = (standard-slot-value/class class 'slots) 1137 with dslotds = (all-dslotds class) 1138 for dslotd in dslotds 1139 as readers = (standard-slot-value/dslotd dslotd 'readers) 1140 as writers = (standard-slot-value/dslotd dslotd 'writers) 1141 as name = (standard-slot-value/dslotd dslotd 'name) 1142 as eslotd = (find name eslotds :key (lambda (x) (standard-slot-value/eslotd x 'name))) 1143 if (member gf-name readers :test #'equal) 1144 return (values eslotd 'reader) 1145 else if (member gf-name writers :test #'equal) 1146 return (values eslotd 'writer)))) 1147 (dolist (class-name *standard-classes*) 1148 (let ((class (find-class class-name))) 1149 (multiple-value-bind (slotd accessor-type) 1150 (standard-class-slot-access gf class) 1151 (when slotd 1152 (return (values class slotd accessor-type)))))))) 1153 1154;;; Find a slot reader/writer method among the methods of generic 1155;;; function GF which reads/writes instances of class CLASS. 1156;;; TYPE is one of the symbols READER or WRITER. 1157(defun find-standard-class-accessor-method (gf class type) 1158 (let ((cpl (standard-slot-value/class class '%class-precedence-list)) 1159 (found-specializer *the-class-t*) 1160 (found-method nil)) 1161 (dolist (method (standard-slot-value/gf gf 'methods) found-method) 1162 (let ((specializers (standard-slot-value/method method 'specializers)) 1163 (qualifiers (standard-slot-value/method method 'qualifiers))) 1164 (when (and (null qualifiers) 1165 (let ((subcpl (member (ecase type 1166 (reader (car specializers)) 1167 (writer (cadr specializers))) 1168 cpl :test #'eq))) 1169 (and subcpl (member found-specializer subcpl :test #'eq)))) 1170 (setf found-specializer (ecase type 1171 (reader (car specializers)) 1172 (writer (cadr specializers)))) 1173 (setf found-method method)))))) 1174 1175(defun accessor-values (gf arg-info classes methods) 1176 (declare (ignore gf)) 1177 (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) 1178 (accessor-class (case accessor-type 1179 ((reader boundp) (car classes)) 1180 (writer (cadr classes))))) 1181 (accessor-values-internal accessor-type accessor-class methods))) 1182 1183(defun accessor-values1 (gf accessor-type accessor-class) 1184 (let* ((type `(class-eq ,accessor-class)) 1185 (types (ecase accessor-type 1186 ((reader boundp) `(,type)) 1187 (writer `(t ,type)))) 1188 (methods (compute-applicable-methods-using-types gf types))) 1189 (accessor-values-internal accessor-type accessor-class methods))) 1190 1191(defun accessor-values-internal (accessor-type accessor-class methods) 1192 (unless accessor-class 1193 (return-from accessor-values-internal (values nil nil))) 1194 (dolist (meth methods) 1195 (when (if (consp meth) 1196 (early-method-qualifiers meth) 1197 (safe-method-qualifiers meth)) 1198 (return-from accessor-values-internal (values nil nil)))) 1199 (let* ((meth (car methods)) 1200 (early-p (not (eq **boot-state** 'complete))) 1201 (slot-name 1202 (cond 1203 ((and (consp meth) 1204 (early-method-standard-accessor-p meth)) 1205 (early-method-standard-accessor-slot-name meth)) 1206 ((and (accessor-method-p meth) 1207 (member *the-class-standard-object* 1208 (if early-p 1209 (early-class-precedence-list accessor-class) 1210 (class-precedence-list accessor-class)))) 1211 (accessor-method-slot-name meth)) 1212 (t (return-from accessor-values-internal (values nil nil))))) 1213 (slotd (if early-p 1214 (dolist (slot (early-class-slotds accessor-class) nil) 1215 (when (eql slot-name (early-slot-definition-name slot)) 1216 (return slot))) 1217 (find-slot-definition accessor-class slot-name)))) 1218 (when (and slotd 1219 (or early-p (slot-accessor-std-p slotd accessor-type)) 1220 (or early-p (not (safe-p accessor-class)))) 1221 (values (if early-p 1222 (early-slot-definition-location slotd) 1223 (slot-definition-location slotd)) 1224 accessor-type)))) 1225 1226(defun make-accessor-table (gf type &optional table) 1227 (unless table (setq table (make-hash-table :test 'eq))) 1228 (let ((methods (if (early-gf-p gf) 1229 (early-gf-methods gf) 1230 (generic-function-methods gf))) 1231 (all-index nil) 1232 (no-class-slots-p t) 1233 (early-p (not (eq **boot-state** 'complete))) 1234 first second (size 0)) 1235 (declare (fixnum size)) 1236 ;; class -> {(specl slotd)} 1237 (dolist (method methods) 1238 (let* ((specializers (if (consp method) 1239 (early-method-specializers method t) 1240 (method-specializers method))) 1241 (specl (ecase type 1242 ((reader boundp) (car specializers)) 1243 (writer (cadr specializers)))) 1244 (specl-cpl (if early-p 1245 (early-class-precedence-list specl) 1246 (when (class-finalized-p specl) 1247 (class-precedence-list specl)))) 1248 (so-p (member *the-class-standard-object* specl-cpl :test #'eq)) 1249 (slot-name (if (consp method) 1250 (and (early-method-standard-accessor-p method) 1251 (early-method-standard-accessor-slot-name 1252 method)) 1253 (accessor-method-slot-name method)))) 1254 (when (or (null specl-cpl) 1255 (null so-p) 1256 (member *the-class-structure-object* specl-cpl :test #'eq)) 1257 (return-from make-accessor-table nil)) 1258 ;; Collect all the slot-definitions for SLOT-NAME from SPECL and 1259 ;; all of its subclasses. If either SPECL or one of the subclasses 1260 ;; is not a standard-class, bail out. 1261 (labels ((aux (class) 1262 (let ((slotd (find-slot-definition class slot-name))) 1263 (when slotd 1264 (unless (or early-p (slot-accessor-std-p slotd type)) 1265 (return-from make-accessor-table nil)) 1266 (push (cons specl slotd) (gethash class table)))) 1267 (dolist (subclass (sb-pcl::class-direct-subclasses class)) 1268 (unless (class-finalized-p subclass) 1269 (return-from make-accessor-table nil)) 1270 (aux subclass)))) 1271 (aux specl)))) 1272 (maphash (lambda (class specl+slotd-list) 1273 (dolist (sclass (if early-p 1274 (early-class-precedence-list class) 1275 (class-precedence-list class)) 1276 (error "This can't happen.")) 1277 (let ((a (assq sclass specl+slotd-list))) 1278 (when a 1279 (let* ((slotd (cdr a)) 1280 (index (if early-p 1281 (early-slot-definition-location slotd) 1282 (slot-definition-location slotd)))) 1283 (unless index (return-from make-accessor-table nil)) 1284 (setf (gethash class table) index) 1285 (when (consp index) (setq no-class-slots-p nil)) 1286 (setq all-index (if (or (null all-index) 1287 (eql all-index index)) 1288 index t)) 1289 (incf size) 1290 (cond ((= size 1) (setq first class)) 1291 ((= size 2) (setq second class))) 1292 (return nil)))))) 1293 table) 1294 (values table all-index first second size no-class-slots-p))) 1295 1296(defun compute-applicable-methods-using-types (generic-function types) 1297 (let ((definite-p t) (possibly-applicable-methods nil)) 1298 (dolist (method (if (early-gf-p generic-function) 1299 (early-gf-methods generic-function) 1300 (safe-generic-function-methods generic-function))) 1301 (let ((specls (if (consp method) 1302 (early-method-specializers method t) 1303 (safe-method-specializers method))) 1304 (types types) 1305 (possibly-applicable-p t) (applicable-p t)) 1306 (dolist (specl specls) 1307 (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) 1308 (specializer-applicable-using-type-p specl (pop types)) 1309 (unless specl-applicable-p 1310 (setq applicable-p nil)) 1311 (unless specl-possibly-applicable-p 1312 (setq possibly-applicable-p nil) 1313 (return nil)))) 1314 (when possibly-applicable-p 1315 (unless applicable-p (setq definite-p nil)) 1316 (push method possibly-applicable-methods)))) 1317 (multiple-value-bind (nreq applyp metatypes nkeys arg-info) 1318 (get-generic-fun-info generic-function) 1319 (declare (ignore nreq applyp metatypes nkeys)) 1320 (let* ((precedence (arg-info-precedence arg-info))) 1321 (values (sort-applicable-methods precedence 1322 (nreverse possibly-applicable-methods) 1323 types) 1324 definite-p))))) 1325 1326(defun sort-applicable-methods (precedence methods types) 1327 (sort-methods methods 1328 precedence 1329 (lambda (class1 class2 index) 1330 (let* ((class (type-class (nth index types))) 1331 (cpl (if (eq **boot-state** 'complete) 1332 (class-precedence-list class) 1333 (early-class-precedence-list class)))) 1334 (if (memq class2 (memq class1 cpl)) 1335 class1 class2))))) 1336 1337(defun sort-methods (methods precedence compare-classes-function) 1338 (flet ((sorter (method1 method2) 1339 (dolist (index precedence) 1340 (let* ((specl1 (nth index (if (listp method1) 1341 (early-method-specializers method1 1342 t) 1343 (method-specializers method1)))) 1344 (specl2 (nth index (if (listp method2) 1345 (early-method-specializers method2 1346 t) 1347 (method-specializers method2)))) 1348 (order (order-specializers 1349 specl1 specl2 index compare-classes-function))) 1350 (when order 1351 (return-from sorter (eq order specl1))))))) 1352 (stable-sort methods #'sorter))) 1353 1354(defun order-specializers (specl1 specl2 index compare-classes-function) 1355 (let ((type1 (if (eq **boot-state** 'complete) 1356 (specializer-type specl1) 1357 (!bootstrap-get-slot 'specializer specl1 '%type))) 1358 (type2 (if (eq **boot-state** 'complete) 1359 (specializer-type specl2) 1360 (!bootstrap-get-slot 'specializer specl2 '%type)))) 1361 (cond ((eq specl1 specl2) 1362 nil) 1363 ((atom type1) 1364 specl2) 1365 ((atom type2) 1366 specl1) 1367 (t 1368 (case (car type1) 1369 (class (case (car type2) 1370 (class (funcall compare-classes-function 1371 specl1 specl2 index)) 1372 (t specl2))) 1373 (prototype (case (car type2) 1374 (class (funcall compare-classes-function 1375 specl1 specl2 index)) 1376 (t specl2))) 1377 (class-eq (case (car type2) 1378 (eql specl2) 1379 ;; FIXME: This says that all CLASS-EQ 1380 ;; specializers are equally specific, which 1381 ;; is fair enough because only one CLASS-EQ 1382 ;; specializer can ever be appliable. If 1383 ;; ORDER-SPECIALIZERS should only ever be 1384 ;; called on specializers from applicable 1385 ;; methods, we could replace this with a BUG. 1386 (class-eq nil) 1387 (class type1))) 1388 (eql (case (car type2) 1389 ;; similarly. 1390 (eql nil) 1391 (t specl1)))))))) 1392 1393(defun map-all-orders (methods precedence function) 1394 (let ((choices nil)) 1395 (flet ((compare-classes-function (class1 class2 index) 1396 (declare (ignore index)) 1397 (let ((choice nil)) 1398 (dolist (c choices nil) 1399 (when (or (and (eq (first c) class1) 1400 (eq (second c) class2)) 1401 (and (eq (first c) class2) 1402 (eq (second c) class1))) 1403 (return (setq choice c)))) 1404 (unless choice 1405 (setq choice 1406 (if (class-might-precede-p class1 class2) 1407 (if (class-might-precede-p class2 class1) 1408 (list class1 class2 nil t) 1409 (list class1 class2 t)) 1410 (if (class-might-precede-p class2 class1) 1411 (list class2 class1 t) 1412 (let ((name1 (class-name class1)) 1413 (name2 (class-name class2))) 1414 (if (and name1 1415 name2 1416 (symbolp name1) 1417 (symbolp name2) 1418 (string< (symbol-name name1) 1419 (symbol-name name2))) 1420 (list class1 class2 t) 1421 (list class2 class1 t)))))) 1422 (push choice choices)) 1423 (car choice)))) 1424 (loop (funcall function 1425 (sort-methods methods 1426 precedence 1427 #'compare-classes-function)) 1428 (unless (dolist (c choices nil) 1429 (unless (third c) 1430 (rotatef (car c) (cadr c)) 1431 (return (setf (third c) t)))) 1432 (return nil)))))) 1433 1434;;; CMUCL comment: used only in map-all-orders 1435(defun class-might-precede-p (class1 class2) 1436 (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))) 1437 1438(defun compute-precedence (lambda-list nreq argument-precedence-order) 1439 (if (null argument-precedence-order) 1440 (let ((list nil)) 1441 (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list))) 1442 (mapcar (lambda (x) (position x lambda-list)) 1443 argument-precedence-order))) 1444 1445(defun cpl-or-nil (class) 1446 (if (eq **boot-state** 'complete) 1447 (progn 1448 ;; KLUDGE: why not use (slot-boundp class 1449 ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is 1450 ;; used within COMPUTE-APPLICABLE-METHODS, including for 1451 ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for 1452 ;; breaking such nasty cycles in effective method computation 1453 ;; only works for readers and writers, not boundps. It might 1454 ;; not be too hard to make it work for BOUNDP accessors, but in 1455 ;; the meantime we use an extra slot for exactly the result of 1456 ;; the SLOT-BOUNDP that we want. (We cannot use 1457 ;; CLASS-FINALIZED-P, because in the process of class 1458 ;; finalization we need to use the CPL which has been computed 1459 ;; to cache effective methods for slot accessors.) -- CSR, 1460 ;; 2004-09-19. 1461 1462 (when (cpl-available-p class) 1463 (return-from cpl-or-nil (class-precedence-list class))) 1464 1465 ;; if we can finalize an unfinalized class, then do so 1466 (when (and (not (class-finalized-p class)) 1467 (not (class-has-a-forward-referenced-superclass-p class)) 1468 (not (class-has-a-cpl-protocol-violation-p class))) 1469 (finalize-inheritance class) 1470 (class-precedence-list class))) 1471 1472 (early-class-precedence-list class))) 1473 1474(defun saut-and (specl type) 1475 (let ((applicable nil) 1476 (possibly-applicable t)) 1477 (dolist (type (cdr type)) 1478 (multiple-value-bind (appl poss-appl) 1479 (specializer-applicable-using-type-p specl type) 1480 (when appl (return (setq applicable t))) 1481 (unless poss-appl (return (setq possibly-applicable nil))))) 1482 (values applicable possibly-applicable))) 1483 1484(defun saut-not (specl type) 1485 (let ((ntype (cadr type))) 1486 (values nil 1487 (case (car ntype) 1488 (class (saut-not-class specl ntype)) 1489 (class-eq (saut-not-class-eq specl ntype)) 1490 (prototype (saut-not-prototype specl ntype)) 1491 (eql (saut-not-eql specl ntype)) 1492 (t (error "~S cannot handle the second argument ~S" 1493 'specializer-applicable-using-type-p type)))))) 1494 1495(defun saut-not-class (specl ntype) 1496 (let* ((class (type-class specl)) 1497 (cpl (cpl-or-nil class))) 1498 (not (memq (cadr ntype) cpl)))) 1499 1500(defun saut-not-prototype (specl ntype) 1501 (let* ((class (case (car specl) 1502 (eql (class-of (cadr specl))) 1503 (class-eq (cadr specl)) 1504 (prototype (cadr specl)) 1505 (class (cadr specl)))) 1506 (cpl (cpl-or-nil class))) 1507 (not (memq (cadr ntype) cpl)))) 1508 1509(defun saut-not-class-eq (specl ntype) 1510 (let ((class (case (car specl) 1511 (eql (class-of (cadr specl))) 1512 (class-eq (cadr specl))))) 1513 (not (eq class (cadr ntype))))) 1514 1515(defun saut-not-eql (specl ntype) 1516 (case (car specl) 1517 (eql (not (eql (cadr specl) (cadr ntype)))) 1518 (t t))) 1519 1520(defun class-applicable-using-class-p (specl type) 1521 (let ((pred (memq specl (cpl-or-nil type)))) 1522 (values pred 1523 (or pred 1524 (if (not *in-*subtypep*) 1525 ;; classes might get common subclass 1526 (superclasses-compatible-p specl type) 1527 ;; worry only about existing classes 1528 (classes-have-common-subclass-p specl type)))))) 1529 1530(defun classes-have-common-subclass-p (class1 class2) 1531 (or (eq class1 class2) 1532 (let ((class1-subs (class-direct-subclasses class1))) 1533 (or (memq class2 class1-subs) 1534 (dolist (class1-sub class1-subs nil) 1535 (when (classes-have-common-subclass-p class1-sub class2) 1536 (return t))))))) 1537 1538(defun saut-class (specl type) 1539 (case (car specl) 1540 (class (class-applicable-using-class-p (cadr specl) (cadr type))) 1541 (t (values nil (let ((class (type-class specl))) 1542 (memq (cadr type) 1543 (cpl-or-nil class))))))) 1544 1545(defun saut-class-eq (specl type) 1546 (if (eq (car specl) 'eql) 1547 (values nil (eq (class-of (cadr specl)) (cadr type))) 1548 (let ((pred (case (car specl) 1549 (class-eq 1550 (eq (cadr specl) (cadr type))) 1551 (class 1552 (or (eq (cadr specl) (cadr type)) 1553 (memq (cadr specl) (cpl-or-nil (cadr type)))))))) 1554 (values pred pred)))) 1555 1556(defun saut-prototype (specl type) 1557 (declare (ignore specl type)) 1558 (values nil nil)) ; XXX original PCL comment: fix this someday 1559 1560(defun saut-eql (specl type) 1561 (let ((pred (case (car specl) 1562 (eql (eql (cadr specl) (cadr type))) 1563 (class-eq (eq (cadr specl) (class-of (cadr type)))) 1564 (class (memq (cadr specl) 1565 (let ((class (class-of (cadr type)))) 1566 (cpl-or-nil class))))))) 1567 (values pred pred))) 1568 1569(defun specializer-applicable-using-type-p (specl type) 1570 (setq specl (type-from-specializer specl)) 1571 (when (eq specl t) 1572 (return-from specializer-applicable-using-type-p (values t t))) 1573 ;; This is used by C-A-M-U-T and GENERATE-DISCRIMINATION-NET-INTERNAL, 1574 ;; and has only what they need. 1575 (if (or (atom type) (eq (car type) t)) 1576 (values nil t) 1577 (case (car type) 1578 (and (saut-and specl type)) 1579 (not (saut-not specl type)) 1580 (class (saut-class specl type)) 1581 (prototype (saut-prototype specl type)) 1582 (class-eq (saut-class-eq specl type)) 1583 (eql (saut-eql specl type)) 1584 (t (error "~S cannot handle the second argument ~S." 1585 'specializer-applicable-using-type-p 1586 type))))) 1587 1588(defun map-all-classes (fun &optional (root t)) 1589 (let ((all-classes (make-hash-table :test 'eq)) 1590 (braid-p (or (eq **boot-state** 'braid) 1591 (eq **boot-state** 'complete)))) 1592 (labels ((do-class (class) 1593 (unless (gethash class all-classes) 1594 (setf (gethash class all-classes) t) 1595 (funcall fun class) 1596 (mapc #'do-class 1597 (if braid-p 1598 (class-direct-subclasses class) 1599 (early-class-direct-subclasses class)))))) 1600 (do-class (if (symbolp root) 1601 (find-class root) 1602 root))) 1603 nil)) 1604 1605;;; Not synchronized, as all the uses we have for it are multiple ones 1606;;; and need WITH-LOCKED-SYSTEM-TABLE in any case. 1607;;; 1608;;; FIXME: Is it really more efficient to store this stuff in a global 1609;;; table instead of having a slot in each method? 1610;;; 1611;;; FIXME: This table also seems to contain early methods, which should 1612;;; presumably be dropped during the bootstrap. 1613(defvar *effective-method-cache* (make-hash-table :test 'eq)) 1614 1615(defun flush-effective-method-cache (generic-function) 1616 (let ((cache *effective-method-cache*)) 1617 (with-locked-system-table (cache) 1618 (dolist (method (generic-function-methods generic-function)) 1619 (remhash method cache))))) 1620 1621(defun get-secondary-dispatch-function (gf methods types 1622 &optional method-alist wrappers) 1623 (let ((generator 1624 (get-secondary-dispatch-function1 1625 gf methods types (not (null method-alist)) (not (null wrappers)) 1626 (not (methods-contain-eql-specializer-p methods))))) 1627 (make-callable gf methods generator method-alist wrappers))) 1628 1629(defun get-secondary-dispatch-function1 (gf methods types method-alist-p 1630 wrappers-p 1631 &optional 1632 all-applicable-p 1633 (all-sorted-p t) 1634 function-p) 1635 (if (null methods) 1636 (lambda (method-alist wrappers) 1637 (declare (ignore method-alist wrappers)) 1638 (lambda (&rest args) 1639 (call-no-applicable-method gf args))) 1640 (let* ((key (car methods)) 1641 (ht *effective-method-cache*) 1642 (ht-value (with-locked-system-table (ht) 1643 (or (gethash key ht) 1644 (setf (gethash key ht) (cons nil nil)))))) 1645 (if (and (null (cdr methods)) all-applicable-p ; the most common case 1646 (null method-alist-p) wrappers-p (not function-p)) 1647 (or (car ht-value) 1648 (setf (car ht-value) 1649 (get-secondary-dispatch-function2 1650 gf methods types method-alist-p wrappers-p 1651 all-applicable-p all-sorted-p function-p))) 1652 (let ((akey (list methods 1653 (if all-applicable-p 'all-applicable types) 1654 method-alist-p wrappers-p function-p))) 1655 (or (cdr (assoc akey (cdr ht-value) :test #'equal)) 1656 (let ((value (get-secondary-dispatch-function2 1657 gf methods types method-alist-p wrappers-p 1658 all-applicable-p all-sorted-p function-p))) 1659 (push (cons akey value) (cdr ht-value)) 1660 value))))))) 1661 1662(defun get-secondary-dispatch-function2 (gf methods types method-alist-p 1663 wrappers-p all-applicable-p 1664 all-sorted-p function-p) 1665 (cond 1666 ((not (and all-applicable-p all-sorted-p (not function-p))) 1667 (let ((net (generate-discrimination-net 1668 gf methods types all-sorted-p))) 1669 (compute-secondary-dispatch-function1 gf net function-p))) 1670 ((eq **boot-state** 'complete) 1671 (let* ((combin (generic-function-method-combination gf)) 1672 (effective (compute-effective-method gf combin methods))) 1673 (make-effective-method-function1 1674 gf effective method-alist-p wrappers-p))) 1675 ((eq (generic-function-name gf) 'make-specializer-form-using-class) 1676 ;; FIXME: instead of the above form, this should be 1677 ;; (eq (generic-function-method-combination gf) *or-method-combination*) 1678 ;; but that does not work for reasons I (JM) do not understand. 1679 (let* ((combin (generic-function-method-combination gf)) 1680 (effective (short-compute-effective-method gf combin methods))) 1681 (make-effective-method-function1 1682 gf effective method-alist-p wrappers-p))) 1683 (t 1684 (let ((effective (standard-compute-effective-method gf nil methods))) 1685 (make-effective-method-function1 1686 gf effective method-alist-p wrappers-p))))) 1687 1688(defun get-effective-method-function (gf methods 1689 &optional method-alist wrappers) 1690 (let ((generator 1691 (get-secondary-dispatch-function1 1692 gf methods nil (not (null method-alist)) (not (null wrappers)) t))) 1693 (make-callable gf methods generator method-alist wrappers))) 1694 1695(defun get-effective-method-function1 (gf methods &optional (sorted-p t)) 1696 (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) 1697 1698(defun methods-contain-eql-specializer-p (methods) 1699 (and (eq **boot-state** 'complete) 1700 (dolist (method methods nil) 1701 (when (dolist (spec (method-specializers method) nil) 1702 (when (eql-specializer-p spec) (return t))) 1703 (return t))))) 1704 1705(defun update-dfun (generic-function &optional dfun cache info) 1706 (let ((early-p (early-gf-p generic-function))) 1707 (flet ((update () 1708 ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can 1709 ;; access it, and so that it's there for eg. future cache updates. 1710 (set-dfun generic-function dfun cache info) 1711 (let ((dfun (if early-p 1712 (or dfun (make-initial-dfun generic-function)) 1713 (compute-discriminating-function generic-function)))) 1714 (set-funcallable-instance-function generic-function dfun) 1715 dfun))) 1716 ;; This needs to be atomic per generic function, consider: 1717 ;; 1. T1 sets dfun-state to S1 and computes discr. fun using S1 1718 ;; 2. T2 sets dfun-state to S2 and computes discr. fun using S2 1719 ;; 3. T2 sets fin 1720 ;; 4. T1 sets fin 1721 ;; Oops: now dfun-state and fin don't match! Since just calling 1722 ;; a generic can cause the dispatch function to be updated we 1723 ;; need a lock here. 1724 ;; 1725 ;; We need to accept recursion, because PCL is nasty and twisty, 1726 ;; and we need to disable interrupts because it would be bad if 1727 ;; we updated the DFUN-STATE but not the dispatch function. 1728 ;; 1729 ;; This is sufficient, because all the other calls to SET-DFUN 1730 ;; are part of this same code path (done while the lock is held), 1731 ;; which we AVER. 1732 ;; 1733 ;; KLUDGE: No need to lock during bootstrap. 1734 (if early-p 1735 (update) 1736 (let ((lock (gf-lock generic-function))) 1737 ;; FIXME: GF-LOCK is a generic function... Are there cases 1738 ;; where we can end up in a metacircular loop here? In 1739 ;; case there are, better fetch it while interrupts are 1740 ;; still enabled... 1741 (sb-thread::call-with-recursive-system-lock #'update lock)))))) 1742 1743(defvar *dfun-count* nil) 1744(defvar *dfun-list* nil) 1745(defvar *minimum-cache-size-to-list*) 1746 1747;;; These functions aren't used in SBCL, or documented anywhere that 1748;;; I'm aware of, but they look like they might be useful for 1749;;; debugging or performance tweaking or something, so I've just 1750;;; commented them out instead of deleting them. -- WHN 2001-03-28 1751#|| 1752(defun list-dfun (gf) 1753 (let* ((sym (type-of (gf-dfun-info gf))) 1754 (a (assq sym *dfun-list*))) 1755 (unless a 1756 (push (setq a (list sym)) *dfun-list*)) 1757 (push (generic-function-name gf) (cdr a)))) 1758 1759(defun list-all-dfuns () 1760 (setq *dfun-list* nil) 1761 (map-all-generic-functions #'list-dfun) 1762 *dfun-list*) 1763 1764(defun list-large-cache (gf) 1765 (let* ((sym (type-of (gf-dfun-info gf))) 1766 (cache (gf-dfun-cache gf))) 1767 (when cache 1768 (let ((size (cache-size cache))) 1769 (when (>= size *minimum-cache-size-to-list*) 1770 (let ((a (assoc size *dfun-list*))) 1771 (unless a 1772 (push (setq a (list size)) *dfun-list*)) 1773 (push (let ((name (generic-function-name gf))) 1774 (if (eq sym 'caching) name (list name sym))) 1775 (cdr a)))))))) 1776 1777(defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) 1778 (setq *dfun-list* nil) 1779 (map-all-generic-functions #'list-large-cache) 1780 (setq *dfun-list* (sort *dfun-list* #'< :key #'car)) 1781 (mapc #'print *dfun-list*) 1782 (values)) 1783 1784(defun count-dfun (gf) 1785 (let* ((sym (type-of (gf-dfun-info gf))) 1786 (cache (gf-dfun-cache gf)) 1787 (a (assq sym *dfun-count*))) 1788 (unless a 1789 (push (setq a (list sym 0 nil)) *dfun-count*)) 1790 (incf (cadr a)) 1791 (when cache 1792 (let* ((size (cache-size cache)) 1793 (b (assoc size (third a)))) 1794 (unless b 1795 (push (setq b (cons size 0)) (third a))) 1796 (incf (cdr b)))))) 1797 1798(defun count-all-dfuns () 1799 (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil)) 1800 '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY 1801 ONE-INDEX N-N CHECKING CACHING 1802 DISPATCH))) 1803 (map-all-generic-functions #'count-dfun) 1804 (mapc (lambda (type+count+sizes) 1805 (setf (third type+count+sizes) 1806 (sort (third type+count+sizes) #'< :key #'car))) 1807 *dfun-count*) 1808 (mapc (lambda (type+count+sizes) 1809 (format t "~&There are ~W dfuns of type ~S." 1810 (cadr type+count+sizes) (car type+count+sizes)) 1811 (format t "~% ~S~%" (caddr type+count+sizes))) 1812 *dfun-count*) 1813 (values)) 1814||# 1815 1816(defun gfs-of-type (type) 1817 (unless (consp type) (setq type (list type))) 1818 (let ((gf-list nil)) 1819 (map-all-generic-functions (lambda (gf) 1820 (when (memq (type-of (gf-dfun-info gf)) 1821 type) 1822 (push gf gf-list)))) 1823 gf-list)) 1824