From 9b6fb70ebae67f5e5dea20b18fe091ef47bfb078 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 18 Aug 2008 15:47:49 -0500
Subject: [PATCH] Debugging optimizer
---
basis/bootstrap/compiler/compiler.factor | 6 +-
basis/compiler/generator/generator.factor | 4 +-
.../tree/dead-code/branches/branches.factor | 66 ++++++++++---------
.../tree/dead-code/dead-code-tests.factor | 10 +--
.../escape-analysis-tests.factor | 12 +++-
.../tree/escape-analysis/simple/simple.factor | 10 +--
.../compiler/tree/optimizer/optimizer.factor | 8 +--
.../propagation/recursive/recursive.factor | 1 -
.../tuple-unboxing-tests.factor | 9 +++
.../tree/tuple-unboxing/tuple-unboxing.factor | 10 ++-
basis/debugger/threads/threads.factor | 3 +
basis/threads/threads.factor | 3 -
12 files changed, 82 insertions(+), 60 deletions(-)
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index cc6b4d1e81..b6c2f64efb 100755
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -80,9 +80,9 @@ nl
malloc calloc free memcpy
} compile-uncompiled
-{
- build-tree optimize-tree
-} compile-uncompiled
+{ build-tree } compile-uncompiled
+
+{ optimize-tree } compile-uncompiled
vocabs [ words compile-uncompiled "." write flush ] each
diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor
index f54ec441b0..4d826c40d2 100755
--- a/basis/compiler/generator/generator.factor
+++ b/basis/compiler/generator/generator.factor
@@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
%jump-label ;
: generate-call ( label -- next )
- dup maybe-compile
+ ! dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
@@ -232,7 +232,7 @@ M: #dispatch generate-node
] if ;
M: #call generate-node
- ! dup node-input-infos [ class>> ] map set-operand-classes
+ dup node-input-infos [ class>> ] map set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [
diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor
index b36eddfece..d94ae1b247 100644
--- a/basis/compiler/tree/dead-code/branches/branches.factor
+++ b/basis/compiler/tree/dead-code/branches/branches.factor
@@ -20,47 +20,49 @@ M: #phi compute-live-values*
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
2bi ;
+SYMBOL: if-node
+
M: #branch remove-dead-code*
- [ [ (remove-dead-code) ] map ] change-children ;
+ [ [ [ (remove-dead-code) ] map ] change-children ]
+ [ if-node set ]
+ bi ;
: remove-phi-inputs ( #phi -- )
dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d
dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r
drop ;
-! SYMBOL: if-node
-!
-! : dead-value-indices ( values -- indices )
-! [ length ] keep live-values get
-! '[ , nth , key? not ] filter ; inline
-!
-! : drop-d-values ( values indices -- node )
-! [ drop filter-live ] [ nths filter-live ] 2bi
-! [ make-values ] keep
-! [ drop ] [ zip ] 2bi
-! #shuffle ;
-!
-! : drop-r-values ( values indices -- nodes )
+: live-value-indices ( values -- indices )
+ [ length ] keep live-values get
+ '[ , nth , key? ] filter ; inline
+
+: drop-d-values ( values indices -- node )
+ [ drop filter-live ] [ nths ] 2bi
+ [ make-values ] keep
+ [ drop ] [ zip ] 2bi
+ #shuffle ;
+
+: drop-r-values ( values indices -- nodes ) 2drop f ;
! [ dup make-values [ #r> ] keep ] dip
! drop-d-values dup out-d>> dup make-values #>r
! 3array ;
-!
-! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
-! '[
-! [ , drop-d-values 1array ]
-! [ , drop-r-values ]
-! bi* 3append
-! ] 3map ;
-!
-! : hoist-drops ( #phi -- )
-! if-node get swap
-! {
-! [ phi-in-d>> ]
-! [ phi-in-r>> ]
-! [ out-d>> dead-value-indices ]
-! [ out-r>> dead-value-indices ]
-! } cleave
-! '[ , , , , insert-drops ] change-children drop ;
+
+: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
+ '[
+ [ , drop-d-values 1array ]
+ [ , drop-r-values ]
+ bi* 3append
+ ] 3map ;
+
+: hoist-drops ( #phi -- )
+ if-node get swap
+ {
+ [ phi-in-d>> ]
+ [ phi-in-r>> ]
+ [ out-d>> live-value-indices ]
+ [ out-r>> live-value-indices ]
+ } cleave
+ '[ , , , , insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d
@@ -69,7 +71,7 @@ M: #branch remove-dead-code*
M: #phi remove-dead-code*
{
- ! [ hoist-drops ]
+ [ hoist-drops ]
[ remove-phi-inputs ]
[ remove-phi-outputs ]
[ ]
diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index d587ae70f2..14e66fa648 100644
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@@ -4,7 +4,8 @@ compiler.tree.combinators compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
-kernel math stack-checker.state accessors combinators io ;
+kernel math stack-checker.state accessors combinators io
+prettyprint ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
@@ -96,9 +97,4 @@ IN: compiler.tree.dead-code.tests
[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
-: non-flushable-4 ( a -- b ) drop f ;
-
-: recursive-test-1 ( a b -- )
- dup 10 < [
- >r drop 5 non-flushable-4 r> 1 + recursive-test-1
- ] [ 2drop ] if ; inline recursive
+[ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 532c5a9ac3..7b0f03e13d 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics ;
+compiler.tree.intrinsics namespaces ;
\ escape-analysis must-infer
@@ -295,3 +295,13 @@ C: <ro-box> ro-box
[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
+
+: impeach-node ( quot: ( node -- ) -- )
+ dup slip impeach-node ; inline recursive
+
+: bleach-node ( quot: ( node -- ) -- )
+ [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
+
+[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 0edcd6c46c..f95d17dd1d 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -59,10 +59,10 @@ M: #push escape-analysis*
] [ 2drop f ] if ;
: record-slot-call ( #call -- )
- [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
- over [
- [ record-slot-access ] [ copy-slot-value ] 3bi
- ] [ 2drop unknown-allocation ] if ;
+ [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+ [ [ record-slot-access ] [ copy-slot-value ] 3bi ]
+ [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+ if ;
M: #call escape-analysis*
dup word>> {
@@ -88,3 +88,5 @@ M: #alien-indirect escape-analysis*
[ in-d>> add-escaping-values ]
[ out-d>> unknown-allocations ]
bi ;
+
+M: #alien-callback escape-analysis* drop ;
diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index 691795efdb..6e191157b0 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -21,10 +21,10 @@ IN: compiler.tree.optimizer
detect-loops
! invert-loops
! fuse-branches
- ! escape-analysis
- ! unbox-tuples
- ! compute-def-use
- ! remove-dead-code
+ escape-analysis
+ unbox-tuples
+ compute-def-use
+ remove-dead-code
! strength-reduce
compute-def-use USE: kernel
dup check-nodes ;
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 14a9427dd1..6b266c4ea8 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -52,7 +52,6 @@ IN: compiler.tree.propagation.recursive
3bi ;
M: #recursive propagate-around ( #recursive -- )
- "blah" USE: io print
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 0dd8f3e3de..8135572bb1 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -37,3 +37,12 @@ TUPLE: empty-tuple ;
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
+
+! A more complicated example
+: impeach-node ( quot: ( node -- ) -- )
+ dup slip impeach-node ; inline recursive
+
+: bleach-node ( quot: ( node -- ) -- )
+ [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
+
+[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index bc5e74b6d7..da89123a4b 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -58,9 +58,11 @@ M: #push unbox-tuples* ( #push -- nodes )
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
- [ in-d>> second 1array #drop ]
- [ prepare-slot-access slot-access-shuffle ]
- bi 2array
+ ! [ in-d>> second 1array #drop ]
+ ! [
+ prepare-slot-access slot-access-shuffle
+ ! ]
+ ! bi 2array
] when ;
M: #call unbox-tuples*
@@ -133,4 +135,6 @@ M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+M: #alien-callback unbox-tuples* ;
+
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor
index 90d70f6754..093d231d08 100644
--- a/basis/debugger/threads/threads.factor
+++ b/basis/debugger/threads/threads.factor
@@ -20,3 +20,6 @@ M: thread error-in-thread ( error thread -- )
error-thread get-global error-in-thread. print-error flush
] bind
] if ;
+
+[ self error-in-thread stop ]
+thread-error-hook set-global
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index c406d0db12..2ff2912d6f 100755
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -223,9 +223,6 @@ GENERIC: error-in-thread ( error thread -- )
dup register-thread
set-self ;
-[ self error-in-thread stop ]
-thread-error-hook set-global
-
PRIVATE>
[ init-threads ] "threads" add-init-hook