dataflow optimizer fixes, minor generic word cleanups

library/collections/cons.factor

@@ -14,7 +14,7 @@ BUILTIN: cons 2 cons? { 0 "car" f } { 1 "cdr" f } ;
 M: f car ;
 M: f cdr ;
 
-UNION: general-list f cons ;
+UNION: general-list POSTPONE: f cons ;
 
 GENERIC: >list ( seq -- list )
 M: general-list >list ( list -- list ) ;

library/compiler/linearizer.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-frontend
-USING: compiler-backend errors generic inference kernel
-kernel-internals lists math namespaces prettyprint sequences
+USING: compiler-backend errors generic lists inference kernel
+kernel-internals math namespaces prettyprint sequences
 strings words ;
 
 GENERIC: linearize-node* ( node -- )
@@ -22,10 +22,13 @@ M: f linearize-node* ( f -- ) drop ;
 M: #label linearize-node* ( node -- )
     <label> dup %return-to , >r
     dup node-param %label ,
-    node-children car linearize-node
+    node-children first linearize-node
     f %return ,
     r> %label , ;
 
+M: #simple-label linearize-node* ( node -- )
+    node-children first linearize-node ;
+
 M: #call linearize-node* ( node -- )
     dup node-param
     dup "intrinsic" word-prop [

library/generic/builtin.factor

@@ -25,9 +25,9 @@ builtin 50 "priority" set-word-prop
 builtin [ (class<) ] "class<" set-word-prop
 
 : builtin-predicate ( class predicate -- )
-    2dup register-predicate
-    [ \ type , swap "builtin-type" word-prop , \ eq? , ] make-list
-    define-compound ;
+    [
+        \ type , over "builtin-type" word-prop , \ eq? ,
+    ] make-list define-predicate ;
 
 : register-builtin ( class -- )
     dup "builtin-type" word-prop builtins get set-nth ;

library/generic/generic.factor

@@ -10,7 +10,8 @@ math-internals ;
 : predicate-word ( word -- word )
     word-name "?" append create-in ;
 
-: register-predicate ( class predicate -- )
+: define-predicate ( class predicate quot -- )
+    dupd define-compound
     2dup unit "predicate" set-word-prop
     swap "predicating" set-word-prop ;
 

library/generic/predicate.factor

@@ -45,11 +45,11 @@ predicate [
     ] ifte
 ] "class<" set-word-prop
 
-: define-predicate ( class predicate definition -- )
-    pick over "definition" set-word-prop
+: define-predicate-class ( class predicate definition -- )
+    3dup nip "definition" set-word-prop
+    pick predicate "metaclass" set-word-prop
     pick "superclass" word-prop "predicate" word-prop
     [ \ dup , % , [ drop f ] , \ ifte , ] make-list
-    define-compound
-    predicate "metaclass" set-word-prop ;
+    define-predicate ;
 
 PREDICATE: word predicate metaclass predicate = ;

library/generic/tuple.factor

@@ -28,9 +28,8 @@ BUILTIN: tuple 18 tuple? ;
     #! Make a foo? word for testing the tuple class at the top
     #! of the stack.
     dup predicate-word
-    2dup register-predicate
-    swap [ \ class , literal, \ eq? , ] make-list
-    define-compound ;
+    [ \ class , over literal, \ eq? , ] make-list
+    define-predicate ;
 
 : forget-tuple ( class -- )
     dup forget "predicate" word-prop car [ forget ] when* ;

library/generic/union.factor

@@ -22,7 +22,7 @@ union 50 "priority" set-word-prop
 
 union [ (class<) ] "class<" set-word-prop
 
