Working on method inlining optimization

TODO.FACTOR.txt

@@ -1,6 +1,5 @@
 should fix in 0.82:
 
-- type inference busted for tuple constructors
 - constant branch folding
 - fast-slot stuff
 - 3 >n fep

library/bootstrap/primitives.factor

@@ -258,12 +258,10 @@ num-types f <array> builtins set
 
 "fixnum?" "math" create t "inline" set-word-prop
 "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
-"fixnum" "math" create 0 "math-priority" set-word-prop
 "fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop
 
 "bignum?" "math" create t "inline" set-word-prop
 "bignum" "math" create 1 "bignum?" "math" create { } define-builtin
-"bignum" "math" create 1 "math-priority" set-word-prop
 "bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
 
 "cons?" "lists" create t "inline" set-word-prop
@@ -279,11 +277,9 @@ num-types f <array> builtins set
     { 0 integer { "numerator" "math" } f }
     { 1 integer { "denominator" "math" } f }
 } define-builtin
-"ratio" "math" create 2 "math-priority" set-word-prop
 
 "float?" "math" create t "inline" set-word-prop
 "float" "math" create 5 "float?" "math" create { } define-builtin
-"float" "math" create 3 "math-priority" set-word-prop
 "float" "math" create ">float" "math" lookup unit "coercer" set-word-prop
 
 "complex?" "math" create t "inline" set-word-prop
@@ -292,7 +288,6 @@ num-types f <array> builtins set
     { 0 real { "real" "math" } f }
     { 1 real { "imaginary" "math" } f }
 } define-builtin
-"complex" "math" create 4 "math-priority" set-word-prop
 
 "alien" "alien" create 7 "alien?" "alien" create
 { { 1 object { "underlying-alien" "alien" } f } } define-builtin

library/cocoa/utilities.factor

