#label optimizer fix

TODO.FACTOR.txt

@@ -48,7 +48,6 @@
 
 + compiler:
 
-- removing unneeded #label
 - flushing optimization
 - compile-byte/cell: instantiating aliens
 - fix fixnum<< and /i overflow on PowerPC

doc/handbook.tex

@@ -2627,10 +2627,11 @@ Outputs \texttt{t} if the quotation yields true when applied to each element, ot
 \ordinaryword{monotonic?}{monotonic?~( seq quot -- ?~)}
 \texttt{quot:~element element -- ?}\\
 }
-Tests if all elements of the sequence are equivalent under the relation. The quotation should be an equality relation (see \ref{equality}), otherwise the result will not be useful. This is implemented by vacuously outputting \verb|t| if the sequence is empty, or otherwise, by applying the quotation to each element together with the first element in turn, and testing if it always yields a true value. Usually, this word is used to test if all elements of a sequence are equal, or the same element:
+Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation. Examples:
 \begin{verbatim}
-[ = ] every?
+[ = ] monotonic?    ! is every element equal?
-[ eq? ] every?
+[ eq? ] monotonic?  ! is every element identical?
+[ < ] monotonic?    ! is the sequence increasing?
 \end{verbatim}
 
 A pair of utility words test of every element in a sequence is true, or if the sequence contains at least one true element.

library/compiler/linearizer.factor

@@ -25,7 +25,7 @@ M: node linearize-node* ( node -- ) drop ;
 M: #label linearize-node* ( node -- )
     <label> dup %return-to , >r
     dup node-param %label ,
-    node-children first linearize-node
+    node-child linearize-node
     r> %label , ;
 
 M: #call linearize-node* ( node -- )

library/inference/dataflow.factor

@@ -64,6 +64,8 @@ M: node = eq? ;
 : d-tail ( n -- list ) meta-d get tail* >vector ;
 : r-tail ( n -- list ) meta-r get tail* >vector ;
 
+: node-child node-children first ;
+
 TUPLE: #label ;
 C: #label make-node ;
 : #label ( label -- node ) param-node <#label> ;
@@ -278,3 +280,15 @@ DEFER: subst-value
         dup node-children [ clone-node ] map over set-node-children
         dup node-successor clone-node over set-node-successor
     ] when ;
+
+GENERIC: calls-label* ( label node -- ? )
+
+M: node calls-label* 2drop f ;
+
+M: #call-label calls-label* node-param eq? ;
+
+: calls-label? ( label node -- ? )
+    [ calls-label* not ] all-nodes-with? not ;
+
+: recursive-label? ( node -- ? )
+    dup node-param swap calls-label? ;

library/inference/inference.factor

@@ -55,7 +55,7 @@ SYMBOL: d-in
     meta-d [ append ] change
     d-in [ append ] change ;
 
-: hairy-node ( node effect quot -- )
+: hairy-node ( node effect quot -- quot: -- )
     over car ensure-d
     -rot 2dup car length 0 rot node-inputs
     2slip

library/inference/optimizer.factor

@@ -80,15 +80,3 @@ M: #values optimize-node* ( node -- node/t )
 ! #return
 M: #return optimize-node* ( node -- node/t )
     optimize-fold ;
-
-! M: #label optimize-node* ( node -- node/t )
-!     dup node-param over node-children first calls-label? [
-!         drop t
-!     ] [
-!         dup node-children first dup node-successor [
-!             dup penultimate-node rot
-!             node-successor swap set-node-successor
-!         ] [
-!             drop node-successor
-!         ] ifte
-!     ] ifte ;

library/inference/print-dataflow.factor

@@ -51,7 +51,7 @@ M: #call-label node>quot ( ? node -- ) #call>quot ;
 
 M: #label node>quot ( ? node -- )
     [ "#label: " over node-param word-name append comment, ] 2keep
-    node-children first swap dataflow>quot , \ call ,  ;
+    node-child swap dataflow>quot , \ call ,  ;
 
 M: #ifte node>quot ( ? node -- )
     [ "#ifte" comment, ] 2keep

library/inference/recursive-values.factor

@@ -24,7 +24,7 @@ M: node solve-recursion* ( node -- ) drop ;
 
 M: #label solve-recursion* ( node -- )
     dup node-param over collect-recursion >r
-    node-children first dup node-in-d r> swap
+    node-child dup node-in-d r> swap
     join-values rot subst-values ;
 
 : solve-recursion ( node -- )

library/inference/split-nodes.factor

@@ -48,8 +48,9 @@ M: #ifte split-node* ( node -- )
 M: #dispatch split-node* ( node -- )
     split-branch ;
 
+! #label
 M: #label split-node* ( node -- )
-    node-children first split-node ;
+    node-child split-node ;
 
 : inline-literals ( node literals -- node )
     #! Make #push -> #return -> successor

library/inference/words.factor

@@ -119,13 +119,29 @@ M: symbol apply-object ( word -- )
         ] ifte*
     ] ifte* ;
 
+
+: splice-node ( node -- )
+    dup node-successor [
+        dup node, penultimate-node f over set-node-successor
+        dup current-node set
+    ] when drop ;
+
+: block, ( block -- )
+    #! If the block does not call itself, there is no point in
+    #! having the block node in the IR. Just add its contents.
+    dup recursive-label? [
+        node,
+    ] [
+        node-child splice-node
+    ] ifte ;
+
 M: compound apply-object ( word -- )
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get assoc [
         recursive-word
     ] [
         dup "inline" word-prop
-        [ inline-block node, ] [ apply-default ] ifte
+        [ inline-block block, ] [ apply-default ] ifte
     ] ifte* ;
 
 : infer-shuffle ( word -- )

library/kernel.factor

@@ -3,18 +3,19 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
-: 2drop ( x x -- ) drop drop ; inline
+: 2drop ( x x -- ) drop drop ;
-: 3drop ( x x x -- ) drop drop drop ; inline
+: 3drop ( x x x -- ) drop drop drop ;
-: 2dup ( x y -- x y x y ) over over ; inline
+: 2dup ( x y -- x y x y ) over over ;
-: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
+: 3dup ( x y z -- x y z x y z ) pick pick pick ;
-: rot ( x y z -- y z x ) >r swap r> swap ; inline
+: rot ( x y z -- y z x ) >r swap r> swap ;
-: -rot ( x y z -- z x y ) swap >r swap r> ; inline
+: -rot ( x y z -- z x y ) swap >r swap r> ;
-: dupd ( x y -- x x y ) >r dup r> ; inline
+: dupd ( x y -- x x y ) >r dup r> ;
-: swapd ( x y z -- y x z ) >r swap r> ; inline
+: swapd ( x y z -- y x z ) >r swap r> ;
+: nip ( x y -- y ) swap drop ;
+: 2nip ( x y z -- z ) >r drop drop r> ;
+: tuck ( x y -- y x y ) dup >r swap r> ;
+
 : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
-: nip ( x y -- y ) swap drop ; inline
-: 2nip ( x y z -- z ) >r drop drop r> ; inline
-: tuck ( x y -- y x y ) dup >r swap r> ; inline
 
 : clear ( -- )
     #! Clear the datastack. For interactive use only; invoking