Changeset 7839

Dec 7, 2007, 4:32:49 AM (13 years ago)

Optimize generic functions with lots of same-type EQL methods
by using a hash table intead of an alist to look up the EQL arg.

Fix a bug in the code that prevented two threads from overwriting the
same generic function dispatch table entry at the same time. This bug
could cause redefining a method to forevermore slow down generic
function dispatch on arguments that hashed to the same place in its
generic function dispatch table. The effective method would never be

There's still some room for optimization of EQL methods. We could use
an array instead of an alist, which would cut the number of memory
references in half and make them more local. If all the methods on a
generic function are EQL methods on values of the same type, instead
of going through %%1st-arg-dcode to get to the EQL combined method, we
could go directly to the EQL combined method.

%gf-dispatch-table-store-conditional overwrites nil or
*gf-dispatch-bug*, not just nil.

grow-gf-dispatch-table uses *gf-dispatch-bug*, not another identical
in-line anonymous function.

compute-eql-combined-method-hash-table-threshold helps in determining
at which point it's faster to use a hash table than an alist for EQL
method dispatch. There are no callers of this function, but it's there
to aid determination of the value for

make-eql-combined-method now creates a hash table and uses
%%hash-table-combined-method-code if there are more than
*eql-combined-method-hash-table-threshold* methods.

%%hash-table-combined-method-dcode works the same as
%%assq-combined-method-dcode and %%assoc-combined-method-dcode, but
with a hash table instead of an alist as the dictionary that maps
the EQL arg to its effective method.

