(in-package "SB-PCL")
\f
+;;; Ye olde CMUCL comment follows, but it seems likely that the paper
+;;; that would be inserted would resemble Kiczales and Rodruigez,
+;;; Efficient Method Dispatch in PCL, ACM 1990. Some of the details
+;;; changed between that paper and "May Day PCL" of 1992; some other
+;;; details have changed since, but reading that paper gives the broad
+;;; idea.
+;;;
;;; The caching algorithm implemented:
;;;
;;; << put a paper here >>
(cond (owrap
(layout-classoid owrap))
((or (*subtypep (class-of class) *the-class-standard-class*)
+ (*subtypep (class-of class) *the-class-funcallable-standard-class*)
(typep class 'forward-referenced-class))
(cond ((and *pcl-class-boot*
(eq (slot-value class 'name) *pcl-class-boot*))
(aver (eq (classoid-pcl-class found) class))
found))
(t
- (make-standard-classoid :pcl-class class))))
+ (let ((name (slot-value class 'name)))
+ (make-standard-classoid :pcl-class class
+ :name (and (symbolp name) name))))))
(t
- (make-random-pcl-classoid :pcl-class class))))))
+ (bug "Got to T branch in ~S" 'make-wrapper))))))
(t
(let* ((found (find-classoid (slot-value class 'name)))
(layout (classoid-layout found)))
(logand mask result)
(the fixnum (1+ (logand mask result))))))
\f
-;;; NIL means nothing so far, no actual arg info has NILs
-;;; in the metatype
-;;; CLASS seen all sorts of metaclasses
-;;; (specifically, more than one of the next 4 values)
-;;; T means everything so far is the class T
-;;; STANDARD-CLASS seen only standard classes
-;;; BUILT-IN-CLASS seen only built in classes
-;;; STRUCTURE-CLASS seen only structure classes
+;;; NIL: means nothing so far, no actual arg info has NILs in the
+;;; metatype
+;;;
+;;; CLASS: seen all sorts of metaclasses (specifically, more than one
+;;; of the next 5 values) or else have seen something which doesn't
+;;; fall into a single category (SLOT-INSTANCE, FORWARD).
+;;;
+;;; T: means everything so far is the class T
+;;; STANDARD-INSTANCE: seen only standard classes
+;;; BUILT-IN-INSTANCE: seen only built in classes
+;;; STRUCTURE-INSTANCE: seen only structure classes
+;;; CONDITION-INSTANCE: seen only condition classes
(defun raise-metatype (metatype new-specializer)
(let ((slot (find-class 'slot-class))
(standard (find-class 'standard-class))
(fsc (find-class 'funcallable-standard-class))
(condition (find-class 'condition-class))
(structure (find-class 'structure-class))
- (built-in (find-class 'built-in-class)))
+ (built-in (find-class 'built-in-class))
+ (frc (find-class 'forward-referenced-class)))
(flet ((specializer->metatype (x)
(let ((meta-specializer
(if (eq *boot-state* 'complete)
((*subtypep meta-specializer structure) 'structure-instance)
((*subtypep meta-specializer built-in) 'built-in-instance)
((*subtypep meta-specializer slot) 'slot-instance)
+ ((*subtypep meta-specializer frc) 'forward)
(t (error "~@<PCL cannot handle the specializer ~S ~
(meta-specializer ~S).~@:>"
- new-specializer
- meta-specializer))))))
+ new-specializer meta-specializer))))))
;; We implement the following table. The notation is
;; that X and Y are distinct meta specializer names.
;;
- ;; NIL <anything> ===> <anything>
- ;; X X ===> X
- ;; X Y ===> CLASS
+ ;; NIL <anything> ===> <anything>
+ ;; X X ===> X
+ ;; X Y ===> CLASS
(let ((new-metatype (specializer->metatype new-specializer)))
(cond ((eq new-metatype 'slot-instance) 'class)
+ ((eq new-metatype 'forward) 'class)
((null metatype) new-metatype)
((eq metatype new-metatype) new-metatype)
(t 'class))))))
(defun fill-cache (cache wrappers value)
;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
- (assert wrappers)
+ (aver wrappers)
(or (fill-cache-p nil cache wrappers value)
(and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
(defun probe-cache (cache wrappers &optional default limit-fn)
;;(declare (values value))
- (unless wrappers
- ;; FIXME: This and another earlier test on a WRAPPERS arg can
- ;; be compact assertoids.
- (error "WRAPPERS arg is NIL!"))
+ (aver wrappers)
(with-local-cache-functions (cache)
(let* ((location (compute-primary-cache-location (field) (mask) wrappers))
(limit (funcall (or limit-fn (limit-fn)) (nlines))))
(let* ((location (compute-primary-cache-location (field) (mask) wrappers))
(primary (location-line location)))
(declare (fixnum location primary))
+ ;; FIXME: I tried (aver (> location 0)) and (aver (not
+ ;; (location-reserved-p location))) here, on the basis that
+ ;; particularly passing a LOCATION of 0 for a cache with more
+ ;; than one key would cause PRIMARY to be -1. However, the
+ ;; AVERs triggered during the bootstrap, and removing them
+ ;; didn't cause anything to break, so I've left them removed.
+ ;; I'm still confused as to what is right. -- CSR, 2006-04-20
(multiple-value-bind (free emptyp)
(find-free-cache-line primary cache wrappers)
(when (or forcep emptyp)
(do-one-fill wrappers value))
(maybe-check-cache ncache)))))
\f
+(defvar *pcl-misc-random-state* (make-random-state))
+
;;; This is the heart of the cache filling mechanism. It implements
;;; the decisions about where entries are placed.
;;;
(when (>= osep limit)
(return-from find-free-cache-line (values primary nil)))
(when (cond ((= nsep limit) t)
- ((= nsep osep) (zerop (random 2)))
+ ((= nsep osep)
+ (zerop (random 2 *pcl-misc-random-state*)))
((> nsep osep) t)
(t nil))
;; See whether we can displace what is in this line so that we
((8 16) 4)
(otherwise 6)))
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
projects / sbcl.git / blobdiff