From c5d7ed58a5451ad508a307acae4f908009717aba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 27 Jul 2009 19:24:13 -0500
Subject: [PATCH] Debugging compiler.cfg.coalescing
---
.../compiler/cfg/builder/builder-tests.factor | 40 ++++++++++++-
.../compiler/cfg/coalescing/coalescing.factor | 2 +-
.../cfg/coalescing/copies/copies.factor | 4 +-
.../cfg/coalescing/renaming/renaming.factor | 36 ++++++++----
.../cfg/dominance/dominance-tests.factor | 1 +
.../cfg/optimizer/optimizer-tests.factor | 58 -------------------
6 files changed, 68 insertions(+), 73 deletions(-)
diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 812ef18e86..2de7c7c3d1 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -3,7 +3,8 @@ USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-arrays locals byte-arrays kernel.private math slots.private ;
+arrays locals byte-arrays kernel.private math slots.private vectors sbufs
+strings math.partial-dispatch strings.private ;
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
@@ -18,6 +19,13 @@ arrays locals byte-arrays kernel.private math slots.private ;
] if
] any? ; inline recursive
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+ test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
{
[ ]
[ dup ]
@@ -62,6 +70,36 @@ arrays locals byte-arrays kernel.private math slots.private ;
[ swap - + * ]
[ swap slot ]
[ blahblah ]
+ [ 1000 [ dup [ reverse ] when ] times ]
+ [ 1array ]
+ [ 1 2 ? ]
+ [ { array } declare [ ] map ]
+ [ { array } declare dup 1 slot [ 1 slot ] when ]
+ [ [ dup more? ] [ dup ] produce ]
+ [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+ [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+ [
+ { fixnum sbuf } declare 2dup 3 slot fixnum> [
+ over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+ ] [ ] if
+ ]
+ [ [ 2 fixnum* ] when 3 ]
+ [ [ 2 fixnum+ ] when 3 ]
+ [ [ 2 fixnum- ] when 3 ]
+ [ 10000 [ ] times ]
+ [
+ over integer? [
+ over dup 16 <-integer-fixnum
+ [ 0 >=-integer-fixnum ] [ drop f ] if [
+ nip dup
+ [ ] [ ] if
+ ] [ 2drop f ] if
+ ] [ 2drop f ] if
+ ]
+ [
+ pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
+ set-string-nth-fast
+ ]
} [
unit-test-cfg
] each
diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor
index afb364f4fe..28528068c2 100644
--- a/basis/compiler/cfg/coalescing/coalescing.factor
+++ b/basis/compiler/cfg/coalescing/coalescing.factor
@@ -54,6 +54,6 @@ SYMBOL: seen
dup compute-dfs
dup process-blocks
break-interferences
- insert-copies
dup perform-renaming
+ insert-copies
dup remove-phis ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor
index 86f9e12423..ab1c514c96 100644
--- a/basis/compiler/cfg/coalescing/copies/copies.factor
+++ b/basis/compiler/cfg/coalescing/copies/copies.factor
@@ -7,11 +7,11 @@ IN: compiler.cfg.coalescing.copies
: compute-copies ( assoc -- assoc' )
dup assoc-size <hashtable> [
'[
- [ _ set-at ] with each
+ [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] with each
] assoc-each
] keep ;
-: insert-copies ( cfg -- )
+: insert-copies ( -- )
waiting get [
[ instructions>> building ] dip '[
building get pop
diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor
index bad74807d0..848d0a4df0 100644
--- a/basis/compiler/cfg/coalescing/renaming/renaming.factor
+++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor
@@ -5,29 +5,43 @@ compiler.cfg.coalescing.state compiler.cfg.renaming compiler.cfg.rpo
disjoint-sets ;
IN: compiler.cfg.coalescing.renaming
+: build-disjoint-set ( assoc -- disjoint-set )
+ <disjoint-set> dup [
+ '[
+ [ _ add-atom ]
+ [ [ drop _ add-atom ] assoc-each ]
+ bi*
+ ] assoc-each
+ ] keep ;
+
: update-congruence-class ( dst assoc disjoint-set -- )
- [ keys swap ] dip
- [ nip add-atoms ]
- [ add-atom drop ]
- [ equate-all-with ] 3tri ;
+ [ keys swap ] dip equate-all-with ;
: build-congruence-classes ( -- disjoint-set )
renaming-sets get
- <disjoint-set> [
- '[
- _ update-congruence-class
- ] assoc-each
- ] keep ;
+ dup build-disjoint-set
+ [ '[ _ update-congruence-class ] assoc-each ] keep ;
: compute-renaming ( disjoint-set -- assoc )
[ parents>> ] keep
'[ drop dup _ representative ] assoc-map ;
-: perform-renaming ( cfg -- )
- build-congruence-classes compute-renaming renamings set
+: rename-blocks ( cfg -- )
[
instructions>> [
[ rename-insn-defs ]
[ rename-insn-uses ] bi
] each
] each-basic-block ;
+
+: rename-copies ( -- )
+ waiting renamings get '[
+ [
+ [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
+ ] assoc-map
+ ] change ;
+
+: perform-renaming ( cfg -- )
+ build-congruence-classes compute-renaming renamings set
+ rename-blocks
+ rename-copies ;
diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor
index 0d4513c848..3da98a5e87 100644
--- a/basis/compiler/cfg/dominance/dominance-tests.factor
+++ b/basis/compiler/cfg/dominance/dominance-tests.factor
@@ -7,6 +7,7 @@ compiler.cfg.predecessors ;
cfg new 0 get >>entry
compute-predecessors
dup compute-dominance
+ dup compute-dom-frontiers
compute-dfs ;
! Example with no back edges
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 695a586199..e69de29bb2 100755
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,58 +0,0 @@
-USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer
-fry kernel kernel.private math math.partial-dispatch math.private
-sbufs sequences sequences.private sets slots.private strings
-strings.private tools.test vectors layouts ;
-IN: compiler.cfg.optimizer.tests
-
-! Miscellaneous tests
-
-: more? ( x -- ? ) ;
-
-: test-case-1 ( -- ? ) f ;
-
-: test-case-2 ( -- )
- test-case-1 [ test-case-2 ] [ ] if ; inline recursive
-
-{
- [ 1array ]
- [ 1 2 ? ]
- [ { array } declare [ ] map ]
- [ { array } declare dup 1 slot [ 1 slot ] when ]
- [ [ dup more? ] [ dup ] produce ]
- [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
- [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
- [
- { fixnum sbuf } declare 2dup 3 slot fixnum> [
- over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
- ] [ ] if
- ]
- [ [ 2 fixnum* ] when 3 ]
- [ [ 2 fixnum+ ] when 3 ]
- [ [ 2 fixnum- ] when 3 ]
- [ 10000 [ ] times ]
- [
- over integer? [
- over dup 16 <-integer-fixnum
- [ 0 >=-integer-fixnum ] [ drop f ] if [
- nip dup
- [ ] [ ] if
- ] [ 2drop f ] if
- ] [ 2drop f ] if
- ]
- [
- pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
- set-string-nth-fast
- ]
-} [
- [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test
-] each
-
-cell 8 = [
- [ t ]
- [
- [
- 1 50 fixnum-shift-fast fixnum+fast
- ] test-mr first instructions>> [ ##add? ] any?
- ] unit-test
-] when