-: union-predicate ( definition -- list )
+: union-predicate ( members -- list )
     [
         [
             \ dup ,
@@ -35,18 +35,10 @@ union [ (class<) ] "class<" set-word-prop
         [ drop f ]
     ] ifte* ;
 
-: define-union ( class predicate definition -- )
+: define-union ( class predicate members -- )
     #! We have to turn the f object into the f word, same for t.
-    [
-        [
-            [
-                [[ f POSTPONE: f ]]
-                [[ t POSTPONE: t ]]
-            ] assoc dup
-        ] keep ?
-    ] map
-    [ union-predicate define-compound ] keep
-    dupd "members" set-word-prop
-    union define-class ;
+    3dup nip "members" set-word-prop
+    pick union define-class
+    union-predicate define-predicate ;
 
 PREDICATE: word union metaclass union = ;

library/inference/dataflow.factor

@@ -27,6 +27,10 @@ TUPLE: #label ;
 C: #label make-node ;
 : #label ( label -- node ) param-node <#label> ;
 
+TUPLE: #simple-label ;
+C: #simple-label make-node ;
+: #simple-label ( label -- node ) param-node <#simple-label> ;
+
 TUPLE: #call ;
 C: #call make-node ;
 : #call ( word -- node ) param-node <#call> ;
@@ -118,6 +122,13 @@ SYMBOL: current-node
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;
 
+: penultimate-node ( node -- penultimate )
+    dup node-successor dup [
+        dup node-successor [ nip penultimate-node ] [ drop ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
 : drop-inputs ( node -- #drop )
     node-in-d in-d-node <#drop> ;
 

library/inference/inline-methods.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic hashtables kernel lists sequences vectors words ;
+USING: namespaces generic hashtables kernel lists sequences
+vectors words ;
 
 ! Method inlining optimization
 
@@ -33,23 +34,40 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 : inlining-class ( #call -- class )
     #! If the generic dispatch can be eliminated, return the
     #! class of the method that will always be invoked here.
-    dup dispatching-classes dup empty? [
-        2drop f
+    dup node-param recursive-state get member? [
+        drop f
     ] [
-        dup [ = ] every? [
-            first 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
         ] ifte
     ] ifte ;
 
-: subst-node
-    [ last-node set-node-successor ] keep ;
+: unlink-last ( node -- butlast last )
+    dup penultimate-node
+    dup node-successor
+    f rot set-node-successor ;
+
+: subst-node ( label old new -- new )
+    #! #simple-label<label> ---> new-last ---> old
+    #!     |---> new-butlast
+    dup node-successor [
+        unlink-last rot over set-node-successor
+        >r >r #simple-label r> 1vector over set-node-children
+        r> over set-node-successor
+    ] [
+        [ set-node-successor drop ] keep
+    ] ifte ;
 
 : inline-method ( node class -- node )
     over node-param "methods" word-prop hash
     over node-in-d dataflow-with
-    subst-node ;
+    >r [ node-param ] keep r> subst-node ;
 
 : related? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
@@ -72,8 +90,8 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     [ >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<
+    dup node-param "predicating" word-prop >r
+    dup dup node-in-d safe-node-classes first r> class<
     inline-literal ;
 
 M: #call optimize-node* ( node -- node/t )

library/inference/optimizer.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic hashtables inference kernel lists matrices
-namespaces sequences vectors ;
+USING: #<unknown> generic hashtables inference kernel lists
+matrices namespaces sequences vectors ;
+
+! We use the recursive-state variable here, to track nested
+! label scopes, to prevent infinite loops when inlining
+! recursive methods.
 
 GENERIC: literals* ( node -- )
 
@@ -57,11 +61,18 @@ GENERIC: optimize-node* ( node -- node )
 
 DEFER: optimize-node ( node -- node/t )
 
-: optimize-children ( node -- )
+GENERIC: optimize-children
+
+M: node optimize-children ( node -- )
     f swap [
         node-children [ optimize-node swap >r or r> ] map
     ] keep set-node-children ;
 
+: optimize-label ( node -- node )
+    dup node-param recursive-state [ cons ] change
+    delegate optimize-children
+    recursive-state [ cdr ] change ;
+
 : keep-optimizing ( node -- node ? )
     dup optimize-node* dup t =
     [ drop f ] [ nip keep-optimizing t or ] ifte ;
@@ -77,10 +88,12 @@ 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
-    dup infer-classes
-    optimize-node
-    [ optimize ] when ;
+    [
+        recursive-state off
+        dup kill-set over kill-node
+        dup infer-classes
+        optimize-node
+    ] with-scope [ optimize ] when ;
 
 : prune-if ( node quot -- successor/t )
     over >r call [ r> node-successor ] [ r> drop t ] ifte ;
@@ -182,6 +195,13 @@ M: #call-label can-kill* ( literal node -- ? )
 M: #label can-kill* ( literal node -- ? )
     node-children first can-kill? ;
 
+M: #simple-label can-kill* ( literal node -- ? )
+    node-children first can-kill? ;
+
+M: #label optimize-children optimize-label ;
+
+M: #simple-label optimize-children optimize-label ;
+
 ! #ifte
 SYMBOL: branch-returns
 

library/inference/print-dataflow.factor

@@ -53,6 +53,9 @@ M: #label node>quot ( ? node -- )
     [ "#label: " over node-param word-name append comment, ] 2keep
     node-children first swap dataflow>quot , \ call ,  ;
 
+M: #simple-label node>quot ( ? node -- )
+    node-children first swap dataflow>quot % ;
+
 M: #ifte node>quot ( ? node -- )
     [ "#ifte" comment, ] 2keep
     node-children [ swap dataflow>quot ] map-with % \ ifte , ;

library/kernel.factor

@@ -3,7 +3,7 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
-UNION: boolean f t ;
+UNION: boolean POSTPONE: f POSTPONE: t ;
 COMPLEMENT: general-t f
 
 GENERIC: hashcode ( obj -- n )

library/syntax/generic.factor

@@ -37,8 +37,7 @@ USING: syntax generic kernel lists namespaces parser words ;
     CREATE dup intern-symbol
     dup rot "superclass" set-word-prop
     dup predicate-word
-    [ dupd unit "predicate" set-word-prop ] keep
-    [ define-predicate ] [ ] ; parsing
+    [ define-predicate-class ] [ ] ; parsing
 
 : TUPLE:
     #! Followed by a tuple name, then slot names, then ;

library/test/compiler/optimizer.factor

@@ -1,4 +1,8 @@
-IN: temporary
+
+GENERIC: xyz
+M: cons xyz xyz ;
+
+[ ] [ \ xyz compile ] unit-testIN: temporary
 USING: generic kernel-internals strings vectors ;
 USE: test
 USE: assembler
@@ -111,3 +115,42 @@ GENERIC: xyz
 M: cons xyz xyz ;
 
 [ ] [ \ xyz compile ] unit-test
+
+! Test predicate inlining
+: pred-test-1
+    dup cons? [
+        dup general-list? [ "general-list" ] [ "nope" ] ifte
+    ] [
+        "not a cons"
+    ] ifte ; compiled
+
+[ [[ 1 2 ]] "general-list" ] [ [[ 1 2 ]] pred-test-1 ] unit-test
+
+: pred-test-2
+    dup fixnum? [
+        dup integer? [ "integer" ] [ "nope" ] ifte
+    ] [
+        "not a fixnum"
+    ] ifte ; compiled
+
+[ 1 "integer" ] [ 1 pred-test-2 ] unit-test
+
+TUPLE: pred-test ;
+
+: pred-test-3
+    dup tuple? [
+        dup pred-test? [ "pred-test" ] [ "nope" ] ifte
+    ] [
+        "not a tuple"
+    ] ifte ; compiled
+
+[ 1 "pred-test" ] [ << pred-test >> pred-test-3 ] unit-test
+
+: pred-test-4
+    dup pred-test? [
+        dup tuple? [ "pred-test" ] [ "nope" ] ifte
+    ] [
+        "not a tuple"
+    ] ifte ; compiled
+
+[ << pred-test >> "pred-test" ] [ << pred-test >> pred-test-4 ] unit-test

library/test/generic.factor

@@ -109,6 +109,7 @@ DEFER: bah
 FORGET: bah
 UNION: bah fixnum alien ;
 [ bah ] [ fixnum alien class-or ] unit-test
+[ bah ] [ \ bah? "predicating" word-prop ] unit-test
 
 DEFER: complement-test
 FORGET: complement-test