;; 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)))
;; ...)). Best to let the user know we haven't
;; been able to extract enough information:
(style-warn
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- specializer
+ "~@<can't find type for specializer ~S in ~S.~@:>"
+ specializer-nameoid
'parameter-specializer-declaration-in-defmethod)
'(ignorable)))))
((:forthcoming-defclass-type)
#-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))
(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
;; 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
;;; 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))
`(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))
(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)))
,(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
(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)))))))
(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))))))))
(set-slot-value #'optimize-set-slot-value)
(slot-boundp #'optimize-slot-boundp))))
(funcall fun slots parameter form))))
- ((and (eq (car form) 'apply)
- (consp (cadr form))
- (eq (car (cadr form)) 'function)
- (generic-function-name-p (cadr (cadr form))))
- (optimize-generic-function-call
- form required-parameters env slots calls))
- ((generic-function-name-p (car form))
- (optimize-generic-function-call
- form required-parameters env slots calls))
(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
(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)
projects / sbcl.git / blobdiff