Aggressive arithmetic inlining

library/compiler/optimizer/call-optimizers.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays errors generic hashtables inference kernel lists
 math math-internals sequences words ;
@@ -63,7 +63,7 @@ math math-internals sequences words ;
 } define-optimizers
 
 : useless-coerce? ( node -- )
-    dup node-in-d first over node-classes ?hash
+    dup node-in-d first over node-class
     swap node-param "infer-effect" word-prop second first eq? ;
 
 : call>no-op ( node -- node )
@@ -185,7 +185,6 @@ M: #call optimize-node* ( node -- node/t )
         { [ dup partial-eval? ] [ partial-eval ] }
         { [ dup find-identity nip ] [ apply-identities ] }
         { [ dup optimizer-hooks ] [ optimize-hooks ] }
-        { [ dup inlining-class ] [ inline-method ] }
         { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ t ] [ drop t ] }
+        { [ t ] [ inline-method ] }
     } cond ;

library/compiler/optimizer/class-infer.factor

@@ -6,6 +6,9 @@ kernel-internals math namespaces sequences words ;
 
 ! Infer possible classes of values in a dataflow IR.
 
+: node-class ( value node -- class )
+    node-classes ?hash [ object ] unless* ;
+
 ! Variables used by the class inferencer
 
 ! Current value --> class mapping

library/compiler/optimizer/inline-methods.factor

@@ -5,55 +5,33 @@ USING: arrays generic hashtables inference kernel lists math
 namespaces sequences words ;
 
 ! Method inlining optimization
+: dispatch# ( #call -- n )
+    node-param "combination" word-prop first ;
 
-GENERIC: dispatching-values ( node word -- seq )
+: dispatching-class ( node -- seq )
-
+    dup dispatch# over node-in-d reverse-slice nth
-M: object dispatching-values 2drop { } ;
+    swap node-class ;
-
-M: standard-generic dispatching-values
-    "combination" word-prop first swap
-    node-in-d reverse-slice nth 1array ;
-
-M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
-
-: node-classes* ( node seq -- seq )
-    >r node-classes r>
-    [ swap ?hash [ object ] unless* ] map-with ;
-
-: dispatching-classes ( node -- seq )
-    dup node-in-d empty? [
-        drop { }
-    ] [
-        dup dup node-param dispatching-values node-classes*
-    ] if ;
 
 : 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 already-inlined? [
+    dup node-param swap dispatching-class
-        drop f
+    specific-method ;
+
+: will-inline-method ( node -- quot/t )
+    #! t indicates failure
+    dup inlining-class dup [
+        swap node-param "methods" word-prop hash
     ] [
-        dup dispatching-classes dup empty? [
+        2drop t
-            2drop f
-        ] [
-            dup all-eq? [
-                first swap node-param order min-class
-            ] [
-                2drop f
-            ] if
-        ] if
     ] if ;
 
-: will-inline ( node -- quot )
-    dup inlining-class swap node-param "methods" word-prop hash ;
-
-: method-dataflow ( node -- dataflow )
-    dup will-inline swap node-in-d dataflow-with ;
-
 : post-inline ( #return/#values #call/#merge -- )
     dup [
         [
@@ -70,10 +48,17 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     #! last node of 'new' and the first node of 'old'.
     last-node 2dup swap post-inline set-node-successor ;
 
-: inline-method ( node -- node )
+: (inline-method) ( #call quot -- node )
-    dup method-dataflow
+    dup t eq? [
-    [ >r node-param r> remember-node ] 2keep
+        2drop t
-    [ subst-node ] keep ;
+    ] [
+        over node-in-d dataflow-with
+        [ >r node-param r> remember-node ] 2keep
+        [ subst-node ] keep
+    ] if ;
+
+: inline-standard-method ( node -- node )
+    dup will-inline-method (inline-method) ;
 
 : comparable? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
@@ -98,3 +83,40 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     dup node-param "predicating" word-prop >r
     dup dup node-in-d node-classes* first r> class<
     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/generic/math-combination.factor

@@ -7,7 +7,11 @@ math namespaces sequences words ;
 ! Math combination for generic dyadic upgrading arithmetic.
 
 : math-priority ( class -- n )
-    "math-priority" word-prop [ 100 ] unless* ;
+    dup "members" word-prop [
+        0 [ math-priority max ] reduce
+    ] [
+        "math-priority" word-prop [ 100 ] unless*
+    ] ?if ;
 
 : math-class< ( class class -- ? )
     [ math-priority ] 2apply < ;
@@ -67,11 +71,5 @@ TUPLE: no-math-method left right generic ;
         ] if nip
     ] math-vtable nip ;
 
-: partial-math-dispatch ( 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> ;
-
 PREDICATE: generic 2generic ( word -- ? )
     "combination" word-prop [ math-combination ] = ;

library/tools/describe.factor

@@ -31,7 +31,7 @@ M: object summary
 
 : slot-sheet ( obj -- sheet )
     dup class "slots" word-prop
-    dup [ second ] map -rot
+    dup [ third ] map -rot
     [ first slot ] map-with
     2array ;