Inlining no-method when a generic word has no method

db4
Daniel Ehrenberg 2010-05-14 20:28:09 -05:00
parent 05290ee1b1
commit fbaa8d153f
3 changed files with 39 additions and 28 deletions

View File

@ -48,12 +48,12 @@ M: callable splicing-nodes splicing-body ;
] if ] if
] [ 2drop undo-inlining ] if ; ] [ 2drop undo-inlining ] if ;
ERROR: bad-splitting class generic ; ERROR: bad-guarded-method-call class generic ;
:: split-code ( class generic -- quot/f ) :: guard-code ( class generic -- quot/f )
class generic method :> my-method class generic method :> my-method
my-method [ class generic bad-splitting ] unless my-method [ class generic bad-guarded-method-call ] unless
class generic my-method depends-on-method-is class generic my-method depends-on-method-identity
generic dispatch# (picker) :> picker generic dispatch# (picker) :> picker
[ [
picker call class instance? picker call class instance?
@ -61,19 +61,20 @@ ERROR: bad-splitting class generic ;
[ generic no-method ] if [ generic no-method ] if
] ; ] ;
:: split-method-call ( class generic -- quot/f ) :: guarded-method-call ( class generic -- quot/f )
class generic subclass-with-only-method [ class generic subclass-with-only-method [
[ class generic depends-on-single-method ] [ class generic depends-on-single-method ] [
[ generic split-code ] bi dup +no-method+ =
[ drop [ generic no-method ] ]
[ generic guard-code ] if
] bi
] [ f ] if* ; ] [ f ] if* ;
: inlining-standard-method ( #call word -- class/f method/f ) : inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [ 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi* [ swap nth value-info class>> dup ] dip
[ swap nth value-info class>> dup ] dip { [ method-for-class ] [ guarded-method-call ] } 2||
{ [ method-for-class ] [ split-method-call ] } 2||
] if
] if ; ] if ;
: inline-standard-method ( #call word -- ? ) : inline-standard-method ( #call word -- ? )

View File

@ -9,7 +9,7 @@ compiler.tree.debugger compiler.tree.checker slots.private words
hashtables classes assocs locals specialized-arrays system hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private sorting math.libm math.floats.private math.integers.private
math.intervals quotations effects alien alien.data sets math.intervals quotations effects alien alien.data sets
strings.private classes.tuple eval ; strings.private classes.tuple eval generic.single ;
FROM: math => float ; FROM: math => float ;
SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void* SPECIALIZED-ARRAY: void*
@ -878,7 +878,8 @@ M: f whatever2 ; inline
SYMBOL: not-an-assoc SYMBOL: not-an-assoc
[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test [ t ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test
[ f ] [ [ not-an-assoc at ] { no-method } inlined? ] unit-test
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test [ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
@ -890,7 +891,8 @@ SYMBOL: not-an-assoc
[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test [ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
[ f ] [ [ instance? ] { instance? } inlined? ] unit-test [ f ] [ [ instance? ] { instance? } inlined? ] unit-test
[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test [ t ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
[ f ] [ [ 5 instance? ] { no-method } inlined? ] unit-test
[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test [ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
@ -1034,3 +1036,9 @@ UNION: ?fixnum fixnum POSTPONE: f ;
[ V{ alien } ] [ [ V{ alien } ] [
[ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
] unit-test ] unit-test
! Ensuring that calling a generic word on a class where it's undefined inlines no-method
GENERIC: undefined-generic-test ( x -- y )
[ t ] [ [ 1 undefined-generic-test ] { undefined-generic-test } inlined? ] unit-test
[ f ] [ [ 1 undefined-generic-test ] { no-method } inlined? ] unit-test

View File

@ -151,26 +151,28 @@ TUPLE: depends-on-single-method method-class object-class generic ;
[ nip [ depends-on-conditionally ] bi@ ] [ nip [ depends-on-conditionally ] bi@ ]
[ \ depends-on-single-method add-conditional-dependency ] 3bi ; [ \ depends-on-single-method add-conditional-dependency ] 3bi ;
:: subclass-with-only-method ( class generic -- subclass/f ) SYMBOL: +no-method+
generic method-classes [ f ] [
f swap [| last-class new-class | :: subclass-with-only-method ( class generic -- subclass/f/+no-method+ ) ! make it return +no-method+ sometimes
class new-class classes-intersect? [ f generic method-classes
last-class [ f f ] [ new-class t ] if [| last-class new-class |
] [ last-class t ] if class new-class classes-intersect? [
] all? swap and last-class [ f f ] [ new-class t ] if
] if-empty ; ] [ last-class t ] if
] all?
[ +no-method+ or ] [ drop f ] if ;
M: depends-on-single-method satisfied? M: depends-on-single-method satisfied?
[ method-class>> ] [ object-class>> ] [ generic>> ] tri [ method-class>> ] [ object-class>> ] [ generic>> ] tri
subclass-with-only-method = ; subclass-with-only-method = ;
TUPLE: depends-on-method-is class generic method ; TUPLE: depends-on-method-identity class generic method ;
: depends-on-method-is ( class generic method -- ) : depends-on-method-identity ( class generic method -- )
[ [ depends-on-conditionally ] tri@ ] [ [ depends-on-conditionally ] tri@ ]
[ \ depends-on-method-is add-conditional-dependency ] 3bi ; [ \ depends-on-method-identity add-conditional-dependency ] 3bi ;
M: depends-on-method-is satisfied? M: depends-on-method-identity satisfied?
[ class>> ] [ generic>> method ] [ method>> ] tri = ; [ class>> ] [ generic>> method ] [ method>> ] tri = ;
: init-dependencies ( -- ) : init-dependencies ( -- )