Inlining no-method when a generic word has no method
							parent
							
								
									05290ee1b1
								
							
						
					
					
						commit
						fbaa8d153f
					
				| 
						 | 
					@ -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 -- ? )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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 ( -- )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue