Faster call-next-method

db4
Slava Pestov 2008-10-01 08:20:49 -05:00
parent 1cf1d967ea
commit 34952ff5c4
3 changed files with 14 additions and 8 deletions

View File

@ -417,7 +417,7 @@ M: quotation '
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
{ {
class<=-cache class-not-cache classes-intersect-cache class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union } [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set bootstrap-global set
bootstrap-global emit-userenv ; bootstrap-global emit-userenv ;

View File

@ -10,20 +10,23 @@ SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache SYMBOL: class-and-cache
SYMBOL: class-or-cache SYMBOL: class-or-cache
SYMBOL: next-method-quot-cache
: init-caches ( -- ) : init-caches ( -- )
H{ } clone class<=-cache set H{ } clone class<=-cache set
H{ } clone class-not-cache set H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set H{ } clone class-and-cache set
H{ } clone class-or-cache set ; H{ } clone class-or-cache set
H{ } clone next-method-quot-cache set ;
: reset-caches ( -- ) : reset-caches ( -- )
class<=-cache get clear-assoc class<=-cache get clear-assoc
class-not-cache get clear-assoc class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc class-and-cache get clear-assoc
class-or-cache get clear-assoc ; class-or-cache get clear-assoc
next-method-quot-cache get clear-assoc ;
SYMBOL: update-map SYMBOL: update-map

View File

@ -45,7 +45,9 @@ GENERIC: effective-method ( generic -- method )
GENERIC: next-method-quot* ( class generic combination -- quot ) GENERIC: next-method-quot* ( class generic combination -- quot )
: next-method-quot ( class generic -- quot ) : next-method-quot ( class generic -- quot )
dup "combination" word-prop next-method-quot* ; next-method-quot-cache get [
dup "combination" word-prop next-method-quot*
] 2cache ;
: (call-next-method) ( class generic -- ) : (call-next-method) ( class generic -- )
next-method-quot call ; next-method-quot call ;
@ -99,10 +101,11 @@ M: method-body crossref?
2bi ; 2bi ;
: create-method ( class generic -- method ) : create-method ( class generic -- method )
2dup method dup [ 2dup method dup [ 2nip ] [
2nip drop
] [ [ <method> dup ] 2keep
drop [ <method> dup ] 2keep reveal-method reveal-method
reset-caches
] if ; ] if ;
PREDICATE: default-method < word "default" word-prop ; PREDICATE: default-method < word "default" word-prop ;