Eliminate one of our effective method function caches

- classes-to-emf-table was only ever used for gfs with exactly one
  argument but more than one method - use the cache in
  StandardGenericFunction.java for that case as well

- also rename %finalize-generic-function to %clear-emf-cache, since that
  is what it's doing
parent 779c76f1
......@@ -552,8 +552,8 @@ public class Autoload extends Function
autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true);
autoload(PACKAGE_SYS, "%%string=", "StringFunctions");
autoload(PACKAGE_SYS, "%adjust-array", "adjust_array");
autoload(PACKAGE_SYS, "%clear-emf-cache", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%defpackage", "PackageFunctions");
autoload(PACKAGE_SYS, "%finalize-generic-function", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%get-output-stream-bytes", "ByteArrayOutputStream"); //AS 20090325
autoload(PACKAGE_SYS, "%get-output-stream-array", "ByteArrayOutputStream");
autoload(PACKAGE_SYS, "%make-array", "make_array");
......@@ -578,7 +578,6 @@ public class Autoload extends Function
autoload(PACKAGE_SYS, "%set-class-direct-slots", "SlotClass", true);
autoload(PACKAGE_SYS, "%set-function-info", "function_info");
autoload(PACKAGE_SYS, "%init-eql-specializations", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%get-arg-specialization", "StandardGenericFunction", true);
autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector");
......
......@@ -831,7 +831,6 @@ public class StandardClass extends SlotClass
new SlotDefinition(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL,
constantlyNil),
new SlotDefinition(Symbol.DECLARATIONS, NIL, constantlyNil),
new SlotDefinition(Symbol.CLASSES_TO_EMF_TABLE, NIL, constantlyNil),
new SlotDefinition(Symbol._DOCUMENTATION, NIL, constantlyNil,
list(internKeyword("DOCUMENTATION")))));
// There are no inherited slots.
......
......@@ -61,11 +61,10 @@ public final class StandardGenericFunction extends FuncallableStandardObject
setInstanceSlotValue(Symbol._METHOD_COMBINATION, list(Symbol.STANDARD));
setInstanceSlotValue(Symbol.ARGUMENT_PRECEDENCE_ORDER, NIL);
setInstanceSlotValue(Symbol.DECLARATIONS, NIL);
setInstanceSlotValue(Symbol.CLASSES_TO_EMF_TABLE, NIL);
setInstanceSlotValue(Symbol._DOCUMENTATION, NIL);
}
void finalizeInternal()
void clearCache()
{
cache = null;
}
......@@ -114,22 +113,22 @@ public final class StandardGenericFunction extends FuncallableStandardObject
}
private static final Primitive _FINALIZE_GENERIC_FUNCTION
private static final Primitive _CLEAR_EMF_CACHE
= new pf__finalize_generic_function();
@DocString(name="%finalize-generic-function",
@DocString(name="%clear-emf-cache",
args="generic-function")
private static final class pf__finalize_generic_function extends Primitive
{
pf__finalize_generic_function()
{
super("%finalize-generic-function", PACKAGE_SYS, true,
super("%clear-emf-cache", PACKAGE_SYS, true,
"generic-function");
}
@Override
public LispObject execute(LispObject arg)
{
final StandardGenericFunction gf = checkStandardGenericFunction(arg);
gf.finalizeInternal();
gf.clearCache();
return T;
}
};
......@@ -264,24 +263,6 @@ public final class StandardGenericFunction extends FuncallableStandardObject
return arg.classOf();
}
private static final Primitive _GET_ARG_SPECIALIZATION
= new pf__get_arg_specialization();
@DocString(name="%get-arg-specialization",
args="generic-function arg")
private static final class pf__get_arg_specialization extends Primitive
{
pf__get_arg_specialization()
{
super("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final StandardGenericFunction gf = checkStandardGenericFunction(first);
return gf.getArgSpecialization(second);
}
};
private static class CacheEntry
{
final LispObject[] array;
......
......@@ -3156,8 +3156,6 @@ public class Symbol extends LispObject implements java.io.Serializable
PACKAGE_SYS.addInternalSymbol("CASE-FROB-STREAM");
public static final Symbol CAUSE =
PACKAGE_SYS.addInternalSymbol("CAUSE");
public static final Symbol CLASSES_TO_EMF_TABLE =
PACKAGE_SYS.addInternalSymbol("CLASSES-TO-EMF-TABLE");
public static final Symbol COMMA_MACRO =
PACKAGE_SYS.addInternalSymbol("COMMA-MACRO");
public static final Symbol DATUM =
......
This diff is collapsed.
......@@ -1612,13 +1612,6 @@ compare the method combination name to the symbol 'standard.")
(defun generic-function-optional-arguments (gf)
(std-slot-value gf 'sys::optional-args))
(declaim (ftype (function * t) classes-to-emf-table))
(defun classes-to-emf-table (gf)
(std-slot-value gf 'sys::classes-to-emf-table))
(defun (setf classes-to-emf-table) (new-value gf)
(setf (std-slot-value gf 'sys::classes-to-emf-table) new-value))
(defun (setf method-lambda-list) (new-value method)
(setf (std-slot-value method 'sys::lambda-list) new-value))
......@@ -1826,10 +1819,7 @@ compare the method combination name to the symbol 'standard.")
result))
(defun finalize-standard-generic-function (gf)
(%finalize-generic-function gf)
(if (classes-to-emf-table gf)
(clrhash (classes-to-emf-table gf))
(setf (classes-to-emf-table gf) (make-hash-table :test #'equal)))
(%clear-emf-cache gf)
(%init-eql-specializations gf (collect-eql-specializer-objects gf))
(set-funcallable-instance-function
gf
......@@ -1865,7 +1855,6 @@ compare the method combination name to the symbol 'standard.")
(setf (std-slot-value gf 'sys::%method-combination) method-combination)
(setf (std-slot-value gf 'sys::declarations) declarations)
(setf (std-slot-value gf 'sys::%documentation) documentation)
(setf (std-slot-value gf 'sys::classes-to-emf-table) nil)
(let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
(required-args (getf plist ':required-args)))
(setf (std-slot-value gf 'sys::required-args) required-args)
......@@ -2257,8 +2246,6 @@ Initialized with the true value near the end of the file.")
(null (intersection (generic-function-lambda-list gf)
'(&rest &optional &key &allow-other-keys &aux)))))
(declaim (ftype (function * t) slow-method-lookup-1))
(defun std-compute-discriminating-function (gf)
;; In this function, we know that gf is of class
;; standard-generic-function, so we can access the instance's slots
......@@ -2297,8 +2284,7 @@ Initialized with the true value near the end of the file.")
;; StandardObject.SET_SLOT_VALUE, so should be reasonably fast
(setf (std-slot-value instance slot-name) new-value))))
(t
(let* ((emf-table (classes-to-emf-table gf))
(number-required (length (generic-function-required-arguments gf)))
(let* ((number-required (length (generic-function-required-arguments gf)))
(lambda-list (generic-function-lambda-list gf))
(exact (null (intersection lambda-list
'(&rest &optional &key
......@@ -2338,15 +2324,11 @@ Initialized with the true value near the end of the file.")
(t
#'(lambda (arg)
(declare (optimize speed))
(let* ((specialization
(%get-arg-specialization gf arg))
(emfun (or (gethash1 specialization
emf-table)
(slow-method-lookup-1
gf arg specialization))))
(let* ((args (list arg))
(emfun (get-cached-emf gf args)))
(if emfun
(funcall emfun (list arg))
(apply #'no-applicable-method gf (list arg))))))))
(funcall emfun args)
(slow-method-lookup gf args)))))))
((= number-required 2)
#'(lambda (arg1 arg2)
(declare (optimize speed))
......@@ -2375,8 +2357,6 @@ Initialized with the true value near the end of the file.")
(if emfun
(funcall emfun args)
(slow-method-lookup gf args))))))
;; (let ((non-key-args (+ number-required
;; (length (generic-function-optional-arguments gf))))))
#'(lambda (&rest args)
(declare (optimize speed))
(let ((len (length args)))
......@@ -2526,23 +2506,6 @@ to ~S with argument list ~S."
(funcall emfun args))
(apply #'no-applicable-method gf args))))
(defun slow-method-lookup-1 (gf arg arg-specialization)
(let ((applicable-methods
(if (eq (class-of gf) +the-standard-generic-function-class+)
(std-compute-applicable-methods gf (list arg))
(or (compute-applicable-methods-using-classes gf (list (class-of arg)))
(compute-applicable-methods gf (list arg))))))
(if applicable-methods
(let ((emfun (funcall (if (eq (class-of gf)
+the-standard-generic-function-class+)
#'std-compute-effective-method
#'compute-effective-method)
gf (generic-function-method-combination gf)
applicable-methods)))
(when emfun
(setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
emfun))))
(defun sub-specializer-p (c1 c2 c-arg)
(find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment