Changeset 7839

Timestamp:

Dec 6, 2007, 8:32:49 PM (17 years ago)

Author:

Bill St. Clair

Message:

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
cached.

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
*eql-combined-method-hash-table-threshold*.

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.

File:

• branches/working-0711/ccl/level-1/l1-dcode.lisp (modified) (7 diffs)

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

@@ -186 +186 @@
    Returns NIL - without storing anything - if the value already in DT
    at INDEX is non-NIL at the time of the store."
-  (%store-node-conditional (+ (ash (%i+ index %gf-dispatch-table-first-data)
-                                   target::word-shift)
-                              target::misc-data-offset)
-                           dt nil new))
+  (let ((offset (+ (ash (%i+ index %gf-dispatch-table-first-data)
+                        target::word-shift)
+                   target::misc-data-offset)))
+    (or (%store-node-conditional offset dt nil new)
+        (%store-node-conditional offset dt *gf-dispatch-bug* new))))
 
 (defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p)
@@ -682 +683 @@
                 (setf contains-obsolete-wrappers-p t
                       (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
-                      (%gf-dispatch-table-ref dt (1+ index))
-                      #'(lambda (&rest rest) 
-                          (declare (ignore rest))
-                          (error "Generic-function dispatch bug.")))
+                      (%gf-dispatch-table-ref dt (1+ index)) *gf-dispatch-bug*)
                 (setq count (%i+ count 1)))))
           (setq index (%i+ index 2)))
@@ -854 +852 @@
         (combined-method (compute-1st-arg-combined-method gf arg wrapper)))
     (multiple-value-bind (index obsolete-wrappers-p)
-                         (find-gf-dispatch-table-index table wrapper)
+        (find-gf-dispatch-table-index table wrapper)
       (if index
-        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
-          (setf (%gf-dispatch-table-ref table index) wrapper))
-        (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
+          (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
+            (setf (%gf-dispatch-table-ref table index) wrapper))
+          (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
     combined-method))
 
@@ -1249 +1247 @@
        wrapper)
     (multiple-value-bind (index obsolete-wrappers-p)
-        ( find-gf-dispatch-table-index table wrapper)
+        (find-gf-dispatch-table-index table wrapper)
       (if index
         (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
-           (setf (%gf-dispatch-table-ref table index) wrapper))
+          (setf (%gf-dispatch-table-ref table index) wrapper))
         (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
     (if sub-dispatch?
@@ -1336 +1334 @@
 
 
-
-;;; This needs to be updated to use a linear search in a vector changing to
-;;; a hash table when the number of entries crosses some threshold.
+(defun compute-eql-combined-method-hash-table-threshold (&optional (iters 1000000) (max 200))
+  (flet ((time-assq (cnt iters)
+           (let ((alist (loop for i from 1 to cnt collect (cons i i)))
+                 (start-time (get-internal-run-time))
+                 (j 0)
+                 res)
+             (declare (fixnum j))
+             (dotimes (i iters)
+               (declare (fixnum i))
+               (setq res (cdr (assq j alist)))
+               (when (>= (incf j) cnt) (setq j 0)))
+             (values (- (get-internal-run-time) start-time) res)))
+         (time-hash (cnt iters)
+           (let ((hash (make-hash-table :test 'eq))
+                 start-time
+                 (j 0)
+                 res)
+             (declare (fixnum j))
+             (dotimes (i cnt)
+               (setf (gethash i hash) i))
+             (assert-hash-table-readonly hash)
+             (setq start-time (get-internal-run-time))
+             (dotimes (i iters)
+               (declare (fixnum i))
+               (setq res (gethash i hash))
+               (when (>= (incf j) cnt) (setq j 0)))
+             (values (- (get-internal-run-time) start-time) res))))
+    (dotimes (i max)
+      (let ((time-assq (time-assq i iters))
+            (time-hash (time-hash i iters)))
+        (format t "i: ~d, assq: ~d, hash: ~d~%" i time-assq time-hash)
+        (when (> time-assq time-hash) (return i))))))
+
+;; Value computed on a dual-core 2.4 GHz AMD Opteron running FC3
+;; This isn't the result of compute-eql-combined-method-hash-table-threshold,
+;; it's the value at which assq takes 3/4 the time of hash, which weights
+;; towards the worst case of the eql method, not the average for uniform inputs.
+(defparameter *eql-combined-method-hash-table-threshold* 45)
+
+;;; A vector might be a little faster than an alist, but the hash table case
+;;; will speed up large numbers of methods.
 (defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional
                                              (method-combination *standard-method-combination*))
@@ -1408 +1444 @@
                                real-gf method-combination methods)))))
       (if eql-method-alist
-        (%cons-combined-method 
-         gf (cons argnum (cons eql-method-alist default-method))
-         (if can-use-eq? 
-           #'%%assq-combined-method-dcode
-           #'%%assoc-combined-method-dcode))
+        (if (> (length eql-method-alist) *eql-combined-method-hash-table-threshold*)
+          (let ((hash (make-hash-table :test (if can-use-eq? 'eq 'eql))))
+            (dolist (pair eql-method-alist)
+              (setf (gethash (car pair) hash) (cdr pair)))
+            (assert-hash-table-readonly hash)
+            (%cons-combined-method 
+             gf (cons argnum (cons hash default-method))
+             #'%%hash-table-combined-method-dcode))
+          (%cons-combined-method
+           gf (cons argnum (cons eql-method-alist default-method))
+           (if can-use-eq? 
+               #'%%assq-combined-method-dcode
+               #'%%assoc-combined-method-dcode)))
         default-method))))
-
-
 
 
@@ -1460 +1502 @@
           (%apply-lexpr (cdr thing) args)
           (%apply-lexpr (cddr stuff) args))))))
+
+
+(defun %%hash-table-combined-method-dcode (stuff args)
+  ;; stuff is (argnum eql-hash-table . default-method)
+  ;(declare (dynamic-extent args))
+  (if (listp args)
+    (let* ((args-len (list-length args))
+           (argnum (car stuff)))
+      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
+      (let* ((arg (nth argnum args)))
+        (apply (gethash arg (cadr stuff) (cddr stuff)) args)))
+    (let* ((args-len (%lexpr-count args))
+           (argnum (car stuff)))
+      (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff))))
+      (let* ((arg (%lexpr-ref args args-len argnum)))
+        (%apply-lexpr (gethash arg (cadr stuff) (cddr stuff)) args)))))