(in-package "SB-PCL")
\f
-;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
-;;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
-;;; up using a thundering herd of explicit prefixes to get to
-;;; SB-KERNEL symbols. Using the SB-INT and SB-EXT packages as well
-;;; would help reduce prefixing and make it more natural to reuse
-;;; things (ONCE-ONLY, *KEYWORD-PACKAGE*..) used in the main body of
-;;; the system. However, that would cause a conflict between the
-;;; SB-ITERATE:ITERATE macro and the SB-INT:ITERATE macro. (This could
-;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or
-;;; with more gruntwork by punting the SB-ITERATE package and
-;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP.
-;;; So perhaps:
-;;; * Do some sort of automated check for overlap of symbols to make
-;;; sure there wouldn't be any other clashes.
-;;; * Rename SB-INT:ITERATE to SB-INT:NAMED-LET.
-;;; * Make SB-PCL use SB-INT and SB-EXT.
-;;; * Grep for SB-INT: and SB-EXT: prefixes in the pcl/ directory
-;;; and delete them.
-
;;; The caching algorithm implemented:
;;;
;;; << put a paper here >>
`(cache-vector-ref ,cache-vector 0))
(defun flush-cache-vector-internal (cache-vector)
- (without-interrupts
+ (sb-sys:without-interrupts
(fill (the simple-vector cache-vector) nil)
(setf (cache-vector-lock-count cache-vector) 0))
cache-vector)
(defmacro modify-cache (cache-vector &body body)
- `(without-interrupts
+ `(sb-sys:without-interrupts
(multiple-value-prog1
(progn ,@body)
(let ((old-count (cache-vector-lock-count ,cache-vector)))
;;; ever return a larger cache.
(defun get-cache-vector (size)
(let ((entry (gethash size *free-cache-vectors*)))
- (without-interrupts
+ (sb-sys:without-interrupts
(cond ((null entry)
(setf (gethash size *free-cache-vectors*) (cons 0 nil))
(get-cache-vector size))
(defun free-cache-vector (cache-vector)
(let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
- (without-interrupts
+ (sb-sys:without-interrupts
(if (null entry)
(error
"attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
;; default here. -- WHN 19991204
(invalid nil))
(:conc-name %wrapper-)
- (:constructor make-wrapper-internal))
+ (:constructor make-wrapper-internal)
+ (:copier nil))
(instance-slots-layout nil :type list)
(class-slots nil :type list))
#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
invalid))))
(defun (setf wrapper-state) (new-value wrapper)
(setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value 't)
+ (if (eq new-value t)
nil
new-value)))
(found
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
+ (aver (eq (sb-kernel:class-pcl-class found) class))
(let ((layout (sb-kernel:class-layout found)))
- (assert layout)
+ (aver layout)
layout))
(t
(make-wrapper-internal
(let ((found (cl:find-class (slot-value class 'name))))
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
+ (aver (eq (sb-kernel:class-pcl-class found) class))
found))
(t
(sb-kernel:make-standard-class :pcl-class class))))
(layout (sb-kernel:class-layout found)))
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
- (assert layout)
+ (aver (eq (sb-kernel:class-pcl-class found) class))
+ (aver layout)
layout))))
;;; FIXME: The immediately following macros could become inline functions.
;;; FIXME: could become inline function
(defmacro invalid-wrapper-p (wrapper)
- `(neq (wrapper-state ,wrapper) 't))
+ `(neq (wrapper-state ,wrapper) t))
(defvar *previous-nwrappers* (make-hash-table))
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
(state (wrapper-state owrapper)))
- (if (eq state 't)
+ (if (eq state t)
owrapper
(let ((nwrapper
(ecase (car state)
(defvar *free-caches* nil)
(defun get-cache (nkeys valuep limit-fn nlines)
- (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
+ (make-cache))))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
(compute-cache-parameters nkeys valuep nlines)
&optional (new-field (first-wrapper-cache-number-index)))
(let ((nkeys (cache-nkeys old-cache))
(valuep (cache-valuep old-cache))
- (cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (cache (or (sb-sys:without-interrupts (pop *free-caches*))
+ (make-cache))))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
(if (= new-nlines (cache-nlines old-cache))
;;; ENSURING that the result is a fixnum
;;; MASK the result against the mask argument.
-;;; COMPUTE-PRIMARY-CACHE-LOCATION
-;;;
;;; The basic functional version. This is used by the cache miss code to
;;; compute the primary location of an entry.
(defun compute-primary-cache-location (field mask wrappers)
(incf i))
(the fixnum (1+ (logand mask location))))))
-;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
-;;;
;;; This version is called on a cache line. It fetches the wrappers
;;; from the cache line and determines the primary location. Various
;;; parts of the cache filling code call this to determine whether it
(wrapper nil)
,@(when wrappers
`((class *the-class-t*)
- (type 't))))
- (unless (eq mt 't)
+ (type t))))
+ (unless (eq mt t)
(setq wrapper (wrapper-of arg))
(when (invalid-wrapper-p wrapper)
(setq ,invalid-wrapper-p t)