Merge branch 'master' of git://factorcode.org/git/factor into propagation

Conflicts:

	basis/compiler/tree/propagation/propagation-tests.factor

diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 05f9092ee130fe95ee6e3f72e607fabc95beaed5..cdfc0e6d3df6013ed729a6908447740bdb8dc8b7 100644 (file)
--- 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 5375ff68819b246ebc1ec373aaee31cfd019f940..e6c63f149ad827bef29e21ac0f112097e56c8d67 100644 (file)
--- 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
@@ -47,12 +48,31 @@ M: callable splicing-nodes splicing-body ;
         ] if
     ] [ 2drop undo-inlining ] if ;
 
+ERROR: bad-splitting class generic ;
+
+:: split-code ( class generic -- quot/f )
+    class generic method :> my-method
+    my-method [ class generic bad-splitting ] unless
+    class generic my-method depends-on-method-is
+    generic dispatch# (picker) :> picker
+    [
+        picker call class instance?
+        [ my-method execute ]
+        [ generic no-method ] if
+    ] ;
+
+:: split-method-call ( class generic -- quot/f )
+    class generic subclass-with-only-method [
+        [ class generic depends-on-single-method ]
+        [ generic split-code ] bi
+    ] [ f ] if* ;
+
 : 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 ] [
             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
             [ swap nth value-info class>> dup ] dip
-            method-for-class
+            { [ method-for-class ] [ split-method-call ] } 2||
         ] if
     ] if ;
 

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index e738a70fc3377f604aed521ca1ac6486cf542270..d083b39b5bc98d14c4224d60fdabc0b7cb9ecada 100644 (file)
--- 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 eval ;
 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{ number } ] [
+[ V{ integer } ] [
     [
         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 } 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
@@ -977,6 +977,45 @@ 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 <displaced-alien> restricts the output type
 [ t ] [
     [ { byte-array } declare <displaced-alien> ] final-classes

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 3d2d7ac298c17d42ed59abac16b300aec34b15c7..da081800df53769b098a3f3aa136a56ac9d73a6c 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -141,6 +141,23 @@ 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 -- )
@@ -173,11 +190,6 @@ 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
@@ -300,12 +312,6 @@ 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 50d5ff6189f70932793d083f2692d40247c8011e..5a7386700643a3236b48ea88887a5260427f331e 100644 (file)
--- 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,34 @@ 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 ;
+
+:: 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?
+    [ method-class>> ] [ object-class>> ] [ generic>> ] tri
+    subclass-with-only-method = ;
+
+TUPLE: depends-on-method-is class generic method ;
+
+: depends-on-method-is ( class generic method -- )
+    [ [ depends-on-conditionally ] tri@ ]
+    [ \ depends-on-method-is add-conditional-dependency ] 3bi ;
+
+M: depends-on-method-is satisfied?
+    [ class>> ] [ generic>> method ] [ method>> ] tri = ;
+
 : init-dependencies ( -- )
     H{ } clone dependencies set
     H{ } clone generic-dependencies set