From ecece1d08b97e286d4eece489c9aa7b8815df1ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 02:49:51 -0500
Subject: [PATCH] CFG checker now checks consistency of successors and
predecessors lists; fix long-standing bug in useless-blocks optimization
---
basis/compiler/cfg/checker/checker.factor | 24 +++++++++++++----
.../useless-blocks-tests.factor | 11 ++++++++
.../cfg/useless-blocks/useless-blocks.factor | 27 +++++++++++--------
3 files changed, 46 insertions(+), 16 deletions(-)
create mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 53f0557db5..bc0eb74554 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/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
-compiler.cfg.linearization combinators.short-circuit accessors math
-sequences sets ;
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+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 ;
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
new file mode 100644
index 0000000000..ebc333b537
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
index b4999a8074..b6ec1a72ce 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ b/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
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+USING: kernel accessors sequences combinators combinators.short-circuit
+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 ]
- [ successors>> first predecessors>> ]
- bi set-first ;
+ ! We have to replace occurrences of bb with bb's predecessor
+ ! in bb's sucessor's list of predecessors.
+ 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 ] }
- { [ dup predecessors>> length 1 = not ] [ f ] }
- { [ dup successors>> length 1 = not ] [ f ] }
- { [ dup instructions>> first ##branch? not ] [ f ] }
- [ t ]
- } cond nip ;
+ [ instructions>> length 1 = ]
+ [ predecessors>> length 1 = ]
+ [ successors>> length 1 = ]
+ [ instructions>> first ##branch? ]
+ } 1&& ;
: delete-useless-blocks ( cfg -- )
[