diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index cdfc0e6d3d..05f9092ee1 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -182,14 +182,9 @@ M: fixnum annotate-entry-test-1 drop ; : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline -[ t ] [ - [ { bignum } declare annotate-entry-test-2 ] - \ annotate-entry-test-1 inlined? -] unit-test - [ f ] [ [ { bignum } declare annotate-entry-test-2 ] - M\ fixnum annotate-entry-test-1 inlined? + \ annotate-entry-test-1 inlined? ] unit-test [ t ] [ diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 2f1e7fe9c6..5375ff6881 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -5,7 +5,6 @@ math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators combinators.short-circuit words namespaces continuations classes fry hints locals -stack-checker.dependencies compiler.tree compiler.tree.builder compiler.tree.recursive @@ -48,33 +47,13 @@ M: callable splicing-nodes splicing-body ; ] if ] [ 2drop undo-inlining ] if ; -ERROR: bad-guarded-method-call class generic ; - -:: guard-code ( class generic -- quot/f ) - class generic method :> my-method - my-method [ class generic bad-guarded-method-call ] unless - class generic my-method depends-on-method-identity - generic dispatch# (picker) :> picker - [ - picker call class instance? - [ my-method execute ] - [ generic no-method ] if - ] ; - -:: guarded-method-call ( class generic -- quot/f ) - class generic subclass-with-only-method [ - [ class generic depends-on-single-method ] [ - dup +no-method+ = - [ drop [ generic no-method ] ] - [ generic guard-code ] if - ] bi - ] [ f ] if* ; - : inlining-standard-method ( #call word -- class/f method/f ) - 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ - [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> dup ] dip - { [ method-for-class ] [ guarded-method-call ] } 2|| + dup "methods" word-prop assoc-empty? [ 2drop f f ] [ + 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ + [ in-d>> ] [ [ dispatch# ] keep ] bi* + [ swap nth value-info class>> dup ] dip + method-for-class + ] if ] if ; : inline-standard-method ( #call word -- ? ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index c1be90a13a..e738a70fc3 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays system sorting math.libm math.floats.private math.integers.private math.intervals quotations effects alien alien.data sets -strings.private classes.tuple eval generic.single ; +strings.private ; FROM: math => float ; SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: void* @@ -693,7 +693,7 @@ M: fixnum bad-generic 1 fixnum+fast ; inline [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test -[ V{ integer } ] [ +[ V{ number } ] [ [ 0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times ] final-classes @@ -863,11 +863,11 @@ TUPLE: foo bar ; GENERIC: whatever ( x -- y ) M: number whatever drop foo ; inline -[ t ] [ [ 1 whatever new ] { new } M\ tuple-class new suffix inlined? ] unit-test +[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test : that-thing ( -- class ) foo ; -[ f ] [ [ that-thing new ] { new } M\ tuple-class new suffix inlined? ] unit-test +[ f ] [ [ that-thing new ] { new } inlined? ] unit-test GENERIC: whatever2 ( x -- y ) M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline @@ -878,8 +878,7 @@ M: f whatever2 ; inline SYMBOL: not-an-assoc -[ t ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test -[ f ] [ [ not-an-assoc at ] { no-method } inlined? ] unit-test +[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test [ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test @@ -891,8 +890,7 @@ SYMBOL: not-an-assoc [ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test [ f ] [ [ instance? ] { instance? } inlined? ] unit-test -[ t ] [ [ 5 instance? ] { instance? } inlined? ] unit-test -[ f ] [ [ 5 instance? ] { no-method } inlined? ] unit-test +[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test [ t ] [ [ array instance? ] { instance? } inlined? ] unit-test [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test @@ -979,45 +977,6 @@ M: tuple-with-read-only-slot clone [ string-nth ] final-info first interval>> 0 23 2^ [a,b] = ] unit-test -! Optimization on instance? -[ f ] [ [ { number } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test - -UNION: ?fixnum fixnum POSTPONE: f ; -[ t ] [ [ { ?fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test -[ t ] [ [ { fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test - -! Actually check to make sure that the generated code works properly -: instance-test-1 ( x -- ? ) { ?fixnum } declare fixnum instance? ; -: instance-test-2 ( x -- ? ) { number } declare fixnum instance? ; -: instance-test-3 ( x -- ? ) { POSTPONE: f } declare \ f instance? ; - -[ t ] [ 1 instance-test-1 ] unit-test -[ f ] [ f instance-test-1 ] unit-test -[ t ] [ 1 instance-test-2 ] unit-test -[ f ] [ 1.1 instance-test-2 ] unit-test -[ t ] [ f instance-test-3 ] unit-test - -[ t ] [ [ { ?fixnum } declare >fixnum ] { >fixnum } inlined? ] unit-test -[ f ] [ [ { integer } declare >fixnum ] { >fixnum } inlined? ] unit-test - -[ f ] [ [ { word } declare parent-word ] { parent-word } inlined? ] unit-test - -! Make sure guarded method inlining installs the right dependencies - -[ ] [ - "IN: compiler.tree.propagation.tests - USING: kernel.private accessors ; - TUPLE: foo bar ; - UNION: ?foo foo POSTPONE: f ; - : baz ( ?foo -- bar ) { ?foo } declare bar>> ;" eval( -- ) -] unit-test - -[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 3 foo boa baz" eval( -- x ) ] unit-test - -[ ] [ "IN: compiler.tree.propagation.tests TUPLE: foo baz bar ;" eval( -- ) ] unit-test - -[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 2 3 foo boa baz" eval( -- x ) ] unit-test - ! Non-zero displacement for restricts the output type [ t ] [ [ { byte-array } declare ] final-classes @@ -1036,9 +995,3 @@ UNION: ?fixnum fixnum POSTPONE: f ; [ V{ alien } ] [ [ { byte-array } declare [ 10 bitand 2 + ] dip ] final-classes ] 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 diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 947f481cef..28de7abd4b 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -142,23 +142,6 @@ IN: compiler.tree.propagation.transforms } case ] "custom-inlining" set-word-prop -:: inline-instance ( node -- quot/f ) - node in-d>> first2 [ value-info ] bi@ literal>> :> ( obj class ) - class class? [ - { - [ class \ f = not ] - [ obj class>> \ f class-not class-and class class<= ] - } 0&& [ - ! TODO: replace this with an implicit null check when - ! profitable, once Factor gets OSR implemented - [ drop >boolean ] - ] [ - class "predicate" word-prop '[ drop @ ] - ] if - ] [ f ] if ; - -\ instance? [ inline-instance ] "custom-inlining" set-word-prop - ERROR: bad-partial-eval quot word ; : check-effect ( quot word -- ) @@ -191,6 +174,11 @@ ERROR: bad-partial-eval quot word ; \ new [ inline-new ] 1 define-partial-eval +\ instance? [ + dup class? + [ "predicate" word-prop ] [ drop f ] if +] 1 define-partial-eval + ! Shuffling : nths-quot ( indices -- quot ) [ [ '[ _ swap nth ] ] map ] [ length ] bi @@ -313,6 +301,12 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval [ \ push def>> ] [ f ] if ] "custom-inlining" set-word-prop +! Speeds up fasta benchmark +\ >fixnum [ + in-d>> first value-info class>> fixnum \ f class-or class<= + [ [ dup [ \ >fixnum no-method ] unless ] ] [ f ] if +] "custom-inlining" set-word-prop + ! We want to constant-fold calls to heap-size, and recompile those ! calls when a C type is redefined \ heap-size [ diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index c380c5ed67..50d5ff6189 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs accessors classes classes.algebra fry generic kernel math namespaces sequences words sets -combinators.short-circuit classes.tuple alien.c-types -locals ; +combinators.short-circuit classes.tuple alien.c-types ; FROM: classes.tuple.private => tuple-layout ; FROM: assocs => change-at ; FROM: namespaces => set ; @@ -145,40 +144,6 @@ TUPLE: depends-on-final class ; M: depends-on-final satisfied? class>> { [ class? ] [ final-class? ] } 1&& ; -TUPLE: depends-on-single-method method-class object-class generic ; - -: depends-on-single-method ( method-class object-class generic -- ) - [ nip [ depends-on-conditionally ] bi@ ] - [ \ depends-on-single-method add-conditional-dependency ] 3bi ; - -SYMBOL: +no-method+ - -:: subclass-with-only-method ( class generic -- subclass/f/+no-method+ ) - f generic method-classes - [| last-class new-class | - class new-class classes-intersect? [ - last-class [ f f ] [ new-class t ] if - ] [ last-class t ] if - ] all? - [ +no-method+ or class null class<= not swap and ] - [ drop f ] if ; - -M: depends-on-single-method satisfied? - [ method-class>> ] [ object-class>> ] [ generic>> ] tri - { - [ [ drop ] [ classoid? ] [ generic? ] tri* and ] - [ subclass-with-only-method = ] - } 3&& ; - -TUPLE: depends-on-method-identity class generic method ; - -: depends-on-method-identity ( class generic method -- ) - [ [ depends-on-conditionally ] tri@ ] - [ \ depends-on-method-identity add-conditional-dependency ] 3bi ; - -M: depends-on-method-identity satisfied? - [ class>> ] [ generic>> method ] [ method>> ] tri = ; - : init-dependencies ( -- ) H{ } clone dependencies set H{ } clone generic-dependencies set