started some class inference, dataflow optimizer improvements

library/bootstrap/boot-stage2.factor

@@ -18,8 +18,6 @@ words ;
 "Loading compiler backend..." print
 
 cpu "x86" = [
-    "/library/compiler/vops.factor"
-    "/library/compiler/intrinsics.factor"
     "/library/compiler/x86/assembler.factor"
     "/library/compiler/x86/generator.factor"
     "/library/compiler/x86/slots.factor"

library/collections/hashtables.factor

@@ -166,6 +166,10 @@ M: hashtable hashcode ( hash -- n )
         pick rot >r >r call dup r> r> set-hash
     ] ifte* ; inline
 
+: map>hash ( seq quot -- hash | quot: elt -- value )
+    over >r map r> dup length <hashtable> -rot
+    [ pick set-hash ] 2each ; inline
+
 : ?hash ( key hash/f -- value/f )
     dup [ hash ] [ 2drop f ] ifte ;
 

library/collections/sequences-epilogue.factor

@@ -118,9 +118,7 @@ M: object empty? ( seq -- ? ) length 0 = ;
 M: object >list ( seq -- list ) dup length 0 rot (>list) ;
 
 : index   ( obj seq -- n )     [ = ] find-with drop ;
-: indq    ( obj seq -- n )     [ eq? ] find-with drop ;
 : index*  ( obj i seq -- n )   [ = ] find-with* drop ;
-: indq*   ( obj i seq -- n )   [ eq? ] find-with* drop ;
 : member? ( obj seq -- ? )     [ = ] contains-with? ;
 : memq?   ( obj seq -- ? )     [ eq? ] contains-with? ;
 : remove  ( obj list -- list ) [ = not ] subset-with ;
@@ -189,9 +187,6 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
 : seq-diff ( seq1 seq2 -- seq2-seq1 )
     [ swap member? not ] subset-with ;
 
-: seq-diffq ( seq1 seq2 -- seq2-seq1 )
-    [ swap memq? not ] subset-with ;
-
 : seq-union ( seq1 seq2 -- seq1\/seq2 )
     append prune ;
 
@@ -237,7 +232,7 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
     #! Substitute elements of old in seq with corresponding
     #! elements from new.
     [
-        dup pick indq dup -1 = [ drop ] [ nip pick nth ] ifte
+        dup pick index dup -1 = [ drop ] [ nip pick nth ] ifte
     ] map 2nip ;
 
 : copy-into ( to from -- )

library/inference/class-infer.factor

@@ -0,0 +1,63 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: generic hashtables kernel namespaces sequences words ;
+
+! Infer possible classes of values in a dataflow IR.
+
+! Variables used by the class inferencer
+
+! Current value --> class mapping
+SYMBOL: value-classes
+
+TUPLE: possibility value class ;
+
+! Maps possibilities to possibilities.
+SYMBOL: possible-classes
+
+GENERIC: infer-classes* ( node -- )
+
+: value-class ( value -- class )
+    value-classes get hash [ object ] unless* ;
+
+: annotate-node ( node -- )
+    #! Annotate the node with the currently-inferred set of
+    #! value classes.
+    dup node-values [ value-class ] map>hash
+    swap set-node-classes ;
+
+M: node infer-classes* ( node -- ) drop ;
+
+: assume-classes ( classes values -- )
+    [ value-classes get set-hash ] 2each ;
+
+: intersect-classes ( classes values -- )
+    [ [ value-class class-and ] 2map ] keep assume-classes ;
+
+M: #call infer-classes* ( node -- )
+    dup node-param "infer-effect" word-prop 2unseq
+    pick node-out-d assume-classes
+    swap node-in-d intersect-classes ;
+
+M: #push infer-classes* ( node -- )
+    node-out-d [
+        dup safe-literal? [
+            [ literal-value class ] keep
+            value-classes get set-hash
+        ] [
+            drop
+        ] ifte
+    ] each ;
+
+: (infer-classes) ( node -- )
+    dup infer-classes*
+    dup annotate-node
+    dup node-children [ (infer-classes) ] each
+    node-successor [ (infer-classes) ] when* ;
+
+: infer-classes ( node -- )
+    [
+        <namespace> value-classes set
+        <namespace> possible-classes set
+        (infer-classes)
+    ] with-scope ;

library/inference/dataflow.factor

@@ -9,15 +9,16 @@ sequences vectors words ;
 ! code with stack flow information and types.
 
 TUPLE: node param in-d out-d in-r out-r
-       successor children ;
+       classes successor children ;
 
-: make-node ( effect param in-d out-d in-r out-r node -- node )
-    [ >r f <node> r> set-delegate ] keep ;
+M: node = eq? ;
 
