[armedbear-cvs] r12042 - trunk/abcl/src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Mon Jul 13 14:11:41 UTC 2009
Author: mevenson
Date: Mon Jul 13 10:10:50 2009
New Revision: 12042
Log:
Cache arg specialization computation for eql-specialized generic functions. (Anton Vodonosov)
I started to investigate this problem because slime fuzzy completion
works very slow with ABCL.
For example
(time (swank::fuzzy-completions "de" 'cl-user))
takes 1.5 - 2 seconds. That long time is not pleasant for user interface.
Turned out that most of the time is spent in COMPILE.
During SWANK::FUZZY-COMPLETIONS every symbol is processed by
SWANK-CLASSIFY-SYMBOL, which uses (DOCUMENTATION s 'TYPE),
and every invocation (DOCUMENTATION s 'TYPE) being eql-specialized
function leads to COMPILE.
With my patch (time (swank::fuzzy-completions "de" 'cl-user))
takes 0.25 - 0.5 seconds. Not too fast, in CLISP the same takes 0.07 sec,
in CCL 0.03 sec. But significantly better than it was.
In the patch method getArgSpecialization could probably be named better.
Also I am not sure if you want to keep the wordy javadoc comment; i just
decided to put the patch explanation to the sources instead of this email.
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Mon Jul 13 10:10:50 2009
@@ -445,7 +445,8 @@
public LispObject execute(LispObject first, LispObject second)
throws ConditionThrowable
{
- checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = second;
+ checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]
+ = second;
return second;
}
};
@@ -457,7 +458,8 @@
@Override
public LispObject execute(LispObject arg) throws ConditionThrowable
{
- return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER];
+ return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass
+ .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER];
}
};
@@ -469,7 +471,8 @@
public LispObject execute(LispObject first, LispObject second)
throws ConditionThrowable
{
- checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second;
+ checkStandardGenericFunction(first)
+ .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second;
return second;
}
};
@@ -481,7 +484,8 @@
@Override
public LispObject execute(LispObject arg) throws ConditionThrowable
{
- return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE];
+ return checkStandardGenericFunction(arg)
+ .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE];
}
};
@@ -493,7 +497,8 @@
public LispObject execute(LispObject first, LispObject second)
throws ConditionThrowable
{
- checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second;
+ checkStandardGenericFunction(first)
+ .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second;
return second;
}
};
@@ -517,7 +522,8 @@
public LispObject execute(LispObject first, LispObject second)
throws ConditionThrowable
{
- checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = second;
+ checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]
+ = second;
return second;
}
};
@@ -550,14 +556,14 @@
LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
for (int i = gf.numberOfRequiredArgs; i-- > 0;)
{
- array[i] = args.car().classOf();
+ array[i] = gf.getArgSpecialization(args.car());
args = args.cdr();
}
- CacheEntry classes = new CacheEntry(array);
+ CacheEntry specializations = new CacheEntry(array);
HashMap<CacheEntry,LispObject> ht = gf.cache;
if (ht == null)
ht = gf.cache = new HashMap<CacheEntry,LispObject>();
- ht.put(classes, third);
+ ht.put(specializations, third);
return third;
}
};
@@ -575,18 +581,97 @@
LispObject[] array = new LispObject[gf.numberOfRequiredArgs];
for (int i = gf.numberOfRequiredArgs; i-- > 0;)
{
- array[i] = args.car().classOf();
+ array[i] = gf.getArgSpecialization(args.car());
args = args.cdr();
}
- CacheEntry classes = new CacheEntry(array);
+ CacheEntry specializations = new CacheEntry(array);
HashMap<CacheEntry,LispObject> ht = gf.cache;
if (ht == null)
return NIL;
- LispObject emf = (LispObject) ht.get(classes);
+ LispObject emf = (LispObject) ht.get(specializations);
return emf != null ? emf : NIL;
}
};
+ /**
+ * Returns an object representing generic function
+ * argument <tt>arg</tt> in a <tt>CacheEntry</tt>
+ *
+ * <p>In the simplest case, when this generic function
+ * does not have EQL specialized methos, and therefore
+ * only argument types are relevant for choosing
+ * applicable methods, the value returned is the
+ * class of <tt>arg</tt>
+ *
+ * <p>If the function has EQL specialized methods:
+ * - if <tt>arg</tt> is EQL to some of the EQL-specializers,
+ * a special object representing equality to that specializer
+ * is returned.
+ * - otherwise class of the <tt>arg</tt> is returned.
+ *
+ * <p>Note that we do not consider argument position, when
+ * calculating arg specialization. In rare cases (when
+ * one argument is eql-specialized to a symbol specifying
+ * class of another argument) this may result in redundant cache
+ * entries caching the same method. But the method cached is anyway
+ * correct for the arguments (because in case of cache miss, correct method
+ * is calculated by other code, which does not rely on getArgSpecialization;
+ * and because EQL is true only for objects of the same type, which guaranties
+ * that if a type-specialized methods was chached by eql-specialization,
+ * all the cache hits into this records will be from args of the conforming
+ * type).
+ *
+ * <p>Consider:
+ * <pre><tt>
+ * (defgeneric f (a b))
+ *
+ * (defmethod f (a (b (eql 'symbol)))
+ * "T (EQL 'SYMBOL)")
+ *
+ * (defmethod f ((a symbol) (b (eql 'symbol)))
+ * "SYMBOL (EQL 'SYMBOL)")
+ *
+ * (f 12 'symbol)
+ * => "T (EQL 'SYMBOL)"
+ *
+ * (f 'twelve 'symbol)
+ * => "SYMBOL (EQL 'SYMBOL)"
+ *
+ * (f 'symbol 'symbol)
+ * => "SYMBOL (EQL 'SYMBOL)"
+ *
+ * </tt></pre>
+ *
+ * After the two above calls <tt>cache</tt> will contain tree keys:
+ * <pre>
+ * { class FIXNUM, EqlSpecialization('SYMBOL) }
+ * { class SYMBOL, EqlSpecialization('SYMBOL) }
+ * { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
+ * </pre>
+ */
+ private LispObject getArgSpecialization(LispObject arg)
+ {
+ for (EqlSpecialization eqlSpecialization : eqlSpecializations)
+ {
+ if (eqlSpecialization.eqlTo.eql(arg))
+ return eqlSpecialization;
+ }
+ return arg.classOf();
+ }
+
+ // ### %get-arg-specialization
+ private static final Primitive _GET_ARG_SPECIALIZATION =
+ new Primitive("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg")
+ {
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+ throws ConditionThrowable
+ {
+ final StandardGenericFunction gf = checkStandardGenericFunction(first);
+ return gf.getArgSpecialization(second);
+ }
+ };
+
// ### cache-slot-location
private static final Primitive CACHE_SLOT_LOCATION =
new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location")
@@ -666,13 +751,45 @@
return true;
}
}
+
+ private EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
+
+ // ### %init-eql-specializations
+ private static final Primitive _INIT_EQL_SPECIALIZATIONS
+ = new Primitive("%init-eql-specializations", PACKAGE_SYS, true,
+ "generic-function eql-specilizer-objects-list")
+ {
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+ throws ConditionThrowable
+ {
+ final StandardGenericFunction gf = checkStandardGenericFunction(first);
+ LispObject eqlSpecializerObjects = second;
+ gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()];
+ for (int i = 0; i < gf.eqlSpecializations.length; i++) {
+ gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car());
+ eqlSpecializerObjects = eqlSpecializerObjects.cdr();
+ }
+ return NIL;
+ }
+ };
+
+ private static class EqlSpecialization extends LispObject
+ {
+ public LispObject eqlTo;
+
+ public EqlSpecialization(LispObject eqlTo)
+ {
+ this.eqlTo = eqlTo;
+ }
+ }
public static final StandardGenericFunction checkStandardGenericFunction(LispObject obj)
throws ConditionThrowable
{
- if (obj instanceof StandardGenericFunction)
- return (StandardGenericFunction) obj;
- return (StandardGenericFunction) // Not reached.
- type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
- }
+ if (obj instanceof StandardGenericFunction)
+ return (StandardGenericFunction) obj;
+ return (StandardGenericFunction) // Not reached.
+ type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
+ }
}
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jul 13 10:10:50 2009
@@ -857,9 +857,20 @@
gf))
(apply gf args))
+(defun collect-eql-specializer-objects (generic-function)
+ (let ((result nil))
+ (dolist (method (generic-function-methods generic-function))
+ (dolist (specializer (%method-specializers method))
+ (when (typep specializer 'eql-specializer)
+ (pushnew (eql-specializer-object specializer)
+ result
+ :test 'eql))))
+ result))
+
(defun finalize-generic-function (gf)
(%finalize-generic-function gf)
(setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
+ (%init-eql-specializations gf (collect-eql-specializer-objects gf))
(set-funcallable-instance-function
gf
(make-closure `(lambda (&rest args)
@@ -1184,12 +1195,6 @@
(error "No such method for ~S." (%generic-function-name gf))
method)))
-(defun methods-contain-eql-specializer-p (methods)
- (dolist (method methods nil)
- (when (dolist (spec (%method-specializers method) nil)
- (when (eql-specializer-p spec) (return t)))
- (return t))))
-
(defun fast-callable-p (gf)
(and (eq (generic-function-method-combination gf) 'standard)
(null (intersection (%generic-function-lambda-list gf)
@@ -1205,11 +1210,7 @@
(defun std-compute-discriminating-function (gf)
(let ((code
- (cond ((methods-contain-eql-specializer-p (generic-function-methods gf))
- (make-closure `(lambda (&rest args)
- (slow-method-lookup ,gf args))
- nil))
- ((and (= (length (generic-function-methods gf)) 1)
+ (cond ((and (= (length (generic-function-methods gf)) 1)
(typep (car (generic-function-methods gf)) 'standard-reader-method))
;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
(make-closure
@@ -1245,23 +1246,30 @@
(cond ((and (eq (generic-function-method-combination gf) 'standard)
(= (length (generic-function-methods gf)) 1))
(let* ((method (%car (generic-function-methods gf)))
- (class (car (%method-specializers method)))
+ (specializer (car (%method-specializers method)))
(function (or (%method-fast-function method)
(%method-function method))))
- `(lambda (arg)
- (declare (optimize speed))
- (unless (simple-typep arg ,class)
- ;; FIXME no applicable method
- (error 'simple-type-error
- :datum arg
- :expected-type ,class))
- (funcall ,function arg))))
+ (if (eql-specializer-p specializer)
+ (let ((specializer-object (eql-specializer-object specializer)))
+ `(lambda (arg)
+ (declare (optimize speed))
+ (if (eql arg ',specializer-object)
+ (funcall ,function arg)
+ (no-applicable-method ,gf (list arg)))))
+ `(lambda (arg)
+ (declare (optimize speed))
+ (unless (simple-typep arg ,specializer)
+ ;; FIXME no applicable method
+ (error 'simple-type-error
+ :datum arg
+ :expected-type ,specializer))
+ (funcall ,function arg)))))
(t
`(lambda (arg)
(declare (optimize speed))
- (let* ((class (class-of arg))
- (emfun (or (gethash1 class ,emf-table)
- (slow-method-lookup-1 ,gf class))))
+ (let* ((specialization (%get-arg-specialization ,gf arg))
+ (emfun (or (gethash1 specialization ,emf-table)
+ (slow-method-lookup-1 ,gf arg specialization))))
(if emfun
(funcall emfun (list arg))
(apply #'no-applicable-method ,gf (list arg)))))
@@ -1275,7 +1283,7 @@
(let ((emfun (get-cached-emf ,gf args)))
(if emfun
(funcall emfun args)
- (slow-method-lookup ,gf args))))))
+ (slow-method-lookup ,gf args))))))
((= number-required 2)
(if exact
`(lambda (arg1 arg2)
@@ -1368,21 +1376,6 @@
(unless (subclassp (car classes) specializer)
(return nil)))))
-(defun %compute-applicable-methods-using-classes (gf required-classes)
- (let ((methods '()))
- (dolist (method (generic-function-methods gf))
- (when (method-applicable-p-using-classes method required-classes)
- (push method methods)))
- (if (or (null methods) (null (%cdr methods)))
- methods
- (sort methods
- (if (eq (class-of gf) (find-class 'standard-generic-function))
- #'(lambda (m1 m2)
- (std-method-more-specific-p m1 m2 required-classes
- (generic-function-argument-precedence-order gf)))
- #'(lambda (m1 m2)
- (method-more-specific-p gf m1 m2 required-classes)))))))
-
(defun slow-method-lookup (gf args)
(let ((applicable-methods (%compute-applicable-methods gf args)))
(if applicable-methods
@@ -1394,15 +1387,15 @@
(funcall emfun args))
(apply #'no-applicable-method gf args))))
-(defun slow-method-lookup-1 (gf class)
- (let ((applicable-methods (%compute-applicable-methods-using-classes gf (list class))))
+(defun slow-method-lookup-1 (gf arg arg-specialization)
+ (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
(if applicable-methods
(let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function))
#'std-compute-effective-method-function
#'compute-effective-method-function)
gf applicable-methods)))
(when emfun
- (setf (gethash class (classes-to-emf-table gf)) emfun))
+ (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
emfun))))
(defun sub-specializer-p (c1 c2 c-arg)
More information about the armedbear-cvs
mailing list