X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Flow.lisp;h=9de576360eac270de4bd1886243cc1bc33c0523f;hb=3fa2feb10ab827fc6cc2a85287e78b6e66b7bf4d;hp=db395cd21698e62eb136689d2cc89b7bb415e7a0;hpb=1dc38285834db2d374a156a4f68b19096341deb3;p=sbcl.git

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index db395cd..9de5763 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -46,6 +46,27 @@
   `(dotimes (,var (the fixnum ,count) ,result)
      (declare (fixnum ,var))
      ,@body))
+
+(declaim (inline random-fixnum))
+(defun random-fixnum ()
+  (random (1+ most-positive-fixnum)))
+
+(defconstant n-fixnum-bits #.(integer-length most-positive-fixnum))
+
+;;; Lambda which executes its body (or not) randomly. Used to drop
+;;; random cache entries.
+(defmacro randomly-punting-lambda (lambda-list &body body)
+  (with-unique-names (drops drop-pos)
+    `(let ((,drops (random-fixnum))
+           (,drop-pos n-fixnum-bits))
+       (declare (fixnum ,drops)
+                (type (integer 0 #.n-fixnum-bits) ,drop-pos))
+       (lambda ,lambda-list
+         (when (logbitp (the unsigned-byte (decf ,drop-pos)) ,drops)
+           (locally ,@body))
+         (when (zerop ,drop-pos)
+           (setf ,drops (random-fixnum)
+                 ,drop-pos n-fixnum-bits))))))
 
 ;;;; early definition of WRAPPER
 ;;;;
@@ -102,11 +123,14 @@
   (declare (type function new-value))
   (aver (funcallable-instance-p fin))
   (setf (funcallable-instance-fun fin) new-value))
+
 ;;; FIXME: these macros should just go away.  It's not clear whether
 ;;; the inline functions defined by
 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS are as efficient as they could
 ;;; be; ordinary defstruct accessors are defined as source transforms.
-(defmacro fsc-instance-p (fin)
+(defun fsc-instance-p (fin)
+  (funcallable-instance-p fin))
+(define-compiler-macro fsc-instance-p (fin)
   `(funcallable-instance-p ,fin))
 (defmacro fsc-instance-wrapper (fin)
   `(%funcallable-instance-layout ,fin))
@@ -128,7 +152,9 @@
 ;;; and normal instances, so we can return true on structures also. A
 ;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to
 ;;; PCL-INSTANCE-P.
-(defmacro std-instance-p (x)
+(defun std-instance-p (x)
+  (%instancep x))
+(define-compiler-macro std-instance-p (x)
   `(%instancep ,x))
 
 ;; a temporary definition used for debugging the bootstrap
@@ -176,7 +202,6 @@
 (defun set-fun-name (fun new-name)
   #+sb-doc
   "Set the name of a compiled function object. Return the function."
-  (declare (special *boot-state* *the-class-standard-generic-function*))
   (when (valid-function-name-p fun)
     (setq fun (fdefinition fun)))
   (typecase fun
@@ -185,7 +210,7 @@
     (sb-eval:interpreted-function
      (setf (sb-eval:interpreted-function-name fun) new-name))
     (funcallable-instance ;; KLUDGE: probably a generic function...
-     (cond ((if (eq *boot-state* 'complete)
+     (cond ((if (eq **boot-state** 'complete)
                 (typep fun 'generic-function)
                 (eq (class-of fun) *the-class-standard-generic-function*))
             (setf (%funcallable-instance-info fun 2) new-name))
@@ -305,17 +330,23 @@
 
 ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
 
-(defun structure-type-included-type-name (type)
-  (let ((include (dd-include (find-defstruct-description type))))
-    (if (consp include)
-        (car include)
-        include)))
-
 (defun structure-type-slot-description-list (type)
-  (nthcdr (length (let ((include (structure-type-included-type-name type)))
-                    (and include
-                         (dd-slots (find-defstruct-description include)))))
-          (dd-slots (find-defstruct-description type))))
+  (let* ((dd (find-defstruct-description type))
+         (include (dd-include dd))
+         (all-slots (dd-slots dd)))
+    (multiple-value-bind (super slot-overrides)
+        (if (consp include)
+            (values (car include) (mapcar #'car (cdr include)))
+            (values include nil))
+      (let ((included-slots
+             (when super
+               (dd-slots (find-defstruct-description super)))))
+        (loop for slot = (pop all-slots)
+              for included-slot = (pop included-slots)
+              while slot
+              when (or (not included-slot)
+                       (member (dsd-name included-slot) slot-overrides :test #'eq))
+              collect slot)))))
 
 (defun structure-slotd-name (slotd)
   (dsd-name slotd))
@@ -365,28 +396,4 @@
   :metaclass-name static-classoid
   :metaclass-constructor make-static-classoid
   :dd-type funcallable-structure)
-
-;;; WITH-PCL-LOCK is used around some forms that were previously
-;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
-;;; have a useful WITHOUT-INTERRUPTS.  In an unthreaded SBCL I'm not
-;;; sure what the desired effect is anyway: should we be protecting
-;;; against the possibility of recursive calls into these functions
-;;; or are we using WITHOUT-INTERRUPTS as WITHOUT-SCHEDULING?
-;;;
-;;; Users: FORCE-CACHE-FLUSHES, MAKE-INSTANCES-OBSOLETE.  Note that
-;;; it's not all certain this is sufficent for threadsafety: do we
-;;; just have to protect against simultaneous calls to these mutators,
-;;; or actually to stop normal slot access etc at the same time as one
-;;; of them runs
-
-#+sb-thread
-(progn
-  (defvar *pcl-lock* (sb-thread::make-spinlock :name "PCL lock"))
-
-  (defmacro with-pcl-lock (&body body)
-    `(sb-thread::with-spinlock (*pcl-lock*)
-      ,@body)))
-
-#-sb-thread
-(defmacro with-pcl-lock (&body body)
-  `(progn ,@body))
+