clos: add a reference implementation of the legacy discriminator

This implementation is included for the reference and benchmarks.

src/clos/dispatch.lsp

@@ -9,33 +9,64 @@
 ;;;
 (in-package #:clos)
 
-;;; This discriminator function is included for the reference and benchmarks.
-;;; It doesn't perform any optimizations and always recomputes everything.
-;;;
 ;;; This function is similar to `generic_compute_applicable_method' in C.
+(defun generic-compute-applicable-method (gf args)
+  (declare (si::c-local))
+  (multiple-value-bind (method-list ok)
+      (compute-applicable-methods-using-classes gf (mapcar #'class-of args))
+    (unless ok
+      (setf method-list (compute-applicable-methods gf args)))
+    (and method-list
+         (let ((combin (generic-function-method-combination gf)))
+           (compute-effective-method-function gf combin method-list)))))
+
+;;; This function is similar to `restricted_compute_applicable_method' in C.
+(defun restricted-compute-applicable-method (gf args)
+  (declare (si::c-local))
+  (with-early-accessors (+standard-generic-function-slots+)
+    (let ((method-list (std-compute-applicable-methods gf args)))
+      (and method-list
+           (let ((combin (generic-function-method-combination gf)))
+             (compute-effective-method-function gf combin method-list))))))
+
+;;; This function is similar to `compute_applicable_method' in C.
+(defun compute-applicable-method (gf args)
+  (declare (si::c-local))
+  (if (eq (slot-value (class-of gf) 'name) 'standard-generic-function)
+      (restricted-compute-applicable-method gf args)
+      (generic-compute-applicable-method gf args)))
+
+;;; This is an unoptimized discriminator function that doesn't cache results.
 (defun unoptimized-discriminator (gf)
   (lambda (&rest args)
-    (multiple-value-bind (method-list ok)
-        (compute-applicable-methods-using-classes gf (mapcar #'class-of args))
-      (unless ok
-        (setf method-list (compute-applicable-methods gf args))
-        (unless method-list
-          (apply #'no-applicable-method gf args)))
-      (let* ((combin (generic-function-method-combination gf))
-             (em-fun (compute-effective-method-function gf combin method-list)))
-        (funcall em-fun args nil)))))
+    (if-let ((fn (compute-applicable-method gf args)))
+      (funcall fn args nil)
+      (apply #'no-applicable-method gf args))))
 
-;;; This discriminator function is similar to UNOPTIMIZED-DISCRIMINATOR except
-;;; that uses the fact that the function class is STANDARD-GENERIC-FUNCTION so
-;;; it may use non-generic version of computation functions and it doesn't call
-;;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES[1]. Both behaviors are permissible.
+;;; This discriminator is similar to the discriminator implemented in C. It is
+;;; slower, incomplete and defined only for the purpose of benchmarking against
+;;; other dispatch prototypes written in Lisp and to better understand C code.
 ;;;
-;;; This function is similar to `restricted_compute_applicable_method' in C.
-(defun standard-gf-discriminator (gf)
-  (lambda (&rest args)
-    (let ((method-list (std-compute-applicable-methods gf args)))
-      (unless method-list
-        (apply #'no-applicable-method gf args))
-      (let* ((combin (generic-function-method-combination gf))
-             (em-fun (compute-effective-method-function gf combin method-list)))
-        (funcall em-fun args nil)))))
+;;; Dispatch is around 1x-4x slower than the "native" implementation and this
+;;; code is reasonably simplified. FIXME accessor optimization is missing.
+#+ (or)
+(defun soft-legacy-discriminator (gf)
+  (let ((method-cache (make-hash-table :test #'equal :synchronized t)))
+    (lambda (&rest args)
+      (let ((hash-key
+              ;; GENERIC-FUNCTION-SPEC-LIST is maintained by the function
+              ;; COMPUTE-G-F-SPEC-LIST called on discriminator invalidation.
+              (loop for arg in args
+                    for (spec-class . spec-eql) in (generic-function-spec-list gf)
+                    if (member arg spec-eql)
+                      collect `(eql ,arg) into hash-key
+                    else
+                      collect (class-of arg) into hash-key
+                    finally (return (list* gf hash-key)))))
+        (if-let ((fn (gethash hash-key method-cache)))
+          (funcall fn args nil)
+          (if-let ((fn (compute-applicable-method gf args)))
+            (progn
+              (setf (gethash hash-key method-cache) fn)
+              (funcall fn args nil))
+            (apply #'no-applicable-method gf args)))))))

src/clos/kernel.lsp

@@ -119,11 +119,7 @@
       (setf (slot-value gf 'name) new-name)))
 
 (defun std-compute-discriminating-function (generic-function)
-  (values (if (eq (slot-value (class-of generic-function) 'name)
-                  'standard-generic-function)
-              (standard-gf-discriminator generic-function)
-              (unoptimized-discriminator generic-function))
-          t))
+  (values (unoptimized-discriminator generic-function) t))
 
 (defun compute-discriminating-function (gf)
   (declare (notinline std-compute-discriminating-function))