X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=6d8c52cc045eb485b5707cd5a952fe8cb90f2b1c;hb=b1a1d1280f0003e0d5af9996274c95a78f188b37;hp=be9bfbdcaba05a3badd580f9f15c50630a2fdeac;hpb=832f3b5652ae1b4a8888829cd4a1b391a8ca9952;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index be9bfbd..6d8c52c 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,13 +649,18 @@ 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) '(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, ~ @@ -741,7 +750,8 @@ bootstrapping. (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 @@ -758,9 +768,9 @@ bootstrapping. (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 @@ -768,7 +778,7 @@ bootstrapping. (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))) @@ -793,7 +803,14 @@ bootstrapping. :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 @@ -905,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)) @@ -962,64 +1007,91 @@ 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))) - -(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))))))))) + (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) + ;; "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))) + (cond ((= 1 length) + `((fixnum + (let* ((.slots. (get-slots-or-nil + ,(car required-args))) + (value (when .slots. (clos-slots-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args) + ,emf) + value))))) + ((= 2 length) + `((fixnum + (let ((.new-value. ,(car required-args)) + (.slots. (get-slots-or-nil + ,(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 + ;; ...) 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 &key required-args rest-arg more-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 + ,(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)) + (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) @@ -1029,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))) @@ -1091,38 +1161,15 @@ bootstrapping. (apply emf args)))) -(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))))) + :required-args ,args + :rest-arg ,(when rest-arg (list rest-arg))))) `(if ,cnm-args (bind-args ((,@args ,@(when rest-arg @@ -1153,7 +1200,8 @@ bootstrapping. ,@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)) @@ -1164,8 +1212,8 @@ bootstrapping. ,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)))) @@ -1227,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))))))) @@ -1257,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)))))))) @@ -1284,13 +1332,18 @@ bootstrapping. 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 @@ -1314,7 +1367,34 @@ bootstrapping. ;; 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) @@ -1329,31 +1409,29 @@ bootstrapping. ((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) (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 - setq-p))))) + (not (null parameters-setqd)) + parameters-setqd))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) @@ -1532,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) @@ -2014,11 +2096,12 @@ bootstrapping. fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) + (generic-function-class 'standard-generic-function) &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) + ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS, + ;; which is what makes the next line work + (unless (eq (class-of existing) generic-function-class) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) @@ -2200,7 +2283,11 @@ bootstrapping. specializers arglist &rest initargs) - (let* ((gf (ensure-generic-function generic-function-name)) + (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) + (gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) (when (and (equal (early-method-specializers m) specializers)