X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=627b660c29ee6c64409d5d6659f6a04610c2f119;hb=416152f084604094445a758ff399871132dff2bd;hp=6c2c45ff3b89419a6a604885fb81fba92ddfeb25;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index 6c2c45f..627b660 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -25,25 +25,6 @@
 
 (in-package "SB-PCL")
 
-;;; 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 >>
@@ -290,7 +271,8 @@
 		      ;; 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))
@@ -334,7 +316,7 @@
 	   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)))
 
@@ -353,9 +335,9 @@
      (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
@@ -388,7 +370,7 @@
 		     (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))))
@@ -399,8 +381,8 @@
 	   (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.
@@ -442,7 +424,7 @@
 
 ;;; 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))
 
@@ -476,7 +458,7 @@
 (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)
@@ -597,7 +579,7 @@
 	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
 		cache-size
 		line-size
-		(the fixnum (floor cache-size line-size))))
+		(the (values fixnum t) (floor cache-size line-size))))
       (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
 	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
 			     (the fixnum
@@ -610,7 +592,7 @@
 	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
 		(the fixnum (1+ cache-size))
 		line-size
-		(the fixnum (floor cache-size line-size))))))
+		(the (values fixnum t) (floor cache-size line-size))))))
 
 ;;; the various implementations of computing a primary cache location from
 ;;; wrappers. Because some implementations of this must run fast there are
@@ -622,8 +604,6 @@
 ;;;  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)
@@ -652,8 +632,6 @@
 	  (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
@@ -751,8 +729,8 @@
 	      (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)