Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp, 1.145, 1.146 combin.lisp, 1.32, 1.33 dlisp.lisp, 1.27, 1.28 methods.lisp, 1.76, 1.77 slots-boot.lisp, 1.39, 1.40 vector.lisp, 1.56, 1.57
|
From: Nikodemus S. <de...@us...> - 2007-09-08 15:15:52
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30715/src/pcl Modified Files: boot.lisp combin.lisp dlisp.lisp methods.lisp slots-boot.lisp vector.lisp Log Message: 1.0.9.43: .PV-CELL., use .PV. directly * Now that .CALLS. are gone we can get rid of the extra indirection. (Maybe we have to add it back later, but worry about that then.) * Since .PV. is magical, also localize its bindings to vector.lisp, instead of exposing the variable in PV-BINDING1's interface (which is used elsewhere as well.) Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.145 retrieving revision 1.146 diff -u -d -r1.145 -r1.146 --- boot.lisp 8 Sep 2007 14:38:03 -0000 1.145 +++ boot.lisp 8 Sep 2007 15:15:45 -0000 1.146 @@ -1015,7 +1015,7 @@ (defstruct (fast-method-call (:copier nil)) (function #'identity :type function) - pv-cell + pv next-method-call arg-info) (defstruct (constant-fast-method-call @@ -1032,7 +1032,7 @@ (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-pv ,method-call) (fast-method-call-next-method-call ,method-call) ,@required-args+rest-arg)) @@ -1042,7 +1042,7 @@ &rest required-args) (macrolet ((generate-call (n) ``(funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) + (fast-method-call-pv ,method-call) (fast-method-call-next-method-call ,method-call) ,@required-args ,@(loop for x below ,n @@ -1056,7 +1056,7 @@ (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-pv ,method-call)) (values (fast-method-call-next-method-call ,method-call)) ,@required-args (sb-c::%more-arg-values ,more-context 0 ,more-count)))))) @@ -1204,7 +1204,7 @@ (nreq (car arg-info))) (if restp (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) + (fast-method-call-pv emf) (fast-method-call-next-method-call emf) args) (cond ((null args) @@ -1227,7 +1227,7 @@ :format-arguments nil))) (t (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) + (fast-method-call-pv emf) (fast-method-call-next-method-call emf) args)))))) (method-call Index: combin.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/combin.lisp,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- combin.lisp 10 May 2007 11:29:11 -0000 1.32 +++ combin.lisp 8 Sep 2007 15:15:45 -0000 1.33 @@ -36,9 +36,9 @@ (let* ((pv-wrappers (when pv-table (pv-wrappers-from-all-wrappers pv-table wrappers))) - (pv-cell (when (and pv-table pv-wrappers) - (pv-table-lookup pv-table pv-wrappers)))) - (values mf t fmf pv-cell)) + (pv (when (and pv-table pv-wrappers) + (pv-table-lookup pv-table pv-wrappers)))) + (values mf t fmf pv)) (values (or mf (if (listp method) (bug "early method with no method-function") @@ -120,7 +120,7 @@ (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) - (multiple-value-bind (mf real-mf-p fmf pv-cell) + (multiple-value-bind (mf real-mf-p fmf pv) (get-method-function method method-alist wrappers) (if fmf (let* ((next-methods (car cm-args)) @@ -132,10 +132,10 @@ (default (cons nil nil)) (value (method-plist-value method :constant-value default))) (if (eq value default) - (make-fast-method-call :function fmf :pv-cell pv-cell + (make-fast-method-call :function fmf :pv pv :next-method-call next :arg-info arg-info) (make-constant-fast-method-call - :function fmf :pv-cell pv-cell :next-method-call next + :function fmf :pv pv :next-method-call next :arg-info arg-info :value value))) (if real-mf-p (flet ((frob-cm-arg (arg) @@ -232,8 +232,8 @@ (long-method-combination-args-lambda-list combin)))))) (cond (error-p - `(lambda (.pv-cell. .next-method-call. &rest .args.) - (declare (ignore .pv-cell. .next-method-call.)) + `(lambda (.pv. .next-method-call. &rest .args.) + (declare (ignore .pv. .next-method-call.)) (declare (ignorable .args.)) (flet ((%no-primary-method (gf args) (apply #'no-primary-method gf args)) @@ -251,14 +251,14 @@ .dfun-more-count.))) `(list ,@required)))) `(lambda ,ll - (declare (ignore .pv-cell. .next-method-call.)) + (declare (ignore .pv. .next-method-call.)) (let ((.gf-args. ,gf-args)) (declare (ignorable .gf-args.)) ,@check-applicable-keywords ,effective-method)))) (t `(lambda ,ll - (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) + (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.)))) ,@check-applicable-keywords ,effective-method)))))) Index: dlisp.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/dlisp.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- dlisp.lisp 29 May 2007 15:31:48 -0000 1.27 +++ dlisp.lisp 8 Sep 2007 15:15:45 -0000 1.28 @@ -101,7 +101,7 @@ '(.dfun-more-context. .dfun-more-count.))))) (defun make-fast-method-call-lambda-list (nargs applyp) - (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp))) + (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp))) ;;; Emitting various accessors. Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.76 retrieving revision 1.77 diff -u -d -r1.76 -r1.77 --- methods.lisp 18 Jun 2007 16:15:54 -0000 1.76 +++ methods.lisp 8 Sep 2007 15:15:45 -0000 1.77 @@ -1360,7 +1360,7 @@ (get-fun1 `(lambda ,arglist ,@(unless function-p - `((declare (ignore .pv-cell. .next-method-call.)))) + `((declare (ignore .pv. .next-method-call.)))) (locally (declare #.*optimize-speed*) (let ((emf ,net)) ,(make-emf-call nargs applyp 'emf)))) Index: slots-boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- slots-boot.lisp 8 Sep 2007 14:38:03 -0000 1.39 +++ slots-boot.lisp 8 Sep 2007 15:15:45 -0000 1.40 @@ -459,8 +459,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-read-internal .pv. instance-slots 0 (slot-value instance slot-name)))))))) @@ -488,15 +488,15 @@ (make-method-function (lambda (nv instance) (funcall check-fun nv instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))) (make-method-function (lambda (nv instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))))))) @@ -509,8 +509,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-boundp-internal .pv. instance-slots 0 (slot-boundp instance slot-name)))))))) Index: vector.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v retrieving revision 1.56 retrieving revision 1.57 diff -u -d -r1.56 -r1.57 --- vector.lisp 8 Sep 2007 14:38:03 -0000 1.56 +++ vector.lisp 8 Sep 2007 15:15:45 -0000 1.57 @@ -159,8 +159,7 @@ (unless (listp wrappers) (setq wrappers (list wrappers))) (let (elements) - (dolist (slot-names slot-name-lists - (make-permutation-vector (nreverse elements))) + (dolist (slot-names slot-name-lists) (when slot-names (let* ((wrapper (pop wrappers)) (std-p (typep wrapper 'wrapper)) @@ -170,10 +169,12 @@ (push (if std-p (compute-pv-slot slot-name wrapper class class-slots) nil) - elements))))))) - -(defun make-permutation-vector (indexes) - (make-array (length indexes) :initial-contents indexes)) + elements))))) + (let* ((n (length elements)) + (pv (make-array n))) + (loop for i from (1- n) downto 0 + do (setf (svref pv i) (pop elements))) + pv))) (defun pv-table-lookup (pv-table pv-wrappers) (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) @@ -187,13 +188,12 @@ (if hitp value (let* ((pv (compute-pv slot-name-lists pv-wrappers)) - (pv-cell (cons pv nil)) - (new-cache (fill-cache cache pv-wrappers pv-cell))) + (new-cache (fill-cache cache pv-wrappers pv))) ;; This is safe: if another thread races us here the loser just ;; misses the next time as well. (unless (eq new-cache cache) (setf (pv-table-cache pv-table) new-cache)) - pv-cell))))) + pv))))) (defun make-pv-type-declaration (var) `(type simple-vector ,var)) @@ -244,8 +244,8 @@ (incf map-index)) (incf param-index))) (when cache - (map-cache (lambda (wrappers pv-cell) - (update-slots-in-pv wrappers (car pv-cell) + (map-cache (lambda (wrappers pv) + (update-slots-in-pv wrappers pv cwrapper pv-size pv-map)) cache)))))) @@ -647,13 +647,13 @@ do (when slots (push required-parameter pv-parameters) (push (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. ,pv-table-form + `(pv-binding1 (,pv-table-form ,(nreverse pv-parameters) ,(nreverse slot-vars)) ,@body))) -(defmacro pv-binding1 ((pv pv-table-form pv-parameters slot-vars) +(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars) &body body) - `(pv-env (,pv ,pv-table-form ,pv-parameters) + `(pv-env (,pv-table-form ,pv-parameters) (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) slot-vars pv-parameters)) (declare (ignorable ,@(mapcar #'identity slot-vars))) @@ -664,18 +664,15 @@ (define-symbol-macro pv-env-environment overridden) (defmacro pv-env (&environment env - (pv pv-table-form pv-parameters) + (pv-table-form pv-parameters) &rest forms) ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT ;; symbol-macrolet. (if (eq (macroexpand 'pv-env-environment env) 'default) - `(let ((,pv (car .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - ,@forms) + `(locally ,@forms) `(let* ((.pv-table. ,pv-table-form) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) + (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))) + (declare ,(make-pv-type-declaration '.pv.)) ,@forms))) (defvar *non-var-declarations* @@ -902,9 +899,9 @@ ;; function name (list (cons 'fast-method (body-method-name body)))) ;; The lambda-list of the FMF - (.pv-cell. .next-method-call. ,@fmf-lambda-list) + (.pv. .next-method-call. ,@fmf-lambda-list) ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.) + (declare (ignorable .pv. .next-method-call.) (disable-package-locks pv-env-environment)) ,@outer-decls (symbol-macrolet ((pv-env-environment default)) @@ -935,8 +932,8 @@ (restp (cdr arg-info))) (setq method-function (lambda (method-args next-methods) - (let* ((pv-cell (when pv-table - (get-pv-cell method-args pv-table))) + (let* ((pv (when pv-table + (get-pv method-args pv-table))) (nm (car next-methods)) (nms (cdr next-methods)) (nmc (when nm @@ -945,7 +942,7 @@ (method-function nm) nm) :call-method-args (list nms))))) - (apply fmf pv-cell nmc method-args)))) + (apply fmf pv nmc method-args)))) ;; FIXME: this looks dangerous. (let* ((fname (%fun-name fmf))) (when (and fname (eq (car fname) 'fast-method)) @@ -958,7 +955,7 @@ ;;; over the actual PV-CELL in this case. (defun method-function-from-fast-method-call (fmc) (let* ((fmf (fast-method-call-function fmc)) - (pv-cell (fast-method-call-pv-cell fmc)) + (pv (fast-method-call-pv fmc)) (arg-info (fast-method-call-arg-info fmc)) (nreq (car arg-info)) (restp (cdr arg-info))) @@ -971,9 +968,9 @@ (method-function nm) nm) :call-method-args (list nms))))) - (apply fmf pv-cell nmc method-args))))) + (apply fmf pv nmc method-args))))) -(defun get-pv-cell (method-args pv-table) +(defun get-pv (method-args pv-table) (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) (when pv-wrappers (pv-table-lookup pv-table pv-wrappers)))) |