Debugging optimizer

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
 

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
     ] [

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 ]
         [ ]

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

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

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 ;

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 ;

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

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

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 ;

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

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