`(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))))))
\f
;;;; early definition of WRAPPER
;;;;
;; default of WRAPPER-INVALID. Instead of trying
;; to find out, I just overrode the LAYOUT
;; default here. -- WHN 19991204
- (invalid nil))
- (:conc-name %wrapper-)
+ (invalid nil)
+ ;; This allows quick testing of wrapperness.
+ (for-std-class-p t))
(:constructor make-wrapper-internal)
(:copier nil))
(instance-slots-layout nil :type list)
\f
;;;; PCL's view of funcallable instances
-(!defstruct-with-alternate-metaclass pcl-funcallable-instance
+(!defstruct-with-alternate-metaclass standard-funcallable-instance
;; KLUDGE: Note that neither of these slots is ever accessed by its
;; accessor name as of sbcl-0.pre7.63. Presumably everything works
;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
:slot-names (clos-slots name hash-code)
- :boa-constructor %make-pcl-funcallable-instance
- :superclass-name funcallable-instance
- :metaclass-name random-pcl-classoid
- :metaclass-constructor make-random-pcl-classoid
+ :boa-constructor %make-standard-funcallable-instance
+ :superclass-name function
+ :metaclass-name standard-classoid
+ :metaclass-constructor make-standard-classoid
:dd-type funcallable-structure
;; Only internal implementation code will access these, and these
;; accesses (slot readers in particular) could easily be a
(declare (type function new-value))
(aver (funcallable-instance-p fin))
(setf (funcallable-instance-fun fin) new-value))
-(defmacro fsc-instance-p (fin)
+
+;;; 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.
+(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))
-;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS
-;;; slot in the FUNCALLABLE-INSTANCE structure, above, which
-;;; (bizarrely) seems to be set to the NAME of the
-;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the
-;;; NAME, and the index 2 NIL. Weird. -- CSR, 2002-11-07
(defmacro fsc-instance-slots (fin)
- `(%funcallable-instance-info ,fin 0))
+ `(%funcallable-instance-info ,fin 1))
(defmacro fsc-instance-hash (fin)
`(%funcallable-instance-info ,fin 3))
\f
;;; 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
(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)))
- (when (funcallable-instance-p fun)
- (if (if (eq *boot-state* 'complete)
- (typep fun 'generic-function)
- (eq (class-of fun) *the-class-standard-generic-function*))
- (setf (%funcallable-instance-info fun 1) new-name)
- (bug "unanticipated function type")))
+ (typecase fun
+ (%method-function (setf (%method-function-name fun) new-name))
+ #+sb-eval
+ (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)
+ (typep fun 'generic-function)
+ (eq (class-of fun) *the-class-standard-generic-function*))
+ (setf (%funcallable-instance-info fun 2) new-name))
+ (t
+ (bug "unanticipated function type")))))
;; Fixup name-to-function mappings in cases where the function
;; hasn't been defined by DEFUN. (FIXME: is this right? This logic
;; comes from CMUCL). -- CSR, 2004-12-31
(!defstruct-with-alternate-metaclass standard-instance
:slot-names (slots hash-code)
:boa-constructor %make-standard-instance
- :superclass-name instance
+ :superclass-name t
:metaclass-name standard-classoid
:metaclass-constructor make-standard-classoid
:dd-type structure
(when (pcl-instance-p instance)
(get-slots instance)))
-(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
-
(defmacro get-wrapper (inst)
(once-only ((wrapper `(wrapper-of ,inst)))
`(progn
;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
-(defun get-structure-dd (type)
- (layout-info (classoid-layout (find-classoid type))))
-
-(defun structure-type-included-type-name (type)
- (let ((include (dd-include (get-structure-dd 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 (get-structure-dd include)))))
- (dd-slots (get-structure-dd 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))
(defun structure-slotd-writer-function (type slotd)
(if (dsd-read-only slotd)
- (let ((dd (get-structure-dd type)))
+ (let ((dd (find-defstruct-description type)))
(coerce (slot-setter-lambda-form dd slotd) 'function))
(fdefinition `(setf ,(dsd-accessor-name slotd)))))
(defun structure-slotd-init-form (slotd)
(dsd-default slotd))
-
-;;; 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?
+\f
+;;; method function stuff.
;;;
-;;; 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))
-
- (defmacro with-pcl-lock (&body body)
- `(sb-thread::with-spinlock (*pcl-lock*)
- ,@body)))
-
-#-sb-thread
-(defmacro with-pcl-lock (&body body)
- `(progn ,@body))
+;;; PCL historically included a so-called method-fast-function, which
+;;; is essentially a method function but with (a) a precomputed
+;;; continuation for CALL-NEXT-METHOD and (b) a permutation vector for
+;;; slot access. [ FIXME: see if we can understand these two
+;;; optimizations before commit. ] However, the presence of the
+;;; fast-function meant that we violated AMOP and the effect of the
+;;; :FUNCTION initarg, and furthermore got to potentially confusing
+;;; situations where the function and the fast-function got out of
+;;; sync, so that calling (method-function method) with the defined
+;;; protocol would do different things from (call-method method) in
+;;; method combination.
+;;;
+;;; So we define this internal method function structure, which we use
+;;; when we create a method function ourselves. This means that we
+;;; can hang the various bits of information that we want off the
+;;; method function itself, and also that if a user overrides method
+;;; function creation there is no danger of having the system get
+;;; confused.
+(!defstruct-with-alternate-metaclass %method-function
+ :slot-names (fast-function name)
+ :boa-constructor %make-method-function
+ :superclass-name function
+ :metaclass-name static-classoid
+ :metaclass-constructor make-static-classoid
+ :dd-type funcallable-structure)
+
projects / sbcl.git / blobdiff