method inlining

library/bootstrap/boot-stage1.factor

@@ -93,6 +93,7 @@ parser prettyprint sequences io vectors words ;
         "/library/inference/partial-eval.factor"
         "/library/inference/class-infer.factor"
         "/library/inference/optimizer.factor"
+        "/library/inference/inline-methods.factor"
         "/library/inference/print-dataflow.factor"
         
         "/library/compiler/assembler.factor"

library/bootstrap/boot-stage3.factor

@@ -41,7 +41,6 @@ compile? [
     \ = compile
     \ unparse compile
     \ scan compile
-    \ optimize compile
     \ (generate) compile
 ] when
 

library/generic/generic.factor

@@ -154,6 +154,12 @@ PREDICATE: compound generic ( word -- ? )
 
 M: generic definer drop \ G: ;
 
+PREDICATE: generic simple-generic ( word -- ? )
+    "picker" word-prop [ dup ] = ;
+
+PREDICATE: generic 2generic ( word -- ? )
+    "dispatcher" word-prop [ arithmetic-type ] = ;
+
 ! Maps lists of builtin type numbers to class objects.
 SYMBOL: typemap
 

library/inference/class-infer.factor

@@ -86,10 +86,14 @@ M: node child-ties ( node -- seq )
     ] ifte ;
 
 M: #call infer-classes* ( node -- )
-    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 [
+        dup create-ties
+        dup node-param "infer-effect" word-prop 2unseq
+        pick node-out-d intersect-classes
+        swap node-in-d intersect-classes
+    ] [
+        drop
+    ] ifte ;
 
 M: #push infer-classes* ( node -- )
     node-out-d [ safe-literal? ] subset
@@ -117,10 +121,12 @@ DEFER: (infer-classes)
     ] 2each ;
 
 : (infer-classes) ( node -- )
