diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 05f9092ee1..cdfc0e6d3d 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -182,11 +182,16 @@ M: fixnum annotate-entry-test-1 drop ; : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline -[ f ] [ +[ 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? +] unit-test + [ t ] [ [ { float } declare 10 [ 2.3 * ] times >float ] \ >float inlined? diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 19b515ba12..f33718a8b6 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -5,6 +5,7 @@ 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 @@ -50,26 +51,20 @@ M: callable splicing-nodes splicing-body ; ERROR: bad-splitting class generic ; :: split-code ( class generic -- quot/f ) - class generic method-for-class - [ class generic bad-splitting ] unless + class generic method-for-class :> method + method [ class generic bad-splitting ] unless + generic dispatch# (picker) :> picker [ - dup class instance? - [ generic execute ] + picker call class instance? + [ method execute ] [ generic no-method ] if ] ; -:: find-method-call ( class generic -- subclass/f ) - generic method-classes [ f ] [ - f swap [| last-class new-class | - class new-class classes-intersect? [ - last-class [ f f ] [ new-class t ] if - ] [ last-class t ] if - ] all? swap and - ] if-empty ; - :: split-method-call ( class generic -- quot/f ) - class generic find-method-call - [ generic split-code ] [ f ] if* ; + class generic subclass-with-only-method [ + class generic depends-on-single-method + generic split-code + ] [ f ] if* ; : inlining-standard-method ( #call word -- class/f method/f ) dup "methods" word-prop assoc-empty? [ 2drop f f ] [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 3b831aeb54..473285e8c5 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 ; +strings.private classes.tuple ; FROM: math => float ; SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: void* @@ -863,11 +863,11 @@ TUPLE: foo bar ; GENERIC: whatever ( x -- y ) M: number whatever drop foo ; inline -[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test +[ t ] [ [ 1 whatever new ] { new } M\ tuple-class new suffix inlined? ] unit-test : that-thing ( -- class ) foo ; -[ f ] [ [ that-thing new ] { new } inlined? ] unit-test +[ f ] [ [ that-thing new ] { new } M\ tuple-class new suffix inlined? ] unit-test GENERIC: whatever2 ( x -- y ) M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 50d5ff6189..5d74e85e87 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -2,7 +2,8 @@ ! 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 ; +combinators.short-circuit classes.tuple alien.c-types +locals ; FROM: classes.tuple.private => tuple-layout ; FROM: assocs => change-at ; FROM: namespaces => set ; @@ -144,6 +145,24 @@ TUPLE: depends-on-final class ; M: depends-on-final satisfied? class>> { [ class? ] [ final-class? ] } 1&& ; +TUPLE: depends-on-single-method class generic ; + +: depends-on-single-method ( class generic -- ) + [ nip depends-on-conditionally ] + [ \ depends-on-single-method add-conditional-dependency ] 2bi ; + +:: subclass-with-only-method ( class generic -- subclass/f ) + generic method-classes [ f ] [ + f swap [| last-class new-class | + class new-class classes-intersect? [ + last-class [ f f ] [ new-class t ] if + ] [ last-class t ] if + ] all? swap and + ] if-empty ; + +M: depends-on-single-method satisfied? + [ class>> ] [ generic>> ] bi subclass-with-only-method >boolean ; + : init-dependencies ( -- ) H{ } clone dependencies set H{ } clone generic-dependencies set