optimize out arithmetic dispatch and known-outcome type predicates

library/generic/generic.factor

@@ -180,13 +180,6 @@ SYMBOL: object
         ] ifte
     ] ifte ;
 
-: class-or-list ( list -- class )
-    #! Return a class that every class in the list is a
-    #! subclass of.
-    [
-        [ builtin-supertypes [ unique, ] each ] each
-    ] make-list lookup-union ;
-
 : class-and ( class class -- class )
     #! Return a class that is a subclass of both, or null in
     #! the degenerate case.

library/generic/slots.factor

@@ -7,7 +7,7 @@ IN: generic
 USING: kernel kernel-internals lists math namespaces parser
 sequences strings vectors words ;
 
-: simple-generic ( class generic def -- )
+: define-typecheck ( class generic def -- )
     #! Just like:
     #! GENERIC: generic
     #! M: class generic def ;
@@ -15,7 +15,7 @@ sequences strings vectors words ;
 
 : define-slot-word ( class slot word quot -- )
     over [
-        >r swap >fixnum r> cons simple-generic
+        >r swap >fixnum r> cons define-typecheck
     ] [
         2drop 2drop
     ] ifte ;

library/inference/class-infer.factor

@@ -88,9 +88,8 @@ M: node child-ties ( node -- seq )
 M: #call infer-classes* ( node -- )
     dup node-param [
         dup create-ties
-        dup node-param "infer-effect" word-prop 2unseq
-        pick node-out-d intersect-classes
-        swap node-in-d intersect-classes
+        dup node-param "infer-effect" word-prop second
+        swap node-out-d intersect-classes
     ] [
         drop
     ] ifte ;

library/inference/dataflow.factor

@@ -118,5 +118,8 @@ SYMBOL: current-node
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;
 
+: drop-inputs ( node -- #drop )
+    node-in-d in-d-node <#drop> ;
+
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state

library/inference/inline-methods.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic hashtables kernel sequences words ;
+USING: generic hashtables kernel lists sequences vectors words ;
 
 ! Method inlining optimization
+
 : min-class? ( class seq -- ? )
     #! Is this class the smallest class in the sequence?
     2dup member? [
@@ -14,42 +15,83 @@ USING: generic hashtables kernel sequences words ;
         2drop f
     ] ifte ;
 
-: node-dispatching-class ( node -- class )
-    dup node-in-d peek dup value-safe? [
-        swap node-classes ?hash
-    ] [
-        2drop object
-    ] ifte ;
+GENERIC: dispatching-values ( node word -- seq )
+
+M: object dispatching-values 2drop { } ;
+
+M: simple-generic dispatching-values drop node-in-d peek 1vector ;
+
+M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
+
+: safe-node-classes ( node seq -- seq )
+    >r node-classes r> [
+        dup value-safe? [
+            swap ?hash [ object ] unless*
+        ] [
+            2drop object
+        ] ifte
+    ] map-with ;
+
+: dispatching-classes ( node -- seq )
+    dup dup node-param dispatching-values safe-node-classes ;
 
 : inline-method? ( #call -- ? )
-    dup node-param "picker" word-prop [ dup ] = [
-        dup node-dispatching-class dup [
-            swap node-param order min-class?
+    dup dispatching-classes dup empty? [
+        2drop f
+    ] [
+        dup [ = ] every? [
+            first swap node-param order min-class?
         ] [
             2drop f
         ] ifte
-    ] [
-        drop f
     ] ifte ;
 
-: subst-node ( old new -- )
-    last-node set-node-successor ;
+: subst-node
+    [ last-node set-node-successor ] keep ;
 
 : inline-method ( node -- node )
-    dup node-dispatching-class
+    dup dispatching-classes first
     over node-param "methods" word-prop hash
     over node-in-d dataflow-with
-    [ subst-node ] keep ;
+    subst-node ;
+
+: related? ( class class -- ? )
+    #! If one of the two classes is contained in the other.
+    2dup class< >r swap class< r> or ;
+
+: optimize-predicate? ( #call -- ? )
+    dup node-param "predicating" word-prop dup [
+        swap dup node-in-d safe-node-classes first related?
+    ] [
+        2drop f
+    ] ifte ;
+
+: subst-literal ( successor literal -- #push )
+    #! Make #push -> #return -> successor
+    literalize dataflow [ last-node set-node-successor ] keep ;
+
+: inline-literal ( node literal -- node )
+    over drop-inputs
+    [ >r subst-literal r> set-node-successor ] keep ;
+
+: optimize-predicate ( #call -- node )
+    dup node-param "predicating" word-prop
+    over dup node-in-d safe-node-classes first class<
+    inline-literal ;
 
 M: #call optimize-node* ( node -- node/t )
     dup node-param [
         dup inline-method? [
             inline-method
         ] [
-            dup optimize-not? [
-                node-successor dup flip-branches
+            dup optimize-predicate? [
+                optimize-predicate
             ] [
-                drop t
+                dup optimize-not? [
+                    node-successor dup flip-branches
+                ] [
+                    drop t
+                ] ifte
             ] ifte
         ] ifte
     ] [

library/inference/optimizer.factor

@@ -206,7 +206,7 @@ SYMBOL: branch-returns
     node-in-d first dup safe-literal? ;
 
 : static-branch ( conditional n -- node )
-    >r [ node-in-d in-d-node <#drop> ] keep r>
+    >r [ drop-inputs ] keep r>
     over node-children nth
     over node-successor over last-node set-node-successor
     pick set-node-successor drop ;

library/test/generic.factor

@@ -199,3 +199,8 @@ TUPLE: delegating ;
 
 [ << shit f >> "shit" ] [ << shit f >> big-generic-test ] unit-test
 [ << shit f >> "shit" ] [ << delegating << shit f >> >> big-generic-test ] unit-test
+
+[ t ] [ \ = simple-generic? ] unit-test
+[ f ] [ \ each simple-generic? ] unit-test
+[ f ] [ \ object simple-generic? ] unit-test
+[ t ] [ \ + 2generic? ] unit-test