#label optimizer fix

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index a4bf89eed7360ab203bad19ba2069ed3dd83f1ff..87cd31c9abb1071611840820888393639ed86a48 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -48,7 +48,6 @@
 \r
 + compiler:\r
 \r
-- removing unneeded #label\r
 - flushing optimization\r
 - compile-byte/cell: instantiating aliens\r
 - fix fixnum<< and /i overflow on PowerPC\r

diff --git a/doc/handbook.tex b/doc/handbook.tex
index 66012942436c25df8bc6a3b654040aeaf9926d6a..d78af4a01471e337a437b443ee0dda4bb7f0b420 100644 (file)
--- a/doc/handbook.tex
+++ b/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?
-[ eq? ] every?
+[ = ] monotonic?    ! is every element equal?
+[ 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.

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 23ca7b2304328f2c0a77eca2935de674b2eb4698..69403c4b008105e47043ab483f3556c4c01abd32 100644 (file)
--- a/library/compiler/linearizer.factor
+++ b/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 -- )

diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor
index da77a273374dd9a19746c94b73c163de4b5ca135..c940050df4b965f55d21b2a3857205f70e1392b1 100644 (file)
--- a/library/inference/dataflow.factor
+++ b/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? ;

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index f5d7740481293eb0f0c85a1a0df46cced26e6ee1..bd3d9a59d62d1fbfa0b5f034fe9bc0ed81243ef0 100644 (file)
--- a/library/inference/inference.factor
+++ b/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

diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor
index 5d0a0bf1086462f2589a6adadb40d63d130a437f..b9250aee84723c7d569b6260c18d45a3413d2e8e 100644 (file)
--- a/library/inference/optimizer.factor
+++ b/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 ;

diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor
index 3f7349bc7eb9da78998501ef35366262eb833f01..eee14d519663dc8c5fdde25a137b7a86c0a397c3 100644 (file)
--- a/library/inference/print-dataflow.factor
+++ b/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

diff --git a/library/inference/recursive-values.factor b/library/inference/recursive-values.factor
index aff97af702cb895befde647aea0e775537bc3311..820ef03f73be62fdb5f60e102f33622ac6be2bd0 100644 (file)
--- a/library/inference/recursive-values.factor
+++ b/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 -- )

diff --git a/library/inference/split-nodes.factor b/library/inference/split-nodes.factor
index e6189b7a54a77c7ba56e60ca26870cfe39defc72..7eaf23da8a002dd681265b180c69cab327c2c9a7 100644 (file)
--- a/library/inference/split-nodes.factor
+++ b/library/inference/split-nodes.factor
@@ -14,7 +14,7 @@ USING: kernel sequences words ;
 !   +--> Y --> X
 !   |
 !   +--> Z --> X
-    
+
 GENERIC: split-node* ( node -- )
 
 : split-node ( node -- )
@@ -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

diff --git a/library/inference/words.factor b/library/inference/words.factor
index 9e5391880a7ed1284e321e8ffd4ced3efb8a7b82..20fbb8b71a3a96ae53bd7b19c7352a2796b77b62 100644 (file)
--- a/library/inference/words.factor
+++ b/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 -- )

diff --git a/library/kernel.factor b/library/kernel.factor
index dd686b87c98db770e8c2c5cc01fb577a22f120e3..d591e986cfa2c432385674db30abe1315e76123c 100644 (file)
--- a/library/kernel.factor
+++ b/library/kernel.factor
@@ -3,18 +3,19 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
-: 2drop ( x x -- ) drop drop ; inline
-: 3drop ( x x x -- ) drop drop drop ; inline
-: 2dup ( x y -- x y x y ) over over ; inline
-: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
-: rot ( x y z -- y z x ) >r swap r> swap ; inline
-: -rot ( x y z -- z x y ) swap >r swap r> ; inline
-: dupd ( x y -- x x y ) >r dup r> ; inline
-: swapd ( x y z -- y x z ) >r swap r> ; inline
+: 2drop ( x x -- ) drop drop ;
+: 3drop ( x x x -- ) drop drop drop ;
+: 2dup ( x y -- x y x y ) over over ;
+: 3dup ( x y z -- x y z x y z ) pick pick pick ;
+: rot ( x y z -- y z x ) >r swap r> swap ;
+: -rot ( x y z -- z x y ) swap >r swap r> ;
+: dupd ( x y -- x x y ) >r dup r> ;
+: 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