CFG checker now checks consistency of successors and predecessors lists; fix long-standing bug in useless-blocks optimization

basis/compiler/cfg/checker/checker.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.linearization combinators.short-circuit accessors math
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
-sequences sets ;
+combinators.short-circuit accessors math sequences sets assocs ;
 IN: compiler.cfg.checker
 
 ERROR: last-insn-not-a-jump insn ;
@@ -27,11 +27,25 @@ ERROR: bad-loop-entry ;
         [ bad-loop-entry ] when
     ] [ drop ] if ;
 
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+    dup successors>> [ predecessors>> memq? ] with all?
+    [ bad-successors ] unless ;
+
 : check-basic-block ( bb -- )
-    [ check-last-instruction ] [ check-loop-entry ] bi ;
+    [ instructions>> check-last-instruction ]
+    [ instructions>> check-loop-entry ]
+    [ check-successors ]
+    tri ;
+
+ERROR: bad-live-in ;
 
 : check-rpo ( rpo -- )
-    [ instructions>> check-basic-block ] each ;
+    [ compute-liveness ]
+    [ first live-in assoc-empty? [ bad-live-in ] unless ]
+    [ [ check-basic-block ] each ]
+    tri ;
 
 ERROR: undefined-values uses defs ;
 

basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor

@@ -0,0 +1,11 @@
+IN: compiler.cfg.useless-blocks.tests
+USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
+
+{
+    [ [ drop 1 ] when ]
+    [ [ drop 1 ] unless ]
+} [
+    [ [ ] ] dip
+    '[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test
+] each

basis/compiler/cfg/useless-blocks/useless-blocks.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators classes vectors
+USING: kernel accessors sequences combinators combinators.short-circuit
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.useless-blocks
 
 : update-predecessor-for-delete ( bb -- )
+    ! We have to replace occurrences of bb with bb's successor
+    ! in bb's predecessor's list of successors.
     dup predecessors>> first [
         [
             2dup eq? [ drop successors>> first ] [ nip ] if
@@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
     ] change-successors drop ;
 
 : update-successor-for-delete ( bb -- )
-    [ predecessors>> first ]
+    ! We have to replace occurrences of bb with bb's predecessor
-    [ successors>> first predecessors>> ]
+    ! in bb's sucessor's list of predecessors.
-    bi set-first ;
+    dup successors>> first [
+        [
+            2dup eq? [ drop predecessors>> first ] [ nip ] if
+        ] with map
+    ] change-predecessors drop ;
 
 : delete-basic-block ( bb -- )
     [ update-predecessor-for-delete ]
@@ -23,12 +29,11 @@ IN: compiler.cfg.useless-blocks
 
 : delete-basic-block? ( bb -- ? )
     {
-        { [ dup instructions>> length 1 = not ] [ f ] }
+        [ instructions>> length 1 = ]
-        { [ dup predecessors>> length 1 = not ] [ f ] }
+        [ predecessors>> length 1 = ]
-        { [ dup successors>> length 1 = not ] [ f ] }
+        [ successors>> length 1 = ]
-        { [ dup instructions>> first ##branch? not ] [ f ] }
+        [ instructions>> first ##branch? ]
-        [ t ]
+    } 1&& ;
-    } cond nip ;
 
 : delete-useless-blocks ( cfg -- )
     [