X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=8d87432ec6ef63144c9ded2457ba45cc3003bff0;hb=62f25b3b18b66ae67d555ca8a05026dbf03d89e1;hp=66d26ef965ec4e45f1e4710f559eec23f41ae393;hpb=4f8f4b25cb564509437d8fc26038143150077f14;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 66d26ef..8d87432 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -606,35 +606,39 @@ bootstrapping. ;; We still need to deal with the class case too, but at ;; least #.(find-class 'integer) and integer as equivalent ;; specializers with this. - (let* ((specializer (if (and (typep specializer 'class) - (let ((name (class-name specializer))) - (and name (symbolp name) - (eq specializer (find-class name nil))))) - (class-name specializer) - specializer)) - (kind (info :type :kind specializer))) - - (flet ((specializer-class () - (if (typep specializer 'class) - specializer - (find-class specializer nil)))) + (let* ((specializer-nameoid + (if (and (typep specializer 'class) + (let ((name (class-name specializer))) + (and name (symbolp name) + (eq specializer (find-class name nil))))) + (class-name specializer) + specializer)) + (kind (info :type :kind specializer-nameoid))) + + (flet ((specializer-nameoid-class () + (typecase specializer-nameoid + (symbol (find-class specializer-nameoid nil)) + (class specializer-nameoid) + (class-eq-specializer + (specializer-class specializer-nameoid)) + (t nil)))) (ecase kind - ((:primitive) `(type ,specializer ,parameter)) + ((:primitive) `(type ,specializer-nameoid ,parameter)) ((:defined) - (let ((class (specializer-class))) - ;; CLASS can be null here if the user has erroneously - ;; tried to use a defined type as a specializer; it - ;; can be a non-BUILT-IN-CLASS if the user defines a - ;; type and calls (SETF FIND-CLASS) in a consistent - ;; way. + (let ((class (specializer-nameoid-class))) + ;; CLASS can be null here if the user has + ;; erroneously tried to use a defined type as a + ;; specializer; it can be a non-BUILT-IN-CLASS if + ;; the user defines a type and calls (SETF + ;; FIND-CLASS) in a consistent way. (when (and class (typep class 'built-in-class)) - `(type ,specializer ,parameter)))) + `(type ,specializer-nameoid ,parameter)))) ((:instance nil) - (let ((class (specializer-class))) + (let ((class (specializer-nameoid-class))) (cond (class (if (typep class '(or built-in-class structure-class)) - `(type ,specializer ,parameter) + `(type ,class ,parameter) ;; don't declare CLOS classes as parameters; ;; it's too expensive. '(ignorable))) @@ -645,8 +649,8 @@ bootstrapping. ;; ...)). Best to let the user know we haven't ;; been able to extract enough information: (style-warn - "~@" - specializer + "~@" + specializer-nameoid 'parameter-specializer-declaration-in-defmethod) '(ignorable))))) ((:forthcoming-defclass-type) @@ -918,14 +922,42 @@ bootstrapping. #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call)) -(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) - `(funcall ,fn ,pv-cell ,next-method-call ,@args)) - -(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) - `(fmc-funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) - (fast-method-call-next-method-call ,method-call) - ,@required-args+rest-arg)) +;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs +;; are handled. The first one will get REST-ARG as a single list (as +;; the last argument), and will thus need to use APPLY. The second one +;; will get them as a &MORE argument, so we can pass the arguments +;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES. + +(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg) + `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call) + (fast-method-call-pv-cell ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) + +(defmacro invoke-fast-method-call/more (method-call + more-context + more-count + &rest required-args) + (macrolet ((generate-call (n) + ``(funcall (fast-method-call-function ,method-call) + (fast-method-call-pv-cell ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args + ,@(loop for x below ,n + collect `(sb-c::%more-arg ,more-context ,x))))) + ;; The cases with only small amounts of required arguments passed + ;; are probably very common, and special-casing speeds them up by + ;; a factor of 2 with very little effect on the other + ;; cases. Though it'd be nice to have the generic case be equally + ;; fast. + `(case ,more-count + (0 ,(generate-call 0)) + (1 ,(generate-call 1)) + (t (multiple-value-call (fast-method-call-function ,method-call) + (values (fast-method-call-pv-cell ,method-call)) + (values (fast-method-call-next-method-call ,method-call)) + ,@required-args + (sb-c::%more-arg-values ,more-context 0 ,more-count)))))) (defstruct (fast-instance-boundp (:copier nil)) (index 0 :type fixnum)) @@ -975,13 +1007,20 @@ bootstrapping. (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast - (emf restp &rest required-args+rest-arg) + (emf restp &key required-args rest-arg more-arg) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (invoke-fast-method-call ,emf ,@required-args+rest-arg))) + (trace-emf-call ,emf ,restp (list ,@required-args rest-arg)) + ,(if more-arg + `(invoke-fast-method-call/more ,emf + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf + ,restp + ,@required-args + ,@rest-arg)))) (defun effective-method-optimized-slot-access-clause - (emf restp required-args+rest-arg) + (emf restp required-args) ;; "What," you may wonder, "do these next two clauses do?" In that ;; case, you are not a PCL implementor, for they considered this to ;; be self-documenting.:-| Or CSR, for that matter, since he can @@ -992,21 +1031,21 @@ bootstrapping. ;; conclude that setting EMF to a FIXNUM is an optimized way to ;; represent these slot access operations. (when (not restp) - (let ((length (length required-args+rest-arg))) + (let ((length (length required-args))) (cond ((= 1 length) `((fixnum (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) + ,(car required-args))) (value (when .slots. (clos-slots-ref .slots. ,emf)))) (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) + (slot-unbound-internal ,(car required-args) ,emf) value))))) ((= 2 length) `((fixnum - (let ((.new-value. ,(car required-args+rest-arg)) + (let ((.new-value. ,(car required-args)) (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) + ,(cadr required-args)))) (when .slots. (setf (clos-slots-ref .slots. ,emf) .new-value.))))))) ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN @@ -1021,7 +1060,7 @@ bootstrapping. ;;; to make less work for the compiler we take a path that doesn't ;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all. (macrolet ((def (name &optional narrow) - `(defmacro ,name (emf restp &rest required-args+rest-arg) + `(defmacro ,name (emf restp &key required-args rest-arg more-arg) (unless (constantp restp) (error "The RESTP argument is not constant.")) (setq restp (constant-form-value restp)) @@ -1029,19 +1068,28 @@ bootstrapping. `(locally (declare (optimize (sb-c:insert-step-conditions 0))) (let ((,emf-n ,emf)) - (trace-emf-call ,emf-n ,restp (list ,@required-args+rest-arg)) + (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg)) (etypecase ,emf-n (fast-method-call - (invoke-fast-method-call ,emf-n ,@required-args+rest-arg)) + ,(if more-arg + `(invoke-fast-method-call/more ,emf-n + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf-n + ,restp + ,@required-args + ,@rest-arg))) ,@,(unless narrow `(effective-method-optimized-slot-access-clause - emf-n restp required-args+rest-arg)) + emf-n restp required-args)) (method-call - (invoke-method-call ,emf-n ,restp ,@required-args+rest-arg)) + (invoke-method-call ,emf-n ,restp ,@required-args + ,@rest-arg)) (function ,(if restp - `(apply ,emf-n ,@required-args+rest-arg) - `(funcall ,emf-n ,@required-args+rest-arg)))))))))) + `(apply ,emf-n ,@required-args ,@rest-arg) + `(funcall ,emf-n ,@required-args + ,@rest-arg)))))))))) (def invoke-effective-method-function nil) (def invoke-narrow-effective-method-function t)) @@ -1053,27 +1101,25 @@ bootstrapping. (restp (cdr arg-info)) (nreq (car arg-info))) (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args rest-args))) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (nconc req-args (list rest-args)))) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + args) (cond ((null args) (if (eql nreq 0) - (invoke-fast-method-call emf) + (invoke-fast-method-call emf nil) (error 'simple-program-error :format-control "invalid number of arguments: 0" :format-arguments nil))) ((null (cdr args)) (if (eql nreq 1) - (invoke-fast-method-call emf (car args)) + (invoke-fast-method-call emf nil (car args)) (error 'simple-program-error :format-control "invalid number of arguments: 1" :format-arguments nil))) ((null (cddr args)) (if (eql nreq 2) - (invoke-fast-method-call emf (car args) (cadr args)) + (invoke-fast-method-call emf nil (car args) (cadr args)) (error 'simple-program-error :format-control "invalid number of arguments: 2" :format-arguments nil))) @@ -1122,8 +1168,8 @@ bootstrapping. ,(let ((call `(invoke-narrow-effective-method-function ,next-method-call ,(not (null rest-arg)) - ,@args - ,@(when rest-arg `(,rest-arg))))) + :required-args ,args + :rest-arg ,(when rest-arg (list rest-arg))))) `(if ,cnm-args (bind-args ((,@args ,@(when rest-arg @@ -1229,7 +1275,7 @@ bootstrapping. (pop ,args-tail) ,(cadr var))))) (t - `((,(caddr var) ,args-tail) + `((,(caddr var) (not (null ,args-tail))) (,(car var) (if ,args-tail (pop ,args-tail) ,(cadr var))))))) @@ -1259,7 +1305,7 @@ bootstrapping. (car var))) `((,key (get-key-arg-tail ',keyword ,args-tail)) - (,(caddr var) ,key) + (,(caddr var) (not (null,key))) (,variable (if ,key (car ,key) ,(cadr var)))))))) @@ -1374,7 +1420,13 @@ bootstrapping. (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) - (values walked-lambda + ;;; FIXME: the walker's rewriting of the source code causes + ;;; trouble when doing code coverage. The rewrites should be + ;;; removed, and the same operations done using + ;;; compiler-macros or tranforms. + (values (if (sb-c:policy env (= sb-c:store-coverage-data 0)) + walked-lambda + method-lambda) call-next-method-p closurep next-method-p-p @@ -1558,17 +1610,21 @@ bootstrapping. (declare (ignore environment)) (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) - (if (and existing - (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function fun-name) - (apply #'ensure-generic-function-using-class - existing fun-name all-keys)))) + (cond ((and existing + (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function fun-name) + (fmakunbound fun-name) + (apply #'ensure-generic-function fun-name all-keys)) + (t + (apply #'ensure-generic-function-using-class + existing fun-name all-keys))))) (defun generic-clobbers-function (fun-name) - (error 'simple-program-error - :format-control "~S already names an ordinary function or a macro." - :format-arguments (list fun-name))) + (cerror "Replace the function binding" + 'simple-program-error + :format-control "~S already names an ordinary function or a macro." + :format-arguments (list fun-name))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) @@ -1953,8 +2009,6 @@ bootstrapping. (setf (gf-dfun-state generic-function) new-value))) (defun set-dfun (gf &optional dfun cache info) - (when cache - (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) (list* dfun cache info) dfun)))