org.armedbear.lisp.EMFCache Maven / Gradle / Ivy
/*
* EMFCache.java
*
* Copyright (C) 2003-2006 Peter Graves, 2013 Rudolf Schlatte
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
import static org.armedbear.lisp.Lisp.*;
import java.util.concurrent.ConcurrentHashMap;
public final class EMFCache extends LispObject
{
ConcurrentHashMap cache
= new ConcurrentHashMap();;
EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0];
void clearCache()
{
cache = new ConcurrentHashMap();
}
@Override
public String printObject()
{
return unreadableString("EMF-CACHE");
}
static final FuncallableStandardObject checkStandardGenericFunction(LispObject obj)
{
if (obj instanceof FuncallableStandardObject)
return (FuncallableStandardObject) obj;
return (FuncallableStandardObject) // Not reached.
type_error(obj, Symbol.STANDARD_GENERIC_FUNCTION);
}
private static class EqlSpecialization extends LispObject
{
public LispObject eqlTo;
public EqlSpecialization(LispObject eqlTo)
{
this.eqlTo = eqlTo;
}
}
private static class CacheEntry
{
final LispObject[] array;
CacheEntry(LispObject[] array)
{
this.array = array;
}
@Override
public int hashCode()
{
int result = 0;
for (int i = array.length; i-- > 0;)
result ^= array[i].hashCode();
return result;
}
@Override
public boolean equals(Object object)
{
if (!(object instanceof CacheEntry))
return false;
final CacheEntry otherEntry = (CacheEntry) object;
if (otherEntry.array.length != array.length)
return false;
final LispObject[] otherArray = otherEntry.array;
for (int i = array.length; i-- > 0;)
if (array[i] != otherArray[i])
return false;
return true;
}
}
private static final Primitive _MAKE_EMF_CACHE
= new pf__make_emf_cache();
@DocString(name="%make-emf-cache")
private static final class pf__make_emf_cache extends Primitive
{
pf__make_emf_cache()
{
super("%make-emf-cache", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg)
{
return new EMFCache();
}
};
private static final Primitive _REINIT_EMF_CACHE
= new pf__reinit_emf_cache();
@DocString(name="%reinit-emf-cache",
args="generic-function eql-specilizer-objects-list")
private static final class pf__reinit_emf_cache extends Primitive
{
pf__reinit_emf_cache()
{
super("%reinit-emf-cache", PACKAGE_SYS, true,
"generic-function eql-specializer-objects-list");
}
@Override
public LispObject execute(LispObject generic_function, LispObject eql_specializers)
{
final FuncallableStandardObject gf = checkStandardGenericFunction(generic_function);
EMFCache cache = gf.cache;
cache.clearCache();
cache.eqlSpecializations = new EqlSpecialization[eql_specializers.length()];
for (int i = 0; i < cache.eqlSpecializations.length; i++) {
cache.eqlSpecializations[i] = new EqlSpecialization(eql_specializers.car());
eql_specializers = eql_specializers.cdr();
}
return T;
}
};
private static final Primitive CACHE_EMF
= new pf_cache_emf();
@DocString(name="cache-emf",
args="generic-function args emf")
private static final class pf_cache_emf extends Primitive
{
pf_cache_emf()
{
super("cache-emf", PACKAGE_SYS, true, "generic-function args emf");
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
final FuncallableStandardObject gf = checkStandardGenericFunction(first);
EMFCache cache = gf.cache;
LispObject args = second;
int numberOfRequiredArgs
= gf.getInstanceSlotValue(Symbol.REQUIRED_ARGS).length();
LispObject[] array = new LispObject[numberOfRequiredArgs];
for (int i = numberOfRequiredArgs; i-- > 0;)
{
array[i] = cache.getArgSpecialization(args.car());
args = args.cdr();
}
CacheEntry specializations = new CacheEntry(array);
ConcurrentHashMap ht = cache.cache;
ht.put(specializations, third);
return third;
}
};
private static final Primitive GET_CACHED_EMF
= new pf_get_cached_emf();
@DocString(name="get-cached-emf",
args="generic-function args")
private static final class pf_get_cached_emf extends Primitive
{
pf_get_cached_emf() {
super("get-cached-emf", PACKAGE_SYS, true, "generic-function args");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final FuncallableStandardObject gf = checkStandardGenericFunction(first);
EMFCache cache = gf.cache;
LispObject args = second;
int numberOfRequiredArgs
= gf.getInstanceSlotValue(Symbol.REQUIRED_ARGS).length();
LispObject[] array = new LispObject[numberOfRequiredArgs];
for (int i = numberOfRequiredArgs; i-- > 0;)
{
array[i] = cache.getArgSpecialization(args.car());
args = args.cdr();
}
CacheEntry specializations = new CacheEntry(array);
ConcurrentHashMap ht = cache.cache;
LispObject emf = (LispObject) ht.get(specializations);
return emf != null ? emf : NIL;
}
};
/**
* Returns an object representing generic function
* argument arg in a CacheEntry
*
* In the simplest case, when this generic function
* does not have EQL specialized methods, and therefore
* only argument types are relevant for choosing
* applicable methods, the value returned is the
* class of arg
*
*
If the function has EQL specialized methods:
* - if arg is EQL to some of the EQL-specializers,
* a special object representing equality to that specializer
* is returned.
* - otherwise class of the arg is returned.
*
*
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).
*
*
Consider:
*
* (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)"
*
*
*
* After the two above calls cache will contain three keys:
*
* { class FIXNUM, EqlSpecialization('SYMBOL) }
* { class SYMBOL, EqlSpecialization('SYMBOL) }
* { EqlSpecialization('SYMBOL), EqlSpecialization('SYMBOL) }.
*
*/
LispObject getArgSpecialization(LispObject arg)
{
for (EqlSpecialization eqlSpecialization : eqlSpecializations)
{
if (eqlSpecialization.eqlTo.eql(arg))
return eqlSpecialization;
}
return arg.classOf();
}
}