((:forthcoming-defclass-type)
'(ignorable))))))))
+;;; For passing a list (groveled by the walker) of the required
+;;; parameters whose bindings are modified in the method body to the
+;;; optimized-slot-value* macros.
+(define-symbol-macro %parameter-binding-modified ())
+
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
(return nil))))))
(multiple-value-bind
(walked-lambda call-next-method-p closurep
- next-method-p-p setq-p)
+ next-method-p-p setq-p
+ parameters-setqd)
(walk-method-lambda method-lambda
required-parameters
env
(setq plist
`(,@(when slot-name-lists
`(:slot-name-lists ,slot-name-lists))
- ,@(when call-list
- `(:call-list ,call-list))
- ,@plist))
+ ,@(when call-list
+ `(:call-list ,call-list))
+ ,@plist))
(setq walked-lambda-body
`((pv-binding (,required-parameters
,slot-name-lists
(intern-pv-table
:slot-name-lists ',slot-name-lists
:call-list ',call-list)))
- ,@walked-lambda-body)))))
+ ,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let ((aux (memq '&aux lambda-list)))
:closurep ,closurep
:applyp ,applyp)
,@walked-declarations
- ,@walked-lambda-body))
+ (locally
+ (declare (disable-package-locks
+ %parameter-binding-modified))
+ (symbol-macrolet ((%parameter-binding-modified
+ ',@parameters-setqd))
+ (declare (enable-package-locks
+ %parameter-binding-modified))
+ ,@walked-lambda-body))))
`(,@(when plist
`(plist ,plist))
,@(when documentation
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(invoke-fast-method-call ,emf ,@required-args+rest-arg)))
-(defmacro invoke-effective-method-function (emf-form restp
- &rest required-args+rest-arg)
- (unless (constantp restp)
- (error "The RESTP argument is not constant."))
- ;; FIXME: The RESTP handling here is confusing and maybe slightly
- ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
- ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
- ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
- (setq restp (constant-form-value restp))
- (with-unique-names (emf)
- `(let ((,emf ,emf-form))
- (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
- (cond ((typep ,emf 'fast-method-call)
- (invoke-fast-method-call ,emf ,@required-args+rest-arg))
- ;; "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 also figure it out by looking
- ;; at it without breaking stride. For the rest of us,
- ;; though: From what the code is doing with .SLOTS. and
- ;; whatnot, evidently it's implementing SLOT-VALUEish and
- ;; GET-SLOT-VALUEish things. Then we can reason backwards
- ;; and conclude that setting EMF to a FIXNUM is an
- ;; optimized way to represent these slot access operations.
- ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let* ((.slots. (get-slots-or-nil
- ,(car required-args+rest-arg)))
- (value (when .slots. (clos-slots-ref .slots. ,emf))))
- (if (eq value +slot-unbound+)
- (slot-unbound-internal ,(car required-args+rest-arg)
- ,emf)
- value)))))
- ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let ((.new-value. ,(car required-args+rest-arg))
- (.slots. (get-slots-or-nil
- ,(cadr required-args+rest-arg))))
- (when .slots.
- (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
- ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
- ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
- ;; there was no explanation and presumably the code is 10+
- ;; years stale, I simply deleted it. -- WHN)
- (t
- (etypecase ,emf
- (method-call
- (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
- (function
- ,(if restp
- `(apply (the function ,emf) ,@required-args+rest-arg)
- `(funcall (the function ,emf)
- ,@required-args+rest-arg)))))))))
+(defun effective-method-optimized-slot-access-clause
+ (emf restp required-args+rest-arg)
+ ;; "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
+ ;; also figure it out by looking at it without breaking stride. For
+ ;; the rest of us, though: From what the code is doing with .SLOTS.
+ ;; and whatnot, evidently it's implementing SLOT-VALUEish and
+ ;; GET-SLOT-VALUEish things. Then we can reason backwards and
+ ;; 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)))
+ (cond ((= 1 length)
+ `((fixnum
+ (let* ((.slots. (get-slots-or-nil
+ ,(car required-args+rest-arg)))
+ (value (when .slots. (clos-slots-ref .slots. ,emf))))
+ (if (eq value +slot-unbound+)
+ (slot-unbound-internal ,(car required-args+rest-arg)
+ ,emf)
+ value)))))
+ ((= 2 length)
+ `((fixnum
+ (let ((.new-value. ,(car required-args+rest-arg))
+ (.slots. (get-slots-or-nil
+ ,(cadr required-args+rest-arg))))
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
+ ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+ ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+ ;; there was no explanation and presumably the code is 10+
+ ;; years stale, I simply deleted it. -- WHN)
+ )))
+
+;;; Before SBCL 0.9.16.7 instead of
+;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
+;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
+;;; 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)
+ (unless (constantp restp)
+ (error "The RESTP argument is not constant."))
+ (setq restp (constant-form-value restp))
+ (with-unique-names (emf-n)
+ `(locally
+ (declare (optimize (sb-c:insert-step-conditions 0)))
+ (let ((,emf-n ,emf))
+ (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))
+ ,@,(unless narrow
+ `(effective-method-optimized-slot-access-clause
+ emf-n restp required-args+rest-arg))
+ (method-call
+ (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))))))))))
+ (def invoke-effective-method-function nil)
+ (def invoke-narrow-effective-method-function t))
(defun invoke-emf (emf args)
(trace-emf-call emf t args)
(apply emf args))))
\f
-(defmacro fast-narrowed-emf (emf)
- ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to dispatch on
- ;; the possibility that EMF might be of type FIXNUM (as an optimized
- ;; representation of a slot accessor). But as far as I (WHN
- ;; 2002-06-11) can tell, it's impossible for such a representation
- ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that
- ;; when called from this context it needn't worry about the FIXNUM
- ;; case, we can keep those cases from being compiled, which is good
- ;; both because it saves bytes and because it avoids annoying type
- ;; mismatch compiler warnings.
- ;;
- ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type system isn't smart
- ;; enough about NOT and intersection types to benefit from a (NOT
- ;; FIXNUM) declaration here. -- WHN 2002-06-12 (FIXME: maybe it is
- ;; now... -- CSR, 2003-06-07)
- ;;
- ;; FIXME: Might the FUNCTION type be omittable here, leaving only
- ;; METHOD-CALLs? Failing that, could this be documented somehow?
- ;; (It'd be nice if the types involved could be understood without
- ;; solving the halting problem.)
- `(the (or function method-call fast-method-call)
- ,emf))
-
(defmacro fast-call-next-method-body ((args next-method-call rest-arg)
method-name-declaration
cnm-args)
`(if ,next-method-call
- ,(let ((call `(invoke-effective-method-function
- (fast-narrowed-emf ,next-method-call)
+ ,(let ((call `(invoke-narrow-effective-method-function
+ ,next-method-call
,(not (null rest-arg))
,@args
,@(when rest-arg `(,rest-arg)))))
,@body)
`(flet (,@(when call-next-method-p
`((call-next-method (&rest cnm-args)
- (declare (muffle-conditions code-deletion-note))
+ (declare (muffle-conditions code-deletion-note)
+ (optimize (sb-c:insert-step-conditions 0)))
,@(if (safe-code-p env)
`((%check-cnm-args cnm-args (list ,@args)
',method-name-declaration))
,method-name-declaration
cnm-args))))
,@(when next-method-p-p
- `((next-method-p
- ()
+ `((next-method-p ()
+ (declare (optimize (sb-c:insert-step-conditions 0)))
(not (null ,next-method-call))))))
(let ,rebindings
,@(when rebindings `((declare (ignorable ,@all-params))))
return tail))
(defun walk-method-lambda (method-lambda required-parameters env slots calls)
- (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD
- ; should be in the method definition
- (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD
- ; was seen in the body of a method
- (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P
- ; should be in the method definition
- (setq-p nil))
+ (let (;; flag indicating that CALL-NEXT-METHOD should be in the
+ ;; method definition
+ (call-next-method-p nil)
+ ;; flag indicating that #'CALL-NEXT-METHOD was seen in the
+ ;; body of a method
+ (closurep nil)
+ ;; flag indicating that NEXT-METHOD-P should be in the method
+ ;; definition
+ (next-method-p-p nil)
+ ;; a list of all required parameters whose bindings might be
+ ;; modified in the method body.
+ (parameters-setqd nil))
(flet ((walk-function (form context env)
(cond ((not (eq context :eval)) form)
;; FIXME: Jumping to a conclusion from the way it's used
;; force method doesn't really cost much; a little
;; loss of discrimination over IGNORED variables
;; should be all. -- CSR, 2004-07-01
- (setq setq-p t)
+ ;;
+ ;; As of 2006-09-18 modified parameter bindings
+ ;; are now tracked with more granularity than just
+ ;; one SETQ-P flag, in order to disable SLOT-VALUE
+ ;; optimizations for parameters that are SETQd.
+ ;; The old binary SETQ-P flag is still used for
+ ;; all other purposes, since as noted above, the
+ ;; extra cost is minimal. -- JES, 2006-09-18
+ ;;
+ ;; The walker will split (SETQ A 1 B 2) to
+ ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
+ ;; only need to handle the simple case of SETQ
+ ;; here.
+ (let ((vars (if (eq (car form) 'setq)
+ (list (second form))
+ (second form))))
+ (dolist (var vars)
+ ;; Note that we don't need to check for
+ ;; %VARIABLE-REBINDING declarations like is
+ ;; done in CAN-OPTIMIZE-ACCESS1, since the
+ ;; bindings that will have that declation will
+ ;; never be SETQd.
+ (when (var-declaration '%class var env)
+ ;; If a parameter binding is shadowed by
+ ;; another binding it won't have a %CLASS
+ ;; declaration anymore, and this won't get
+ ;; executed.
+ (pushnew var parameters-setqd))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
((and (memq (car form)
'(slot-value set-slot-value slot-boundp))
(constantp (caddr form)))
- (let ((parameter (can-optimize-access form
- required-parameters
- env)))
+ (let ((parameter (can-optimize-access form
+ required-parameters
+ env)))
(let ((fun (ecase (car form)
(slot-value #'optimize-slot-value)
(set-slot-value #'optimize-set-slot-value)
call-next-method-p
closurep
next-method-p-p
- setq-p)))))
+ (not (null parameters-setqd))
+ parameters-setqd)))))
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
arglist
&rest initargs)
(let* (;; we don't need to deal with the :generic-function-class
- ;; argument here because the default,
- ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
- ;; functions. (See REAL-ADD-NAMED-METHOD)
+ ;; argument here because the default,
+ ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
+ ;; functions. (See REAL-ADD-NAMED-METHOD)
(gf (ensure-generic-function generic-function-name))
(existing
(dolist (m (early-gf-methods gf))
projects / sbcl.git / blobdiff