Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp, 1.144, 1.145 slots-boot.lisp, 1.38, 1.39 vector.lisp, 1.55, 1.56
|
From: Nikodemus S. <de...@us...> - 2007-09-08 14:38:07
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15169/src/pcl Modified Files: boot.lisp slots-boot.lisp vector.lisp Log Message: 1.0.9.42: remove stale CALLS support * Permutation vector code contained infrastructure for optimizing GF calls inside method bodies in a similar manner as slot accesses are optimized, but this support was never finished. While it would be nice to have it, right now clarity of the code seems like a higher priority -- it seems to be simple enough to reinstate when we want, and the end result is liable to be easier to understand. * Add a big FIXME with a short explanation of the optimization and a pointer to this commit. Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.144 retrieving revision 1.145 diff -u -d -r1.144 -r1.145 --- boot.lisp 27 Aug 2007 15:47:55 -0000 1.144 +++ boot.lisp 8 Sep 2007 14:38:03 -0000 1.145 @@ -617,7 +617,6 @@ parameters specializers)) (slots (mapcar #'list required-parameters)) - (calls (list nil)) (class-declarations `(declare ;; These declarations seem to be used by PCL to pass @@ -692,29 +691,24 @@ (walk-method-lambda method-lambda required-parameters env - slots - calls) + slots) (multiple-value-bind (walked-lambda-body walked-declarations walked-documentation) (parse-body (cddr walked-lambda)) (declare (ignore walked-documentation)) (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) + (let ((slot-name-lists (slot-name-lists-from-slots slots))) (setq plist `(,@(when slot-name-lists `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) ,@plist)) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists (load-time-value (intern-pv-table - :slot-name-lists ',slot-name-lists - :call-list ',call-list))) + :slot-name-lists ',slot-name-lists))) ,@walked-lambda-body))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) @@ -1439,7 +1433,7 @@ when (eq key keyword) return tail)) -(defun walk-method-lambda (method-lambda required-parameters env slots calls) +(defun walk-method-lambda (method-lambda required-parameters env slots) (let (;; flag indicating that CALL-NEXT-METHOD should be in the ;; method definition (call-next-method-p nil) @@ -1619,11 +1613,10 @@ (set-fun-name mff fast-name)))) (when plist (let ((plist plist)) - (let ((snl (getf plist :slot-name-lists)) - (cl (getf plist :call-list))) - (when (or snl cl) + (let ((snl (getf plist :slot-name-lists))) + (when snl (setf (method-plist-value method :pv-table) - (intern-pv-table :slot-name-lists snl :call-list cl)))))))) + (intern-pv-table :slot-name-lists snl)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? Index: slots-boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- slots-boot.lisp 29 Aug 2007 16:02:37 -0000 1.38 +++ slots-boot.lisp 8 Sep 2007 14:38:03 -0000 1.39 @@ -459,8 +459,7 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") + (pv-binding1 (.pv. (bug "Please report this") (instance) (instance-slots)) (instance-read-internal .pv. instance-slots 0 @@ -489,16 +488,14 @@ (make-method-function (lambda (nv instance) (funcall check-fun nv instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") + (pv-binding1 (.pv. (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. .calls. - (bug "Please report this") + (pv-binding1 (.pv. (bug "Please report this") (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv @@ -512,8 +509,7 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") + (pv-binding1 (.pv. (bug "Please report this") (instance) (instance-slots)) (instance-boundp-internal .pv. instance-slots 0 Index: vector.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v retrieving revision 1.55 retrieving revision 1.56 diff -u -d -r1.55 -r1.56 --- vector.lisp 27 Aug 2007 15:31:38 -0000 1.55 +++ vector.lisp 8 Sep 2007 14:38:03 -0000 1.56 @@ -24,6 +24,18 @@ ;;;; specification. (in-package "SB-PCL") + +;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation +;;;; for optimizing GF calls inside method bodies using a PV approach, +;;;; inherited from the original PCL. This was never completed, and +;;;; was removed at that point to make the code easier to understand +;;;; -- but: +;;;; +;;;; FIXME: It would be possible to optimize GF calls inside method +;;;; bodies using permutation vectors: if all the arguments to the +;;;; GF are specializers parameters, we can assign a permutation index +;;;; to each such (GF . ARGS) tuple inside a method body, and use this +;;;; to cache effective method functions. (defmacro instance-slot-index (wrapper slot-name) `(let ((pos 0)) @@ -35,12 +47,11 @@ (defstruct (pv-table (:predicate pv-tablep) (:constructor make-pv-table-internal - (slot-name-lists call-list)) + (slot-name-lists)) (:copier nil)) (cache nil :type (or cache null)) (pv-size 0 :type fixnum) - (slot-name-lists nil :type list) - (call-list nil :type list)) + (slot-name-lists nil :type list)) #-sb-fluid (declaim (sb-ext:freeze-type pv-table)) @@ -54,8 +65,8 @@ ;;; (defvar *all-pv-table-list* nil) (declaim (inline make-pv-table)) -(defun make-pv-table (&key slot-name-lists call-list) - (make-pv-table-internal slot-name-lists call-list)) +(defun make-pv-table (&key slot-name-lists) + (make-pv-table-internal slot-name-lists)) (defun make-pv-table-type-declaration (var) `(type pv-table ,var)) @@ -66,30 +77,24 @@ ;;; Entries in this are lists of (table . pv-offset-list). (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) -(defun intern-pv-table (&key slot-name-lists call-list) +(defun intern-pv-table (&key slot-name-lists) (let ((new-p nil)) - (flet ((inner (x) - (or (gethash x *slot-name-lists-inner*) - (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) - (outer (x) - (or (gethash x *slot-name-lists-outer*) - (setf (gethash x *slot-name-lists-outer*) - (let ((snl (copy-list (cdr x))) - (cl (car x))) + (flet ((inner (slot-names) + (or (gethash slot-names *slot-name-lists-inner*) + (setf (gethash slot-names *slot-name-lists-inner*) slot-names))) + (outer (snl) + (or (gethash snl *slot-name-lists-outer*) + (setf (gethash snl *slot-name-lists-outer*) + (progn (setq new-p t) - (make-pv-table :slot-name-lists snl - :call-list cl)))))) - (let ((pv-table - (outer (mapcar #'inner (cons call-list slot-name-lists))))) + (make-pv-table :slot-name-lists snl)))))) + (let ((pv-table (outer (mapcar #'inner slot-name-lists)))) (when new-p (let ((pv-index 0)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (note-pv-table-reference slot-name pv-index pv-table) (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) (setf (pv-table-pv-size pv-table) pv-index))) pv-table)))) @@ -167,42 +172,11 @@ nil) elements))))))) -(defun compute-calls (call-list wrappers) - (declare (ignore call-list wrappers)) - #|| - (map 'vector - (lambda (call) - (compute-emf-from-wrappers call wrappers)) - call-list) - ||# - '#()) - -#|| ; Need to finish this, then write the maintenance functions. -(defun compute-emf-from-wrappers (call wrappers) - (when call - (destructuring-bind (gf-name nreq restp arg-info) call - (if (eq gf-name 'make-instance) - (error "should not get here") ; there is another mechanism for this. - (lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) -||# - (defun make-permutation-vector (indexes) (make-array (length indexes) :initial-contents indexes)) (defun pv-table-lookup (pv-table pv-wrappers) (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) - (call-list (pv-table-call-list pv-table)) (cache (or (pv-table-cache pv-table) (setf (pv-table-cache pv-table) (make-cache :key-count (- (length slot-name-lists) @@ -213,8 +187,7 @@ (if hitp value (let* ((pv (compute-pv slot-name-lists pv-wrappers)) - (calls (compute-calls call-list pv-wrappers)) - (pv-cell (cons pv calls)) + (pv-cell (cons pv nil)) (new-cache (fill-cache cache pv-wrappers pv-cell))) ;; This is safe: if another thread races us here the loser just ;; misses the next time as well. @@ -225,15 +198,6 @@ (defun make-pv-type-declaration (var) `(type simple-vector ,var)) -(defmacro copy-pv (pv) - `(copy-seq ,pv)) - -(defun make-calls-type-declaration (var) - `(type simple-vector ,var)) - -(defmacro callsref (calls index) - `(svref ,calls ,index)) - (defvar *pv-table-cache-update-info* nil) (defun update-pv-table-cache-info (class) @@ -604,51 +568,26 @@ ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to ;;; having fewer PV's floating around. Even if the gain is only ;;; modest, it costs nothing. -(defun slot-name-lists-from-slots (slots calls) - (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) +(defun slot-name-lists-from-slots (slots) + (let ((slots (mutate-slots slots))) (let* ((slot-name-lists (mapcar (lambda (parameter-entry) (cons nil (mapcar #'car (cdr parameter-entry)))) - slots)) - (call-list - (mapcar #'car calls))) - (dolist (call call-list) - (dolist (arg (cdr call)) - (when (integerp arg) - (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar (lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) - slot-name-lists)) - (let ((cvt (apply #'vector - (let ((i -1)) - (mapcar (lambda (r+snl) - (when r+snl (incf i))) - slot-name-lists))))) - (setq call-list (mapcar (lambda (call) - (cons (car call) - (mapcar (lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) - call-list))) - (values slot-name-lists call-list)))) + slots))) + (mapcar (lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) + slot-name-lists)))) -(defun mutate-slots-and-calls (slots calls) +(defun mutate-slots (slots) (let ((sorted-slots (sort-slots slots)) - (sorted-calls (sort-calls (cdr calls))) (pv-offset -1)) (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) (incf pv-offset) (dolist (form (cdr slot-entry)) (setf (cadr form) pv-offset)))) - (dolist (call-entry sorted-calls) - (incf pv-offset) - (dolist (form (cdr call-entry)) - (setf (cadr form) pv-offset))) - (values sorted-slots sorted-calls))) + sorted-slots)) (defun symbol-pkg-name (sym) (let ((pkg (symbol-package sym))) @@ -693,8 +632,6 @@ :key #'car))) slots)) -(defun sort-calls (calls) - (sort calls #'symbol-or-cons-lessp :key #'car)) ;;;; This needs to work in terms of metatypes and also needs to work ;;;; for automatically generated reader and writer functions. @@ -710,13 +647,13 @@ do (when slots (push required-parameter pv-parameters) (push (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. .calls. ,pv-table-form + `(pv-binding1 (.pv. ,pv-table-form ,(nreverse pv-parameters) ,(nreverse slot-vars)) ,@body))) -(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars) +(defmacro pv-binding1 ((pv pv-table-form pv-parameters slot-vars) &body body) - `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters) + `(pv-env (,pv ,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))) @@ -727,24 +664,18 @@ (define-symbol-macro pv-env-environment overridden) (defmacro pv-env (&environment env - (pv calls pv-table-form pv-parameters) + (pv 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.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls + `(let ((,pv (car .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) ,@forms) `(let* ((.pv-table. ,pv-table-form) (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) + (,pv (car .pv-cell.))) (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) - ,pv ,calls ,@forms))) (defvar *non-var-declarations* @@ -996,10 +927,9 @@ (defun method-function-from-fast-function (fmf plist) (declare (type function fmf)) (let* ((method-function nil) - (calls (getf plist :call-list)) (snl (getf plist :slot-name-lists)) - (pv-table (when (or calls snl) - (intern-pv-table :call-list calls :slot-name-lists snl))) + (pv-table (when snl + (intern-pv-table :slot-name-lists snl))) (arg-info (getf plist :arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) |