-    dup infer-classes*
-    dup annotate-node
-    dup infer-children
-    node-successor [ (infer-classes) ] when* ;
+    [
+        dup infer-classes*
+        dup annotate-node
+        dup infer-children
+        node-successor (infer-classes)
+    ] when* ;
 
 : infer-classes ( node -- )
     [

library/inference/inference.factor

@@ -39,7 +39,8 @@ SYMBOL: d-in
 
 : effect ( -- [[ in# out# ]] )
     #! After inference is finished, collect information.
-    d-in get length meta-d get length 2list ;
+    d-in get length object <repeated> >list
+    meta-d get length object <repeated> >list 2list ;
 
 : init-inference ( recursive-state -- )
     init-interpreter

library/inference/inline-methods.factor

@@ -0,0 +1,67 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: generic hashtables kernel sequences words ;
+
+! Method inlining optimization
+: min-class? ( class seq -- ? )
+    #! Is this class the smallest class in the sequence?
+    2dup member? [
+        [ dupd class-and ] map
+        [ null = not ] subset
+        [ class< ] all-with?
+    ] [
+        2drop f
+    ] ifte ;
+
+: node-dispatching-class ( node -- class )
+    dup node-in-d peek dup value-safe? [
+        swap node-classes ?hash
+    ] [
+        2drop object
+    ] ifte ;
+
+: inline-method? ( #call -- ? )
+    dup node-param "picker" word-prop [ dup ] = [
+        dup node-dispatching-class dup [
+            swap node-param order min-class?
+        ] [
+            2drop f
+        ] ifte
+    ] [
+        drop f
+    ] ifte ;
+
+: subst-node ( old new -- )
+    last-node set-node-successor ;
+
+: inline-method ( node -- node )
+    dup node-dispatching-class
+    over node-param "methods" word-prop hash
+    over node-in-d dataflow-with
+    [ subst-node ] keep ;
+
+M: #call optimize-node* ( node -- node/t )
+    dup node-param [
+        dup inline-method? [
+            inline-method
+        ] [
+            dup optimize-not? [
+                node-successor dup flip-branches
+            ] [
+                drop t
+            ] ifte
+        ] ifte
+    ] [
+        node-successor
+    ] ifte ;
+
+: post-inline ( #return #call -- node )
+    [ >r node-in-d r> node-out-d ] keep
+    node-successor [ subst-values ] keep ;
+
+M: #return optimize-node* ( node -- node/t )
+    #! A #return followed by another node is a result of
+    #! method inlining. Do a value substitution and drop both
+    #! nodes.
+    dup node-successor dup [ post-inline ] [ 2drop t ] ifte ;

library/inference/optimizer.factor

@@ -77,7 +77,9 @@ DEFER: optimize-node ( node -- node/t )
 : optimize ( dataflow -- dataflow )
     #! Remove redundant literals from the IR. The original IR
     #! is destructively modified.
-    dup kill-set over kill-node optimize-node
+    dup kill-set over kill-node
+    dup infer-classes
+    optimize-node
     [ optimize ] when ;
 
 : prune-if ( node quot -- successor/t )
@@ -172,13 +174,6 @@ M: #call kill-node* ( literals node -- )
 : flip-branches ( #ifte -- )
     dup node-children 2unseq swap 2vector swap set-node-children ;
 
-M: #call optimize-node* ( node -- node )
-     dup optimize-not? [
-         node-successor dup flip-branches
-     ] [
-         [ node-param not ] prune-if
-     ] ifte ;
-
 ! #call-label
 M: #call-label can-kill* ( literal node -- ? )
      2drop t ;
@@ -258,7 +253,7 @@ M: #values can-kill* ( literal node -- ? )
     dup node-successor dup node-successor
     values/merge [ subst-values ] keep ;
 
-M: #values optimize-node* ( node -- node )
+M: #values optimize-node* ( node -- node ? )
     dup node-successor #merge? [ post-split ] [ drop t ] ifte ;
 
 ! #merge

library/math/matrices.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: math
-USING: kernel sequences vectors ;
+USING: generic kernel sequences vectors ;
 
 ! Vectors
 : zero-vector ( n -- vector ) 0 <repeated> >vector ;
@@ -56,12 +56,24 @@ USING: kernel sequences vectors ;
     0 1 cross-minor 3vector ;
 
 ! Matrices
+
+! A diagonal of a matrix stored as a sequence of rows.
+TUPLE: diagonal index ;
+
+C: diagonal ( seq -- diagonal ) [ set-delegate ] keep ;
+
+: diagonal@ ( n diag -- n vec ) dupd delegate nth ;
+
+M: diagonal nth ( n diag -- elt ) diagonal@ nth ;
+
+M: diagonal set-nth ( elt n diag -- ) diagonal@ set-nth ;
+
 : zero-matrix ( m n -- matrix )
     swap [ drop zero-vector ] map-with ;
 
 : identity-matrix ( n -- matrix )
     #! Make a nxn identity matrix.
-    dup zero-matrix dup 0 <diagonal> [ drop 1 ] nmap ;
+    dup zero-matrix dup <diagonal> [ drop 1 ] nmap ;
 
 ! Matrix operations
 : mneg ( m -- m ) [ vneg ] map ;
@@ -88,4 +100,4 @@ USING: kernel sequences vectors ;
 : m.v ( m v -- v ) swap [ v. ] map-with ;
 : m.  ( m m -- m ) flip swap [ m.v ] map-with ;
 
-: trace ( matrix -- tr ) 0 <diagonal> product ;
+: trace ( matrix -- tr ) <diagonal> product ;

library/syntax/prettyprint.factor

@@ -91,17 +91,15 @@ M: word prettyprint* ( indent word -- indent )
         >r >r unparse. bl r> drop r> unparse.
     ] ifte ;
 
-M: list prettyprint* ( indent list -- indent )
+M: cons prettyprint* ( indent list -- indent )
    [
-       \ [ swap \ ] prettyprint-sequence
+       dup list? [
+           \ [ swap \ ]
+       ] [
+           \ [[ swap uncons 2list \ ]]
+       ] ifte prettyprint-sequence
    ] check-recursion ;
 
-M: cons prettyprint* ( indent cons -- indent )
-    #! Here we turn the cons into a list of two elements.
-    [
-        \ [[ swap uncons 2list \ ]] prettyprint-sequence
-    ] check-recursion ;
-
 M: vector prettyprint* ( indent vector -- indent )
     [
         \ { swap >list \ } prettyprint-sequence

library/test/compiler/optimizer.factor

@@ -1,4 +1,5 @@
 IN: temporary
+USING: generic kernel-internals strings vectors ;
 USE: test
 USE: assembler
 USE: compiler
@@ -73,3 +74,28 @@ USE: sequences
     [ 1 2 3 ] >r + r> drop ; compiled
 
 [ 4 ] [ 2 2 literal-kill-test-7 ] unit-test
+
+[ t ] [
+    \ string
+    [ range repeated integer string mirror array reversed sbuf
+    slice vector diagonal general-list ]
+    min-class?
+] unit-test
+
+[ f ] [
+    \ fixnum
+    [ fixnum integer letter ]
+    min-class?
+] unit-test
+
+[ t ] [
+    \ fixnum
+    [ fixnum integer object ]
+    min-class?
+] unit-test
+
+[ f ] [
+    \ fixnum
+    [ integer object ]
+    min-class?
+] unit-test

library/test/math/matrices.factor

@@ -92,13 +92,6 @@ unit-test
 [ { { 1 2 } { 3 4 } { 5 6 } } flip ]
 unit-test
 
-[
-    { { 7 } { 4 8 } { 1 5 9 } { 2 6 } { 3 } }
-] [
-    { { 1 2 3 } { 4 5 6 } { 7 8 9 } }
-    5 [ 2 - <diagonal> >vector ] map-with
-] unit-test
-
 [ { t t t } ]
 [ { 1 2 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
 unit-test