steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Remove a conditional branch from all tuple dispatches, since we don't have to check if the class height is at least 1; and remove memory accesses from tuple dispatch where all tuples are height 1

db4
Slava Pestov 2008-11-05 20:23:38 -06:00
parent fbb958da82
commit 4e98751ce0
2 changed files with 42 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
core/generic/standard/engines/tuple/tuple.factor
View File

@ -123,8 +123,8 @@ M: echelon-dispatch-engine engine>quot
] [ ] make ] [ ] make
] if ; ] if ;
: >=-case-quot ( alist -- quot ) : >=-case-quot ( default alist -- quot )
default get [ drop ] prepend swap [ [ drop ] prepend ] dip
[ [
[ [ dup ] swap [ fixnum>= ] curry compose ] [ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ] [ [ drop ] prepose ]
@ -132,31 +132,40 @@ M: echelon-dispatch-engine engine>quot
] assoc-map ] assoc-map
alist>quot ; alist>quot ;
: tuple-layout-echelon% ( -- ) : tuple-layout-echelon-quot ( -- quot )
[ [
{ tuple } declare { tuple } declare
1 slot { tuple-layout } declare 1 slot { tuple-layout } declare
5 slot 5 slot
] % ; inline ] ; inline
: echelon-case-quot ( alist -- quot )
#! We don't have to test for echelon 1 since all tuple
#! classes are at least at depth 1 in the inheritance
#! hierarchy.
dup first first 1 = [ unclip second ] [ default get ] if swap
[
[
picker %
tuple-layout-echelon-quot %
>=-case-quot %
] [ ] make
] unless-empty ;
M: tuple-dispatch-engine engine>quot M: tuple-dispatch-engine engine>quot
[ [
picker %
tuple-layout-echelon%
[ [
tuple assumed set tuple assumed set
echelons>> dup empty? [ echelons>> unclip-last
unclip-last [
[ [
[ engine>quot define-engine-word
engine>quot define-engine-word [ remember-engine ] [ 1quotation ] bi
[ remember-engine ] [ 1quotation ] bi dup default set
dup default set ] assoc-map
] assoc-map ]
] [ first2 engine>quot 2array ] bi*
[ first2 engine>quot 2array ] bi* suffix
suffix
] unless
] with-scope ] with-scope
>=-case-quot % echelon-case-quot %
] [ ] make ; ] [ ] make ;

29
core/generic/standard/standard.factor
View File

@ -60,21 +60,22 @@ ERROR: no-method object generic ;
[ 1quotation ] [ extra-values \ drop <repetition> ] bi* [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ; prepend [ ] like ;
: <standard-engine> ( word -- engine )
object bootstrap-word assumed set {
[ generic set ]
[ "engines" word-prop forget-all ]
[ V{ } clone "engines" set-word-prop ]
[
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[ <big-dispatch-engine> ]
bi
]
} cleave ;
: single-combination ( word -- quot ) : single-combination ( word -- quot )
[ [ <standard-engine> engine>quot ] with-scope ;
object bootstrap-word assumed set {
[ generic set ]
[ "engines" word-prop forget-all ]
[ V{ } clone "engines" set-word-prop ]
[
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[ <big-dispatch-engine> ]
bi engine>quot
]
} cleave
] with-scope ;
ERROR: inconsistent-next-method class generic ; ERROR: inconsistent-next-method class generic ;