X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=0811d8e6f8ecfa68551c4ccd4d53c9c667eb8497;hb=d147d512602d761a2dcdfded506dd1a8f9a140dc;hp=f2142c896095b9c3534f57baf9f6991a364ad14a;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index f2142c8..0811d8e 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -22,9 +22,6 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") #| @@ -107,7 +104,7 @@ And so, we are saved. (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)) @@ -115,7 +112,7 @@ And so, we are saved. (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) @@ -164,15 +161,12 @@ And so, we are saved. (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))))))))))) ;;; When all the methods of a generic function are automatically generated ;;; reader or writer methods a number of special optimizations are possible. @@ -207,28 +201,29 @@ And so, we are saved. ;;; 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 @@ -238,62 +233,64 @@ And so, we are saved. ;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) @@ -303,13 +300,11 @@ And so, we are saved. (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)) @@ -382,7 +377,7 @@ And so, we are saved. (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) @@ -395,16 +390,15 @@ And so, we are saved. (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)) @@ -417,7 +411,7 @@ And so, we are saved. (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) @@ -453,9 +447,8 @@ And so, we are saved. (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)))) @@ -475,7 +468,7 @@ And so, we are saved. (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) @@ -501,7 +494,7 @@ And so, we are saved. (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))))) @@ -514,9 +507,8 @@ And so, we are saved. (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)))) @@ -733,12 +725,12 @@ And so, we are saved. (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) @@ -1130,7 +1122,7 @@ And so, we are saved. (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)) @@ -1208,10 +1200,10 @@ And so, we are saved. (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) @@ -1389,11 +1381,11 @@ And so, we are saved. (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)) @@ -1406,7 +1398,7 @@ And so, we are saved. '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) @@ -1507,7 +1499,7 @@ And so, we are saved. (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)