Changeset 14485

Timestamp:

04/29/13 15:48:24 (10 years ago)

Author:

rschlatte

Message:

remove slot location caching from StandardGenericFunction?

• std-slot-value goes through a hash table lookup as well (via StandardObject?.SLOT_VALUE), and we eliminate some function calls on the fast path.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (2 diffs)
• StandardGenericFunction.java (modified) (2 diffs)
• clos.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -612 +612 @@
         autoload(PACKAGE_SYS, "%time", "Time");
         autoload(PACKAGE_SYS, "cache-emf", "StandardGenericFunction", true);
-        autoload(PACKAGE_SYS, "cache-slot-location", "StandardGenericFunction", true);
         autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true);
         autoload(PACKAGE_SYS, "%class-direct-slots", "SlotClass");
@@ -629 +628 @@
         autoload(PACKAGE_SYS, "function-info", "function_info");
         autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true);
-        autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true);
         autoload(PACKAGE_SYS, "get-function-info-value", "function_info");
         autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions");

trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

@@ -42 +42 @@
 
   ConcurrentHashMap<CacheEntry,LispObject> cache;
-  ConcurrentHashMap<LispObject,LispObject> slotCache;
 
   public StandardGenericFunction()
@@ -284 +283 @@
   };
 
-  private static final Primitive CACHE_SLOT_LOCATION 
-    = new pf_cache_slot_location(); 
-  @DocString(name="cache-slot-location",
-           args="generic-function layout location")
-  private static final class pf_cache_slot_location extends Primitive
-  {
-    pf_cache_slot_location()
-    {
-      super("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location");
-    }
-    @Override
-    public LispObject execute(LispObject first, LispObject second,
-                                LispObject third)
-    {
-      final StandardGenericFunction gf = checkStandardGenericFunction(first);
-      LispObject layout = second;
-      LispObject location = third;
-      ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
-      if (ht == null)
-        ht = gf.slotCache = new ConcurrentHashMap<LispObject,LispObject>();
-      ht.put(layout, location);
-      return third;
-    }
-  };
-
-  private static final Primitive GET_CACHED_SLOT_LOCATION 
-    = new pf_get_cached_slot_location();
-  @DocString(name="get-cached-slot-location")
-  private static final class pf_get_cached_slot_location extends Primitive
-  {
-    pf_get_cached_slot_location()
-    {
-      super("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout");
-    }
-    @Override
-    public LispObject execute(LispObject first, LispObject second)
-    {
-      final StandardGenericFunction gf = checkStandardGenericFunction(first);
-      LispObject layout = second;
-      ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;
-      if (ht == null)
-        return NIL;
-      LispObject location = (LispObject) ht.get(layout);
-      return location != null ? location : NIL;
-    }
-  };
-
   private static class CacheEntry
   {

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -2260 +2260 @@
 (declaim (ftype (function * t) slow-method-lookup-1))
 
-(declaim (ftype (function (t t t) t) slow-reader-lookup))
-(defun slow-reader-lookup (gf layout slot-name)
-  (let ((location (layout-slot-location layout slot-name)))
-    (cache-slot-location gf layout location)
-    location))
-
 (defun std-compute-discriminating-function (gf)
   ;; In this function, we know that gf is of class
@@ -2275 +2269 @@
       ((and (= (length methods) 1)
             (eq (type-of (car methods)) 'standard-reader-method)
-            (eq (type-of (car (std-method-specializers (%car methods))))
+            (eq (type-of (car (std-method-specializers (car methods))))
                 'standard-class))
-       (let* ((method (%car methods))
-              (class (car (std-method-specializers method)))
-              (slot-name (slot-definition-name (accessor-method-slot-definition
-                                                method)))
-              (reader (if (typep class 'funcallable-standard-class)
-                          #'funcallable-standard-instance-access
-                          #'standard-instance-access)))
+       (let ((slot-name (slot-definition-name (accessor-method-slot-definition
+                                               (first methods)))))
          #'(lambda (arg)
-             (declare (optimize speed))
-             (let* ((layout (std-instance-layout arg))
-                    (location (get-cached-slot-location gf layout)))
-               (unless location
-                 (unless (simple-typep arg class)
-                   ;; FIXME no applicable method
-                   (error 'simple-type-error
-                          :datum arg
-                          :expected-type class))
-                 (setf location (slow-reader-lookup gf layout slot-name)))
-               (let ((value (if (consp location)
-                                (cdr location) ; :allocation :class
-                                (funcall reader arg location))))
-                 (if (eq value +slot-unbound+)
-                     ;; fix SLOT-UNBOUND.5 from ansi test suite
-                     (nth-value 0 (slot-unbound class arg slot-name))
-                     value))))))
+             ;; this evades linear scan through slot names (see
+             ;; SLOT_VALUE in StandardObject.java)
+             (std-slot-value arg slot-name))))
 
       (t