@@ -119,9 +119,6 @@ H{
 : class-methods ( classname -- seq )
     objc-meta-class objc-methods ;
 
-: make-dip ( quot n -- quot )
-    dup \ >r <array> -rot \ r> <array> append3 ;
-
 : <super> ( receiver class -- super )
     "objc-super" <c-object>
     [ set-objc-super-class ] keep

library/collections/lists.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: lists USING: errors generic kernel math sequences ;
+IN: lists USING: arrays errors generic kernel math sequences ;
 
 M: f car ;
 M: f cdr ;
@@ -79,6 +79,9 @@ M: cons = ( obj cons -- ? )
 
 : curry ( obj quot -- quot ) >r literalize r> cons ;
 
+: make-dip ( quot n -- quot )
+    dup \ >r <array> -rot \ r> <array> append3 >list ;
+
 : (>list) ( n i seq -- list )
     pick pick <= [
         3drop [ ]

library/collections/sequences.factor

@@ -26,7 +26,7 @@ GENERIC: reverse-slice ( seq -- seq ) flushable
     [ 1 <vector> ] unless* [ push ] keep ;
 
 : bounds-check? ( n seq -- ? )
-    over 0 >= [ length < ] [ 2drop f ] if ;
+    over 0 >= [ length < ] [ 2drop f ] if ; inline
 
 : ?nth ( n seq/f -- elt/f )
     2dup bounds-check? [ nth ] [ 2drop f ] if ;

library/compiler/optimizer/call-optimizers.factor

@@ -63,7 +63,7 @@ math math-internals sequences words ;
 } define-optimizers
 
 : useless-coerce? ( node -- )
-    dup node-in-d first over node-class
+    dup 0 node-class#
     swap node-param "infer-effect" word-prop second first eq? ;
 
 : call>no-op ( node -- node )

library/compiler/optimizer/class-infer.factor

@@ -9,6 +9,9 @@ kernel-internals math namespaces sequences words ;
 : node-class ( value node -- class )
     node-classes ?hash [ object ] unless* ;
 
+: node-class# ( node n -- class )
+    swap [ node-in-d reverse-slice nth ] keep node-class ;
+
 ! Variables used by the class inferencer
 
 ! Current value --> class mapping

library/compiler/optimizer/inline-methods.factor

@@ -1,37 +1,10 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
-USING: arrays generic hashtables inference kernel lists math
+USING: arrays generic hashtables inference kernel
-namespaces sequences words ;
+kernel-internals lists math namespaces sequences words ;
-
-! Method inlining optimization
-: dispatch# ( #call -- n )
-    node-param "combination" word-prop first ;
-
-: dispatching-class ( node -- seq )
-    dup dispatch# over node-in-d reverse-slice nth
-    swap node-class ;
-
-: already-inlined? ( node -- ? )
-    #! Was this node inlined from definition of 'word'?
-    dup node-param swap node-history memq? ;
-
-: specific-method ( word class -- ? ) swap order min-class ;
-
-: inlining-class ( #call -- class )
-    #! If the generic dispatch can be eliminated, return the
-    #! class of the method that will always be invoked here.
-    dup node-param swap dispatching-class
-    specific-method ;
-
-: will-inline-method ( node -- quot/t )
-    #! t indicates failure
-    dup inlining-class dup [
-        swap node-param "methods" word-prop hash
-    ] [
-        2drop t
-    ] if ;
 
+! Some utilities for splicing in dataflow IR subtrees
 : post-inline ( #return/#values #call/#merge -- )
     dup [
         [
@@ -54,12 +27,82 @@ namespaces sequences words ;
     ] [
         over node-in-d dataflow-with
         [ >r node-param r> remember-node ] 2keep
-        [ subst-node ] keep
+        [ subst-node ] keep [ infer-classes ] keep
+    ] if ;
+
+! Single dispatch method inlining optimization
+: dispatch# ( #call -- n )
+    node-param "combination" word-prop first ;
+
+: dispatching-class ( node -- seq ) dup dispatch# node-class# ;
+
+: already-inlined? ( node -- ? )
+    #! Was this node inlined from definition of 'word'?
+    dup node-param swap node-history memq? ;
+
+: specific-method ( word class -- ? ) swap order min-class ;
+
+: inlining-class ( #call -- class )
+    #! If the generic dispatch can be eliminated, return the
+    #! class of the method that will always be invoked here.
+    dup node-param swap dispatching-class
+    specific-method ;
+
+: will-inline-method ( node -- quot/t )
+    #! t indicates failure
+    dup inlining-class dup [
+        swap node-param "methods" word-prop hash
+    ] [
+        2drop t
     ] if ;
 
 : inline-standard-method ( node -- node )
     dup will-inline-method (inline-method) ;
 
+: inline-standard-method? ( #call -- ? )
+    dup already-inlined? not swap node-param standard-generic?
+    and ;
+
+! Partial dispatch of 2generic words
+: math-both-known? ( word left right -- ? )
+    math-class-max specific-method ;
+
+: max-tag ( class -- n ) types peek 1+ num-tags min ;
+
+: left-partial-math ( word left right -- quot/t )
+    #! The left type is known; dispatch on right
+    \ dup swap max-tag
+    [ >r 2dup r> math-method ] math-vtable* 2nip ;
+
+: right-partial-math ( word left right -- quot/t )
+    #! The right type is known; dispatch on left
+    \ over rot max-tag
+    [ >r 2dup r> swap math-method ] math-vtable* 2nip ;
+
+: will-inline-math-method ( word left right -- quot/t )
+    #! t indicates failure
+    {
+        { [ 3dup math-both-known? ] [ math-method ] }
+        { [ 3dup drop specific-method ] [ left-partial-math ] }
+        { [ 3dup nip specific-method ] [ right-partial-math ] }
+        { [ t ] [ 3drop t ] }
+    } cond ;
+
+: inline-math-method ( #call -- node )
+    dup node-param over 1 node-class# pick 0 node-class#
+    will-inline-math-method (inline-method) ;
+
+: inline-math-method? ( #call -- ? )
+    dup node-history empty? swap node-param 2generic? and ;
+
+: inline-method ( #call -- node )
+    {
+        { [ dup inline-standard-method? ] [ inline-standard-method ] }
+        { [ dup inline-math-method? ] [ inline-math-method ] }
+        { [ t ] [ drop t ] }
+    } cond ;
+
+! Resolve type checks at compile time where possible
 : comparable? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
     #! are disjoint, return t.
@@ -67,7 +110,7 @@ namespaces sequences words ;
 
 : optimize-predicate? ( #call -- ? )
     dup node-param "predicating" word-prop dup [
-        >r dup node-in-d node-classes* first r> comparable?
+        >r dup 0 node-class# r> comparable?
     ] [
         2drop f
     ] if ;
@@ -81,42 +124,4 @@ namespaces sequences words ;
 
 : optimize-predicate ( #call -- node )
     dup node-param "predicating" word-prop >r
-    dup dup node-in-d node-classes* first r> class<
+    dup 0 node-class# r> class< 1array inline-literals ;
-    1array inline-literals ;
-
-: math-both-known? ( word left right -- ? )
-    math-class-max specific-method ;
-    
-: partial-math ( word class left/right -- vtable )
-    dup \ dup \ over ? [
-        ( word class left/right class )
-        >r 3dup r> swap [ swap ] unless math-method
-    ] math-vtable >r 3drop r> ;
-
-: will-inline-math-method ( word left right -- quot/t )
-    #! t indicates failure
-    {
-        { [ 3dup math-both-known? ] [ math-method ] }
-        { [ 3dup drop specific-method ] [ drop t partial-math ] }
-        { [ 3dup nip specific-method ] [ nip f partial-math ] }
-        { [ t ] [ 3drop t ] }
-    } cond ;
-
-: inline-math-method ( #call -- node )
-    dup node-param
-    over dup node-in-d [ swap node-class ] map-with first2
-    will-inline-math-method (inline-method) ;
-
-: inline-standard-method? ( #call -- ? )
-    dup already-inlined? not swap node-param standard-generic?
-    and ;
-
-: inline-math-method? ( #call -- ? )
-    dup node-history empty? swap node-param 2generic? and ;
-
-: inline-method ( #call -- node )
-    {
-        { [ dup inline-standard-method? ] [ inline-standard-method ] }
-        { [ dup inline-math-method? ] [ inline-math-method ] }
-        { [ t ] [ drop t ] }
-    } cond ;

library/compiler/ppc/intrinsics.factor

@@ -67,7 +67,7 @@ math-internals namespaces sequences words ;
 ] H{
     { +input { { f "val" } { f "obj" } { f "slot" } } }
     { +scratch { { f "x" } } }
-    { +clobber { "obj" } }
+    { +clobber { "obj" "slot" } }
 } define-intrinsic
 
 \ set-char-slot [
@@ -77,7 +77,7 @@ math-internals namespaces sequences words ;
 ] H{
     { +input { { f "val" } { f "slot" } { f "obj" } } }
     { +scratch { { f "x" } } }
-    { +clobber { "obj" } }
+    { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
 : define-binary-op ( word op -- )

library/generic/generic.factor

@@ -39,7 +39,7 @@ SYMBOL: builtins
     ] hash-each ;
 
 : types ( class -- types )
-    [ (types) ] make-hash hash-keys ;
+    [ (types) ] make-hash hash-keys natural-sort ;
 
 DEFER: class<
 

library/generic/math-combination.factor

@@ -1,35 +1,29 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: generic
-USING: errors generic hashtables kernel kernel-internals lists
+USING: arrays errors generic hashtables kernel kernel-internals
-math namespaces sequences words ;
+lists math namespaces sequences words ;
 
 ! Math combination for generic dyadic upgrading arithmetic.
 
-: math-priority ( class -- n )
+: first/last ( seq -- pair ) dup first swap peek 2array ;
-    dup "members" word-prop [
-        0 [ math-priority max ] reduce
-    ] [
-        "math-priority" word-prop [ 100 ] unless*
-    ] ?if ;
 
-: math-class< ( class class -- ? )
+: math-class-compare ( class class -- n )
-    [ math-priority ] 2apply < ;
+    [
+        dup number class<
+        [ types first/last ] [ drop { 100 100 } ] if
+    ] 2apply <=> ;
 
 : math-class-max ( class class -- class )
-    [ swap math-class< ] 2keep ? ;
+    [ math-class-compare 0 > ] 2keep ? ;
+
+: (math-upgrade) ( max class -- quot )
+    dupd = [ drop [ ] ] [ "coercer" word-prop ] if ;
 
 : math-upgrade ( left right -- quot )
-    2dup math-class< [
+    [ math-class-max ] 2keep
-        nip "coercer" word-prop
+    >r over r> (math-upgrade)
-        dup [ [ >r ] swap [ r> ] append3 ] when
+    >r (math-upgrade) dup [ 1 make-dip ] when r> append ;
-    ] [
-        2dup swap math-class< [
-            drop "coercer" word-prop
-        ] [
-            2drop [ ]
-        ] if
-    ] if ;
 
 TUPLE: no-math-method left right generic ;
 
@@ -52,13 +46,16 @@ TUPLE: no-math-method left right generic ;
         2drop object-method
     ] if ;
 
-: math-vtable ( picker quot -- quot )
+: math-vtable* ( picker max quot -- quot )
     [
-        swap , \ tag ,
+        rot , \ tag ,
-        [ num-tags [ type>class ] map swap map % ] { } make ,
+        [ >r [ type>class ] map r> map % ] { } make ,
         \ dispatch ,
     ] [ ] make ; inline
 
+: math-vtable ( picker quot -- quot )
+    num-tags swap math-vtable* ; inline
+
 : math-class? ( object -- ? )
     dup word? [ "math-priority" word-prop ] [ drop f ] if ;
 

library/kernel.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: kernel
-USING: generic kernel-internals math-internals ;
+USING: generic kernel-internals math math-internals ;
 
 : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
 
@@ -81,7 +81,7 @@ IN: kernel-internals
 ! These words are unsafe. Don't use them.
 : declare ( types -- ) drop ;
 
-: array-capacity 1 slot ; inline
+: array-capacity 1 slot { fixnum } declare ; inline
 : array-nth swap 2 fixnum+fast slot ; inline
 : set-array-nth swap 2 fixnum+fast set-slot ; inline
 

library/test/generic.factor

@@ -200,3 +200,11 @@ TUPLE: delegating ;
 [ t ] [ \ + 2generic? ] unit-test
 
 [ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
+
+! Test math-combination
+[ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
+[ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
+[ number ] [ \ number \ float math-class-max ] unit-test
+[ float ] [ \ real \ float math-class-max ] unit-test