Changeset 14485
- Timestamp:
- 04/29/13 15:48:24 (10 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/Autoload.java
r14479 r14485 612 612 autoload(PACKAGE_SYS, "%time", "Time"); 613 613 autoload(PACKAGE_SYS, "cache-emf", "StandardGenericFunction", true); 614 autoload(PACKAGE_SYS, "cache-slot-location", "StandardGenericFunction", true);615 614 autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true); 616 615 autoload(PACKAGE_SYS, "%class-direct-slots", "SlotClass"); … … 629 628 autoload(PACKAGE_SYS, "function-info", "function_info"); 630 629 autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true); 631 autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true);632 630 autoload(PACKAGE_SYS, "get-function-info-value", "function_info"); 633 631 autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); -
trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
r14481 r14485 42 42 43 43 ConcurrentHashMap<CacheEntry,LispObject> cache; 44 ConcurrentHashMap<LispObject,LispObject> slotCache;45 44 46 45 public StandardGenericFunction() … … 284 283 }; 285 284 286 private static final Primitive CACHE_SLOT_LOCATION287 = new pf_cache_slot_location();288 @DocString(name="cache-slot-location",289 args="generic-function layout location")290 private static final class pf_cache_slot_location extends Primitive291 {292 pf_cache_slot_location()293 {294 super("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location");295 }296 @Override297 public LispObject execute(LispObject first, LispObject second,298 LispObject third)299 {300 final StandardGenericFunction gf = checkStandardGenericFunction(first);301 LispObject layout = second;302 LispObject location = third;303 ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;304 if (ht == null)305 ht = gf.slotCache = new ConcurrentHashMap<LispObject,LispObject>();306 ht.put(layout, location);307 return third;308 }309 };310 311 private static final Primitive GET_CACHED_SLOT_LOCATION312 = new pf_get_cached_slot_location();313 @DocString(name="get-cached-slot-location")314 private static final class pf_get_cached_slot_location extends Primitive315 {316 pf_get_cached_slot_location()317 {318 super("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout");319 }320 @Override321 public LispObject execute(LispObject first, LispObject second)322 {323 final StandardGenericFunction gf = checkStandardGenericFunction(first);324 LispObject layout = second;325 ConcurrentHashMap<LispObject,LispObject> ht = gf.slotCache;326 if (ht == null)327 return NIL;328 LispObject location = (LispObject) ht.get(layout);329 return location != null ? location : NIL;330 }331 };332 333 285 private static class CacheEntry 334 286 { -
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r14483 r14485 2260 2260 (declaim (ftype (function * t) slow-method-lookup-1)) 2261 2261 2262 (declaim (ftype (function (t t t) t) slow-reader-lookup))2263 (defun slow-reader-lookup (gf layout slot-name)2264 (let ((location (layout-slot-location layout slot-name)))2265 (cache-slot-location gf layout location)2266 location))2267 2268 2262 (defun std-compute-discriminating-function (gf) 2269 2263 ;; In this function, we know that gf is of class … … 2275 2269 ((and (= (length methods) 1) 2276 2270 (eq (type-of (car methods)) 'standard-reader-method) 2277 (eq (type-of (car (std-method-specializers ( %car methods))))2271 (eq (type-of (car (std-method-specializers (car methods)))) 2278 2272 'standard-class)) 2279 (let* ((method (%car methods)) 2280 (class (car (std-method-specializers method))) 2281 (slot-name (slot-definition-name (accessor-method-slot-definition 2282 method))) 2283 (reader (if (typep class 'funcallable-standard-class) 2284 #'funcallable-standard-instance-access 2285 #'standard-instance-access))) 2273 (let ((slot-name (slot-definition-name (accessor-method-slot-definition 2274 (first methods))))) 2286 2275 #'(lambda (arg) 2287 (declare (optimize speed)) 2288 (let* ((layout (std-instance-layout arg)) 2289 (location (get-cached-slot-location gf layout))) 2290 (unless location 2291 (unless (simple-typep arg class) 2292 ;; FIXME no applicable method 2293 (error 'simple-type-error 2294 :datum arg 2295 :expected-type class)) 2296 (setf location (slow-reader-lookup gf layout slot-name))) 2297 (let ((value (if (consp location) 2298 (cdr location) ; :allocation :class 2299 (funcall reader arg location)))) 2300 (if (eq value +slot-unbound+) 2301 ;; fix SLOT-UNBOUND.5 from ansi test suite 2302 (nth-value 0 (slot-unbound class arg slot-name)) 2303 value)))))) 2276 ;; this evades linear scan through slot names (see 2277 ;; SLOT_VALUE in StandardObject.java) 2278 (std-slot-value arg slot-name)))) 2304 2279 2305 2280 (t
Note: See TracChangeset
for help on using the changeset viewer.