-: empty-node f f f f f f f f ;
-: param-node ( label) f f f f f ;
-: in-d-node ( inputs) >r f r> f f f f ;
-: out-d-node ( outputs) >r f f r> f f f ;
+: make-node ( param in-d out-d in-r out-r node -- node )
+    [ >r f f f <node> r> set-delegate ] keep ;
+
+: param-node ( label) f f f f ;
+: in-d-node ( inputs) >r f r> f f f ;
+: out-d-node ( outputs) >r f f r> f f ;
 
 : d-tail ( n -- list ) meta-d get tail* >vector ;
 : r-tail ( n -- list ) meta-r get tail* >vector ;
@@ -106,13 +107,13 @@ SYMBOL: current-node
 : node-effect ( node -- [[ d-in meta-d ]] )
     dup node-in-d swap node-out-d cons ;
 
-: consumes-literal? ( literal node -- ? )
-    #! Does the dataflow node consume the literal?
-    2dup node-in-d memq? >r node-in-r memq? r> or ;
+: node-values ( node -- values )
+    [
+        dup node-in-d % dup node-out-d %
+        dup node-in-r % node-out-r %
+    ] make-vector ;
 
-: produces-literal? ( literal node -- ? )
-    #! Does the dataflow node produce the literal?
-    2dup node-out-d memq? >r node-out-r memq? r> or ;
+: uses-value? ( value node -- ? ) node-values memq? ;
 
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;

library/inference/optimizer.factor

@@ -29,10 +29,10 @@ GENERIC: can-kill* ( literal node -- ? )
     dup literals [ swap can-kill? ] subset-with ;
 
 : remove-value ( value node -- )
-    2dup [ node-in-d seq-diffq ] keep set-node-in-d
-    2dup [ node-out-d seq-diffq ] keep set-node-out-d
-    2dup [ node-in-r seq-diffq ] keep set-node-in-r
-    [ node-out-r seq-diffq ] keep set-node-out-r ;
+    2dup [ node-in-d seq-diff ] keep set-node-in-d
+    2dup [ node-out-d seq-diff ] keep set-node-out-d
+    2dup [ node-in-r seq-diff ] keep set-node-in-r
+    [ node-out-r seq-diff ] keep set-node-out-r ;
 
 GENERIC: kill-node* ( literals node -- )
 
@@ -92,7 +92,7 @@ M: f can-kill* ( literal node -- ? )
     2drop t ;
 
 M: node can-kill* ( literal node -- ? )
-    2dup consumes-literal? >r produces-literal? r> or not ;
+    uses-value? ;
 
 M: node kill-node* ( literals node -- )
     2drop ;
@@ -110,7 +110,7 @@ M: #push can-kill* ( literal node -- ? )
     2drop t ;
 
 M: #push kill-node* ( literals node -- )
-    [ node-out-d seq-diffq ] keep set-node-out-d ;
+    [ node-out-d seq-diff ] keep set-node-out-d ;
 
 M: #push optimize-node* ( node -- node/t )
     [ node-out-d empty? ] prune-if ;
@@ -198,7 +198,7 @@ SYMBOL: branch-returns
     #! Check if the literal appears in either branch. This
     #! assumes that the last element of each branch is a #values
     #! node.
-    2dup consumes-literal? [
+    2dup uses-value? [
         2drop f
     ] [
         [
@@ -229,7 +229,7 @@ M: #dispatch can-kill* ( literal node -- ? )
 
 ! #values
 M: #values can-kill* ( literal node -- ? )
-    dupd consumes-literal? [
+    dupd uses-value? [
         branch-returns get
         [ memq? ] subset-with
         [ [ eq? ] fiber? ] all?

library/inference/print-dataflow.factor

@@ -1,6 +1,6 @@
 IN: inference
-USING: generic inference io kernel kernel-internals math
-namespaces prettyprint sequences vectors words ;
+USING: generic hashtables inference io kernel kernel-internals
+math namespaces prettyprint sequences vectors words ;
 
 ! A simple tool for turning dataflow IR into quotations, for
 ! debugging purposes.
@@ -13,13 +13,16 @@ M: annotation prettyprint* ( ann -- )
     "( " over annotation-text " )" append3
     swap annotation-node object. ;
 
-: value-str ( values -- str )
-    length "x" <repeated> " " join ;
+: value-str ( classes values -- str )
+    [ swap ?hash [ [ object ] ] unless* ] map-with
+    [ word-name ] map
+    " " join ;
 
 : effect-str ( node -- str )
     [
-        dup node-in-d value-str %
-        "-" %
+        dup node-classes swap
+        2dup node-in-d value-str %
+        "--" %
         node-out-d value-str %
     ] make-string ;
 

library/inference/values.factor

@@ -11,6 +11,8 @@ C: value ( recursion -- value )
     [ t swap set-value-safe? ] keep
     [ set-value-recursion ] keep ;
 
+M: value = eq? ;
+
 TUPLE: computed ;
 
 C: computed ( -- value )