1 edited


  • branches/working-0711/ccl/level-1/l1-dcode.lisp

    r7837 r7839  
    186186   Returns NIL - without storing anything - if the value already in DT
    187187   at INDEX is non-NIL at the time of the store."
    188   (%store-node-conditional (+ (ash (%i+ index %gf-dispatch-table-first-data)
    189                                    target::word-shift)
    190                               target::misc-data-offset)
    191                            dt nil new))
     188  (let ((offset (+ (ash (%i+ index %gf-dispatch-table-first-data)
     189                        target::word-shift)
     190                   target::misc-data-offset)))
     191    (or (%store-node-conditional offset dt nil new)
     192        (%store-node-conditional offset dt *gf-dispatch-bug* new))))
    193194(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p)
    682683                (setf contains-obsolete-wrappers-p t
    683684                      (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
    684                       (%gf-dispatch-table-ref dt (1+ index))
    685                       #'(lambda (&rest rest)
    686                           (declare (ignore rest))
    687                           (error "Generic-function dispatch bug.")))
     685                      (%gf-dispatch-table-ref dt (1+ index)) *gf-dispatch-bug*)
    688686                (setq count (%i+ count 1)))))
    689687          (setq index (%i+ index 2)))
    854852        (combined-method (compute-1st-arg-combined-method gf arg wrapper)))
    855853    (multiple-value-bind (index obsolete-wrappers-p)
    856                          (find-gf-dispatch-table-index table wrapper)
     854        (find-gf-dispatch-table-index table wrapper)
    857855      (if index
    858         (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
    859           (setf (%gf-dispatch-table-ref table index) wrapper))
    860         (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
     856          (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
     857            (setf (%gf-dispatch-table-ref table index) wrapper))
     858          (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
    861859    combined-method))
    12491247       wrapper)
    12501248    (multiple-value-bind (index obsolete-wrappers-p)
    1251         ( find-gf-dispatch-table-index table wrapper)
     1249        (find-gf-dispatch-table-index table wrapper)
    12521250      (if index
    12531251        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
    1254            (setf (%gf-dispatch-table-ref table index) wrapper))
     1252          (setf (%gf-dispatch-table-ref table index) wrapper))
    12551253        (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
    12561254    (if sub-dispatch?
    1339 ;;; This needs to be updated to use a linear search in a vector changing to
    1340 ;;; a hash table when the number of entries crosses some threshold.
     1336(defun compute-eql-combined-method-hash-table-threshold (&optional (iters 1000000) (max 200))
     1337  (flet ((time-assq (cnt iters)
     1338           (let ((alist (loop for i from 1 to cnt collect (cons i i)))
     1339                 (start-time (get-internal-run-time))
     1340                 (j 0)
     1341                 res)
     1342             (declare (fixnum j))
     1343             (dotimes (i iters)
     1344               (declare (fixnum i))
     1345               (setq res (cdr (assq j alist)))
     1346               (when (>= (incf j) cnt) (setq j 0)))
     1347             (values (- (get-internal-run-time) start-time) res)))
     1348         (time-hash (cnt iters)
     1349           (let ((hash (make-hash-table :test 'eq))
     1350                 start-time
     1351                 (j 0)
     1352                 res)
     1353             (declare (fixnum j))
     1354             (dotimes (i cnt)
     1355               (setf (gethash i hash) i))
     1356             (assert-hash-table-readonly hash)
     1357             (setq start-time (get-internal-run-time))
     1358             (dotimes (i iters)
     1359               (declare (fixnum i))
     1360               (setq res (gethash i hash))
     1361               (when (>= (incf j) cnt) (setq j 0)))
     1362             (values (- (get-internal-run-time) start-time) res))))
     1363    (dotimes (i max)
     1364      (let ((time-assq (time-assq i iters))
     1365            (time-hash (time-hash i iters)))
     1366        (format t "i: ~d, assq: ~d, hash: ~d~%" i time-assq time-hash)
     1367        (when (> time-assq time-hash) (return i))))))
     1369;; Value computed on a dual-core 2.4 GHz AMD Opteron running FC3
     1370;; This isn't the result of compute-eql-combined-method-hash-table-threshold,
     1371;; it's the value at which assq takes 3/4 the time of hash, which weights
     1372;; towards the worst case of the eql method, not the average for uniform inputs.
     1373(defparameter *eql-combined-method-hash-table-threshold* 45)
     1375;;; A vector might be a little faster than an alist, but the hash table case
     1376;;; will speed up large numbers of methods.
    13411377(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
    13421378                                             (method-combination *standard-method-combination*))
    14081444                               real-gf method-combination methods)))))
    14091445      (if eql-method-alist
    1410         (%cons-combined-method
    1411          gf (cons argnum (cons eql-method-alist default-method))
    1412          (if can-use-eq?
    1413            #'%%assq-combined-method-dcode
    1414            #'%%assoc-combined-method-dcode))
     1446        (if (> (length eql-method-alist) *eql-combined-method-hash-table-threshold*)
     1447          (let ((hash (make-hash-table :test (if can-use-eq? 'eq 'eql))))
     1448            (dolist (pair eql-method-alist)
     1449              (setf (gethash (car pair) hash) (cdr pair)))
     1450            (assert-hash-table-readonly hash)
     1451            (%cons-combined-method
     1452             gf (cons argnum (cons hash default-method))
     1453             #'%%hash-table-combined-method-dcode))
     1454          (%cons-combined-method
     1455           gf (cons argnum (cons eql-method-alist default-method))
     1456           (if can-use-eq?
     1457               #'%%assq-combined-method-dcode
     1458               #'%%assoc-combined-method-dcode)))
    14151459        default-method))))
    14601502          (%apply-lexpr (cdr thing) args)
    14611503          (%apply-lexpr (cddr stuff) args))))))
     1506(defun %%hash-table-combined-method-dcode (stuff args)
     1507  ;; stuff is (argnum eql-hash-table . default-method)
     1508  ;(declare (dynamic-extent args))
     1509  (if (listp args)
     1510    (let* ((args-len (list-length args))
     1511           (argnum (car stuff)))
     1512      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
     1513      (let* ((arg (nth argnum args)))
     1514        (apply (gethash arg (cadr stuff) (cddr stuff)) args)))
     1515    (let* ((args-len (%lexpr-count args))
     1516           (argnum (car stuff)))
     1517      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
     1518      (let* ((arg (%lexpr-ref args args-len argnum)))
     1519        (%apply-lexpr (gethash arg (cadr stuff) (cddr stuff)) args)))))
Note: See TracChangeset for help on using the changeset viewer.