(defclass funcallable-standard-object (std-object
sb-kernel:funcallable-instance)
- ()
+ ()
(:metaclass funcallable-standard-class))
(defclass specializer (standard-object)
- ((type
- :initform nil
- :reader specializer-type)))
+ ((type
+ :initform nil
+ :reader specializer-type)))
(defclass definition-source-mixin (std-object)
- ((source
- :initform *load-truename*
- :reader definition-source
- :initarg :definition-source))
+ ((source
+ :initform *load-truename*
+ :reader definition-source
+ :initarg :definition-source))
(:metaclass std-class))
(defclass plist-mixin (std-object)
- ((plist
- :initform ()
- :accessor object-plist))
+ ((plist
+ :initform ()
+ :accessor object-plist))
(:metaclass std-class))
(defclass documentation-mixin (plist-mixin)
- ()
+ ()
(:metaclass std-class))
(defclass dependent-update-mixin (plist-mixin)
- ()
+ ()
(:metaclass std-class))
-;;; The class CLASS is a specified basic class. It is the common superclass
-;;; of any kind of class. That is any class that can be a metaclass must
-;;; have the class CLASS in its class precedence list.
-(defclass class (documentation-mixin dependent-update-mixin
- definition-source-mixin specializer)
- ((name
- :initform nil
- :initarg :name
- :accessor class-name)
- (class-eq-specializer
- :initform nil
- :reader class-eq-specializer)
- (direct-superclasses
- :initform ()
- :reader class-direct-superclasses)
- (direct-subclasses
- :initform ()
- :reader class-direct-subclasses)
- (direct-methods
- :initform (cons nil nil))
- (predicate-name
- :initform nil
- :reader class-predicate-name)))
-
-;;; The class PCL-CLASS is an implementation-specific common superclass of
-;;; all specified subclasses of the class CLASS.
+;;; The class CLASS is a specified basic class. It is the common
+;;; superclass of any kind of class. That is any class that can be a
+;;; metaclass must have the class CLASS in its class precedence list.
+(defclass class (documentation-mixin
+ dependent-update-mixin
+ definition-source-mixin
+ specializer)
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor class-name)
+ (class-eq-specializer
+ :initform nil
+ :reader class-eq-specializer)
+ (direct-superclasses
+ :initform ()
+ :reader class-direct-superclasses)
+ (direct-subclasses
+ :initform ()
+ :reader class-direct-subclasses)
+ (direct-methods
+ :initform (cons nil nil))
+ (predicate-name
+ :initform nil
+ :reader class-predicate-name)))
+
+;;; The class PCL-CLASS is an implementation-specific common
+;;; superclass of all specified subclasses of the class CLASS.
(defclass pcl-class (class)
- ((class-precedence-list
- :reader class-precedence-list)
- (can-precede-list
- :initform ()
- :reader class-can-precede-list)
- (incompatible-superclass-list
- :initform ()
- :accessor class-incompatible-superclass-list)
- (wrapper
- :initform nil
- :reader class-wrapper)
- (prototype
- :initform nil
- :reader class-prototype)))
+ ((class-precedence-list
+ :reader class-precedence-list)
+ (can-precede-list
+ :initform ()
+ :reader class-can-precede-list)
+ (incompatible-superclass-list
+ :initform ()
+ :accessor class-incompatible-superclass-list)
+ (wrapper
+ :initform nil
+ :reader class-wrapper)
+ (prototype
+ :initform nil
+ :reader class-prototype)))
(defclass slot-class (pcl-class)
- ((direct-slots
- :initform ()
- :accessor class-direct-slots)
- (slots
- :initform ()
- :accessor class-slots)
- (initialize-info
- :initform nil
- :accessor class-initialize-info)))
-
-;;; The class STD-CLASS is an implementation-specific common superclass of
-;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
+ ((direct-slots
+ :initform ()
+ :accessor class-direct-slots)
+ (slots
+ :initform ()
+ :accessor class-slots)
+ (initialize-info
+ :initform nil
+ :accessor class-initialize-info)))
+
+;;; The class STD-CLASS is an implementation-specific common
+;;; superclass of the classes STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
(defclass std-class (slot-class)
())
;;;; slot definitions
(defclass slot-definition (standard-object)
- ((name
- :initform nil
- :initarg :name
- :accessor slot-definition-name)
- (initform
- :initform nil
- :initarg :initform
- :accessor slot-definition-initform)
- (initfunction
- :initform nil
- :initarg :initfunction
- :accessor slot-definition-initfunction)
- (readers
- :initform nil
- :initarg :readers
- :accessor slot-definition-readers)
- (writers
- :initform nil
- :initarg :writers
- :accessor slot-definition-writers)
- (initargs
- :initform nil
- :initarg :initargs
- :accessor slot-definition-initargs)
- (type
- :initform t
- :initarg :type
- :accessor slot-definition-type)
- (documentation
- :initform ""
- :initarg :documentation)
- (class
- :initform nil
- :initarg :class
- :accessor slot-definition-class)))
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor slot-definition-name)
+ (initform
+ :initform nil
+ :initarg :initform
+ :accessor slot-definition-initform)
+ (initfunction
+ :initform nil
+ :initarg :initfunction
+ :accessor slot-definition-initfunction)
+ (readers
+ :initform nil
+ :initarg :readers
+ :accessor slot-definition-readers)
+ (writers
+ :initform nil
+ :initarg :writers
+ :accessor slot-definition-writers)
+ (initargs
+ :initform nil
+ :initarg :initargs
+ :accessor slot-definition-initargs)
+ (type
+ :initform t
+ :initarg :type
+ :accessor slot-definition-type)
+ (documentation
+ :initform ""
+ :initarg :documentation)
+ (class
+ :initform nil
+ :initarg :class
+ :accessor slot-definition-class)))
(defclass standard-slot-definition (slot-definition)
((allocation
(defclass method-combination (standard-object) ())
-(defclass standard-method-combination
- (definition-source-mixin method-combination)
- ((type :reader method-combination-type
- :initarg :type)
- (documentation :reader method-combination-documentation
- :initarg :documentation)
- (options :reader method-combination-options
- :initarg :options)))
+(defclass standard-method-combination (definition-source-mixin
+ method-combination)
+ ((type
+ :reader method-combination-type
+ :initarg :type)
+ (documentation
+ :reader method-combination-documentation
+ :initarg :documentation)
+ (options
+ :reader method-combination-options
+ :initarg :options)))
(defparameter *early-class-predicates*
'((specializer specializerp)
;;; --------------------------------
+;;; FIXME: What do these variables mean?
(defvar *precompiling-lap* nil)
(defvar *emit-function-p* t)
(restl (when applyp '(.lap-rest-arg.))))
(generating-lisp '(emf)
dlap-lambda-list
- `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
-
-(defmacro emit-default-only-macro (metatypes applyp)
- (let ((*emit-function-p* nil)
- (*precompiling-lap* t))
- (values
- (emit-default-only metatypes applyp))))
+ `(invoke-effective-method-function emf
+ ,applyp
+ ,@args
+ ,@restl))))
;;; --------------------------------
nil)))
;;; note on implementation for CMU 17 and later (including SBCL):
-;;; Since std-instance-p is weakened, that branch may run on non-pcl
+;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
;;; instances (structures). The result will be the non-wrapper layout
;;; for the structure, which will cause a miss. The "slots" will be
;;; whatever the first slot is, but will be ignored. Similarly,
-;;; fsc-instance-p returns true on funcallable structures as well as
+;;; FSC-INSTANCE-P returns true on funcallable structures as well as
;;; PCL fins.
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
(when (and (null *precompiling-lap*) *emit-function-p*)
(ecase 1-or-2-class
(1 (setq closure-variables '(wrapper-0 index miss-fn)))
(2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
- (generating-lisp closure-variables
- arglist
- `(let* (,@(unless class-slot-p `((slots nil)))
+ (generating-lisp
+ closure-variables
+ arglist
+ `(let* (,@(unless class-slot-p `((slots nil)))
(wrapper (cond ((std-instance-p ,instance)
,@(unless class-slot-p
- `((setq slots (std-instance-slots ,instance))))
+ `((setq slots
+ (std-instance-slots ,instance))))
(std-instance-wrapper ,instance))
((fsc-instance-p ,instance)
,@(unless class-slot-p
- `((setq slots (fsc-instance-slots ,instance))))
+ `((setq slots
+ (fsc-instance-slots ,instance))))
(fsc-instance-wrapper ,instance)))))
- (block access
- (when (and wrapper
- (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
- ,@(if (eql 1 1-or-2-class)
- `((eq wrapper wrapper-0))
- `((or (eq wrapper wrapper-0)
- (eq wrapper wrapper-1)))))
- ,@(if readp
- `((let ((value ,read-form))
- (unless (eq value +slot-unbound+)
- (return-from access value))))
- `((return-from access (setf ,read-form ,(car arglist))))))
- (funcall miss-fn ,@arglist))))))
+ (block access
+ (when (and wrapper
+ (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
+ ,@(if (eql 1 1-or-2-class)
+ `((eq wrapper wrapper-0))
+ `((or (eq wrapper wrapper-0)
+ (eq wrapper wrapper-1)))))
+ ,@(if readp
+ `((let ((value ,read-form))
+ (unless (eq value +slot-unbound+)
+ (return-from access value))))
+ `((return-from access (setf ,read-form ,(car arglist))))))
+ (funcall miss-fn ,@arglist))))))
(defun emit-slot-read-form (class-slot-p index slots)
(if class-slot-p
(funcall ,miss-fn ,@arglist)
value)))
-(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
+(defun emit-slot-access (reader/writer
+ class-slot-p
+ slots
+ index
+ miss-fn
+ arglist)
(let ((read-form (emit-slot-read-form class-slot-p index slots))
(write-form (emit-slot-write-form
class-slot-p index slots (car arglist))))
(values
(emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
-(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
+(defun emit-one-or-n-index-reader/writer (reader/writer
+ cached-index-p
+ class-slot-p)
(when (and (null *precompiling-lap*) *emit-function-p*)
(return-from emit-one-or-n-index-reader/writer
(emit-one-or-n-index-reader/writer-function
'(standard-instance)))
(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
'(t standard-instance))))
- (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
- arglist
- `(let (,@(unless class-slot-p '(slots))
- ,@(when cached-index-p '(index)))
- ,(emit-dlap arglist metatypes
- (emit-slot-access reader/writer class-slot-p
- 'slots 'index 'miss-fn arglist)
- `(funcall miss-fn ,@arglist)
- (when cached-index-p 'index)
- (unless class-slot-p '(slots)))))))
+ (generating-lisp
+ `(cache ,@(unless cached-index-p '(index)) miss-fn)
+ arglist
+ `(let (,@(unless class-slot-p '(slots))
+ ,@(when cached-index-p '(index)))
+ ,(emit-dlap arglist metatypes
+ (emit-slot-access reader/writer class-slot-p
+ 'slots 'index 'miss-fn arglist)
+ `(funcall miss-fn ,@arglist)
+ (when cached-index-p 'index)
+ (unless class-slot-p '(slots)))))))
(defmacro emit-one-or-n-index-reader/writer-macro
(reader/writer cached-index-p class-slot-p)
(let ((*emit-function-p* nil)
(*precompiling-lap* t))
(values
- (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
+ (emit-one-or-n-index-reader/writer reader/writer
+ cached-index-p
+ class-slot-p))))
(defun emit-miss (miss-fn args &optional applyp)
(let ((restl (when applyp '(.lap-rest-arg.))))
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
(args (remove '&rest dlap-lambda-list))
(restl (when applyp '(.lap-rest-arg.))))
- (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
- dlap-lambda-list
- `(let (,@(when cached-emf-p '(emf)))
- ,(emit-dlap args
- metatypes
- (if return-value-p
- (if cached-emf-p 'emf t)
- `(invoke-effective-method-function emf ,applyp
- ,@args ,@restl))
- (emit-miss 'miss-fn args applyp)
- (when cached-emf-p 'emf))))))
-
-(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
+ (generating-lisp
+ `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
+ dlap-lambda-list
+ `(let (,@(when cached-emf-p '(emf)))
+ ,(emit-dlap args
+ metatypes
+ (if return-value-p
+ (if cached-emf-p 'emf t)
+ `(invoke-effective-method-function
+ emf ,applyp ,@args ,@restl))
+ (emit-miss 'miss-fn args applyp)
+ (when cached-emf-p 'emf))))))
+
+(defmacro emit-checking-or-caching-macro (cached-emf-p
+ return-value-p
+ metatypes
+ applyp)
(let ((*emit-function-p* nil)
(*precompiling-lap* t))
(values
(return-from dfun ,miss)))))
(defun emit-1-nil-dlap (wrapper miss-label)
- `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+ `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
+ miss-label))
(location primary))
(declare (fixnum primary location))
(block search
(the fixnum lock-count)))
(defun emit-1-t-dlap (wrapper miss-label value)
- `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+ `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
+ miss-label))
(initial-lock-count (get-cache-vector-lock-count cache-vector)))
(declare (fixnum primary initial-lock-count))
(let ((location primary))
(defun emit-greater-than-1-dlap (wrappers miss-label value)
(declare (type list wrappers))
- (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
- `(let ((primary 0) (size-1 (the fixnum (- size 1))))
+ (let ((cache-line-size (compute-line-size (+ (length wrappers)
+ (if value 1 0)))))
+ `(let ((primary 0)
+ (size-1 (the fixnum (- size 1))))
(declare (fixnum primary size-1))
,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
(let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
(declare (fixnum initial-lock-count))
- (let ((location primary) (next-location 0))
+ (let ((location primary)
+ (next-location 0))
(declare (fixnum location next-location))
(block search
(loop (setq next-location
wrappers))
,@(when value
`((setq location (the fixnum (+ location 1)))
- (setq ,value (cache-vector-ref cache-vector location))))
+ (setq ,value (cache-vector-ref cache-vector
+ location))))
(return-from search nil))
(setq location next-location)
(when (= location size-1)
`(the fixnum ,form))))))))
wrappers))))
-;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
-;;; approach of using funcallable instances, that branch may run
-;;; on non-pcl instances (structures). The result will be the
-;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
-;;; will be whatever the first slot is, but will be ignored. Similarly,
-;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
+;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
+;;; CMU/SBCL approach of using funcallable instances, that branch may
+;;; run on non-pcl instances (structures). The result will be the
+;;; non-wrapper layout for the structure, which will cause a miss. The
+;;; "slots" will be whatever the first slot is, but will be ignored.
+;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
+;;; as well as PCL fins.
(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
(ecase metatype
((standard-instance)
projects / sbcl.git / commitdiff