(member generator '(emit-checking emit-caching
emit-in-checking-cache-p emit-constant-value)))
(setq args (cons (mapcar #'(lambda (mt)
- (if (eq mt 't)
+ (if (eq mt t)
mt
'class))
(car args))
(let* ((generator-entry (assq generator *dfun-constructors*))
(args-entry (assoc args (cdr generator-entry) :test #'equal)))
(if (null *enable-dfun-constructor-caching*)
- (apply (symbol-function generator) args)
+ (apply (fdefinition generator) args)
(or (cadr args-entry)
(multiple-value-bind (new not-best-p)
(apply (symbol-function generator) args)
(eq (caddr args-entry) system))
(when system (setf (caddr args-entry) system))
(gather1
- (make-top-level-form `(precompile-dfun-constructor
- ,(car generator-entry))
- '(:load-toplevel)
- `(load-precompiled-dfun-constructor
- ',(car generator-entry)
- ',(car args-entry)
- ',system
- ,(apply (symbol-function (car generator-entry))
- (car args-entry))))))))))))
+ `(load-precompiled-dfun-constructor
+ ',(car generator-entry)
+ ',(car args-entry)
+ ',system
+ ,(apply (fdefinition (car generator-entry))
+ (car args-entry)))))))))))
\f
;;; When all the methods of a generic function are automatically generated
;;; reader or writer methods a number of special optimizations are possible.
;;; slot index. A cache vector stores the wrappers and corresponding
;;; slot indexes. Because each cache line is more than one element
;;; long, a cache lock count is used.
-(defstruct (dfun-info (:constructor nil))
+(defstruct (dfun-info (:constructor nil)
+ (:copier nil))
(cache nil))
-(defstruct (no-methods
- (:constructor no-methods-dfun-info ())
- (:include dfun-info)))
+(defstruct (no-methods (:constructor no-methods-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (initial
- (:constructor initial-dfun-info ())
- (:include dfun-info)))
+(defstruct (initial (:constructor initial-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (initial-dispatch
- (:constructor initial-dispatch-dfun-info ())
- (:include dfun-info)))
+(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (dispatch
- (:constructor dispatch-dfun-info ())
- (:include dfun-info)))
+(defstruct (dispatch (:constructor dispatch-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (default-method-only
- (:constructor default-method-only-dfun-info ())
- (:include dfun-info)))
+(defstruct (default-method-only (:constructor default-method-only-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
;without caching:
; dispatch one-class two-class default-method-only
;accessor:
; one-class two-class one-index n-n
-(defstruct (accessor-dfun-info
- (:constructor nil)
- (:include dfun-info))
+(defstruct (accessor-dfun-info (:constructor nil)
+ (:include dfun-info)
+ (:copier nil))
accessor-type) ; (member reader writer)
(defmacro dfun-info-accessor-type (di)
`(accessor-dfun-info-accessor-type ,di))
-(defstruct (one-index-dfun-info
- (:constructor nil)
- (:include accessor-dfun-info))
+(defstruct (one-index-dfun-info (:constructor nil)
+ (:include accessor-dfun-info)
+ (:copier nil))
index)
(defmacro dfun-info-index (di)
`(one-index-dfun-info-index ,di))
-(defstruct (n-n
- (:constructor n-n-dfun-info (accessor-type cache))
- (:include accessor-dfun-info)))
+(defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache))
+ (:include accessor-dfun-info)
+ (:copier nil)))
-(defstruct (one-class
- (:constructor one-class-dfun-info (accessor-type index wrapper0))
- (:include one-index-dfun-info))
+(defstruct (one-class (:constructor one-class-dfun-info
+ (accessor-type index wrapper0))
+ (:include one-index-dfun-info)
+ (:copier nil))
wrapper0)
(defmacro dfun-info-wrapper0 (di)
`(one-class-wrapper0 ,di))
-(defstruct (two-class
- (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
- (:include one-class))
+(defstruct (two-class (:constructor two-class-dfun-info
+ (accessor-type index wrapper0 wrapper1))
+ (:include one-class)
+ (:copier nil))
wrapper1)
(defmacro dfun-info-wrapper1 (di)
`(two-class-wrapper1 ,di))
-(defstruct (one-index
- (:constructor one-index-dfun-info
- (accessor-type index cache))
- (:include one-index-dfun-info)))
+(defstruct (one-index (:constructor one-index-dfun-info
+ (accessor-type index cache))
+ (:include one-index-dfun-info)
+ (:copier nil)))
-(defstruct (checking
- (:constructor checking-dfun-info (function cache))
- (:include dfun-info))
+(defstruct (checking (:constructor checking-dfun-info (function cache))
+ (:include dfun-info)
+ (:copier nil))
function)
(defmacro dfun-info-function (di)
`(checking-function ,di))
-(defstruct (caching
- (:constructor caching-dfun-info (cache))
- (:include dfun-info)))
+(defstruct (caching (:constructor caching-dfun-info (cache))
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (constant-value
- (:constructor constant-value-dfun-info (cache))
- (:include dfun-info)))
+(defstruct (constant-value (:constructor constant-value-dfun-info (cache))
+ (:include dfun-info)
+ (:copier nil)))
(defmacro dfun-update (generic-function function &rest args)
`(multiple-value-bind (dfun cache info)
(defun accessor-miss-function (gf dfun-info)
(ecase (dfun-info-accessor-type dfun-info)
(reader
- #'(lambda (arg)
- (declare (pcl-fast-call))
- (accessor-miss gf nil arg dfun-info)))
+ (lambda (arg)
+ (accessor-miss gf nil arg dfun-info)))
(writer
- #'(lambda (new arg)
- (declare (pcl-fast-call))
- (accessor-miss gf new arg dfun-info)))))
+ (lambda (new arg)
+ (accessor-miss gf new arg dfun-info)))))
#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
\f
(multiple-value-bind (nreq applyp metatypes nkeys)
(get-generic-function-info generic-function)
(declare (ignore nreq))
- (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (if (every #'(lambda (mt) (eq mt t)) metatypes)
(let ((dfun-info (default-method-only-dfun-info)))
(values
(funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
(funcall (get-dfun-constructor 'emit-checking metatypes applyp)
cache
function
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (checking-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (checking-miss generic-function args dfun-info)))
cache
dfun-info)))))
(defun make-final-checking-dfun (generic-function function
classes-list new-class)
(let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
- (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (if (every #'(lambda (mt) (eq mt t)) metatypes)
(values #'(lambda (&rest args)
(invoke-emf function args))
nil (default-method-only-dfun-info))
(multiple-value-bind (nreq applyp metatypes nkeys)
(get-generic-function-info generic-function)
(declare (ignore nreq applyp nkeys))
- (every #'(lambda (mt) (eq mt 't)) metatypes)))
+ (every #'(lambda (mt) (eq mt t)) metatypes)))
(defun use-caching-dfun-p (generic-function)
(some (lambda (method)
(values
(funcall (get-dfun-constructor 'emit-caching metatypes applyp)
cache
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (caching-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (caching-miss generic-function args dfun-info)))
cache
dfun-info))))
(when (and metatypes
(not (null (car metatypes)))
(dolist (mt metatypes nil)
- (unless (eq mt 't) (return t))))
+ (unless (eq mt t) (return t))))
(get-dfun-constructor 'emit-caching metatypes applyp))))
(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
(method-function method)))
:constant-value default)))
(if boolean-values-p
- (not (or (eq value 't) (eq value nil)))
+ (not (or (eq value t) (eq value nil)))
(eq value default)))))
methods)))))
(values
(funcall (get-dfun-constructor 'emit-constant-value metatypes)
cache
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (constant-value-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (constant-value-miss generic-function args dfun-info)))
cache
dfun-info))))
(ecase type
(reader #'(sb-kernel:instance-lambda (instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-get-slot class-name instance slot-name))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-get-slot class-name instance slot-name))))
(writer #'(sb-kernel:instance-lambda (new-value instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-set-slot class-name instance slot-name new-value)))))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-set-slot class-name instance slot-name new-value)))))))
(defun initial-dfun (gf args)
(dfun-miss (gf args wrappers invalidp nemf ntype nindex)
(dolist (sclass (if early-p
(early-class-precedence-list class)
(class-precedence-list class))
- (error "This can't happen"))
+ (error "This can't happen."))
(let ((a (assq sclass specl+slotd-list)))
(when a
(let* ((slotd (cdr a))
(defun order-specializers (specl1 specl2 index compare-classes-function)
(let ((type1 (if (eq *boot-state* 'complete)
(specializer-type specl1)
- (bootstrap-get-slot 'specializer specl1 'type)))
+ (!bootstrap-get-slot 'specializer specl1 'type)))
(type2 (if (eq *boot-state* 'complete)
(specializer-type specl2)
- (bootstrap-get-slot 'specializer specl2 'type))))
+ (!bootstrap-get-slot 'specializer specl2 'type))))
(cond ((eq specl1 specl2)
nil)
((atom type1)
(defun specializer-applicable-using-type-p (specl type)
(setq specl (type-from-specializer specl))
- (when (eq specl 't)
+ (when (eq specl t)
(return-from specializer-applicable-using-type-p (values t t)))
;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
;; and has only what they need.
- (if (or (atom type) (eq (car type) 't))
+ (if (or (atom type) (eq (car type) t))
(values nil t)
(case (car type)
(and (saut-and specl type))
'specializer-applicable-using-type-p
type)))))
-(defun map-all-classes (function &optional (root 't))
+(defun map-all-classes (function &optional (root t))
(let ((braid-p (or (eq *boot-state* 'braid)
(eq *boot-state* 'complete))))
(labels ((do-class (class)
(defun update-dfun (generic-function &optional dfun cache info)
(let* ((early-p (early-gf-p generic-function))
(gf-name (if early-p
- (early-gf-name generic-function)
+ (!early-gf-name generic-function)
(generic-function-name generic-function)))
(ocache (gf-dfun-cache generic-function)))
(set-dfun generic-function dfun cache info)
projects / sbcl.git / blobdiff