Debugging compiler

basis/compiler/tests/optimizer.factor

@@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
 sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
-compiler.tree.builder compiler.tree.optimizer ;
+compiler.tree.builder compiler.tree.optimizer sequences.deep ;
 IN: optimizer.tests
 
 GENERIC: xyz ( obj -- obj )
@@ -353,3 +353,8 @@ TUPLE: some-tuple x ;
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+
+: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
+
+[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
+[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test

basis/compiler/tests/redefine4.factor

@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
 
 [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
 
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
 
 [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs math math.private
-math.partial-dispatch classes.tuple classes.tuple.private
+classes.algebra namespaces assocs words math math.private
+math.partial-dispatch classes classes.tuple classes.tuple.private
 definitions stack-checker.state stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
 [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
 
 [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
+
+: call-recursive-dce-7 ( obj -- elt ? )
+    dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
+
+[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
     #! corresponding inputs to the #call-recursive are live also.
     [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
 
-: return-recursive-phi-in ( #return-recursive -- phi-in )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
 M: #return-recursive compute-live-values*
-    [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
 
 M: #call-recursive compute-live-values*
     #! If the output of a #call-recursive is live, then the
@@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
         drop-values
     ] ;
 
-M: #recursive remove-dead-code* ( node -- nodes )
-    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
-    {
-        [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
-        [ drop [ (remove-dead-code) ] change-child drop ]
-        [ drop label>> [ filter-live ] change-enter-out drop ]
-        [ swap 2array ]
-    } 2cleave ;
-
 M: #enter-recursive remove-dead-code*
     [ filter-live ] change-out-d ;
 
@@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
     [ drop-call-recursive-outputs ]
     tri 3array ;
 
-M: #return-recursive remove-dead-code* ( node -- nodes )
-    dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
-    [ drop [ filter-live ] change-out-d drop ]
-    [ out-d>> >>in-d drop ]
-    [ swap 2array ]
-    2tri ;
+:: drop-recursive-inputs ( node -- shuffle )
+    [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
+            new-outputs [ shuffle out-d>> ] |
+        node new-outputs
+        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+        shuffle
+    ] ;
+
+:: drop-recursive-outputs ( node -- shuffle )
+    [let* | return [ node label>> return>> ]
+            new-inputs [ return in-d>> filter-live ]
+            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+        return
+        [ new-inputs >>in-d new-outputs >>out-d drop ]
+        [ drop-dead-outputs ]
+        bi
+    ] ;
+
+M:: #recursive remove-dead-code* ( node -- nodes )
+    [let* | drop-inputs [ node drop-recursive-inputs ]
+            drop-outputs [ node drop-recursive-outputs ] |
+         node [ (remove-dead-code) ] change-child drop
+         node label>> [ filter-live ] change-enter-out drop
+         drop-inputs node drop-outputs 3array
+    ] ;
+
+M: #return-recursive remove-dead-code* ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
-fry locals classes.algebra stack-checker.backend
+fry locals definitions classes.algebra
+stack-checker.state
+stack-checker.backend
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
@@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     ] ;
 
 : drop-dead-outputs ( node -- nodes )
-    dup out-d>> drop-dead-values
-    [ in-d>> >>out-d drop ] [ 2array ] 2bi ;
+    dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
 
 M: #introduce remove-dead-code* ( #introduce -- nodes )
-    drop-dead-outputs ;
+    dup drop-dead-outputs 2array ;
 
 M: #>r remove-dead-code*
     [ filter-live ] change-out-r
@@ -105,7 +106,9 @@ M: #push remove-dead-code*
     ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
-    in-d>> #drop remove-dead-code* ;
+    [ word>> +inlined+ depends-on ]
+    [ in-d>> #drop remove-dead-code* ]
+    bi ;
 
 : some-outputs-dead? ( #call -- ? )
     out-d>> [ live-value? not ] contains? ;
@@ -115,7 +118,7 @@ M: #call remove-dead-code*
         remove-flushable-call
     ] [
         dup some-outputs-dead? [
-            drop-dead-outputs
+            dup drop-dead-outputs 2array
         ] when
     ] if ;
 

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -125,21 +125,20 @@ SYMBOL: history
 : remember-inlining ( word -- )
     history [ swap suffix ] change ;
 
-: inline-word ( #call word -- )
+: inline-word ( #call word -- ? )
     dup history get memq? [
-        2drop
+        2drop f
     ] [
         [
             dup remember-inlining
             dupd def>> splicing-nodes >>body
             propagate-body
         ] with-scope
+        t
     ] if ;
 
 : inline-method-body ( #call word -- ? )
-    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+    2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
-
-: always-inline-word ( #call word -- ? ) inline-word t ;

basis/compiler/tree/propagation/simple/simple.factor

@@ -93,7 +93,7 @@ M: #declare propagate-before
 
 : do-inlining ( #call word -- ? )
     {
-        { [ dup always-inline-word? ] [ always-inline-word ] }
+        { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }

basis/stack-checker/inlining/inlining.factor

@@ -67,8 +67,10 @@ SYMBOL: enter-out
     [ entry-stack-height current-stack-height swap - ]
     bi*
     = [ 2drop ] [
+        terminated? get [ 2drop ] [
             word>> current-stack-height
             unbalanced-recursion-error inference-error
+        ] if
     ] if ;
 
 : end-recursive-word ( word label -- )
@@ -79,7 +81,7 @@ SYMBOL: enter-out
 : recursive-word-inputs ( label -- n )
     entry-stack-height d-in get + ;
 
-: (inline-recursive-word) ( word -- label in out visitor )
+: (inline-recursive-word) ( word -- label in out visitor terminated? )
     dup prepare-stack
     [
         init-inference
@@ -96,11 +98,13 @@ SYMBOL: enter-out
         dup recursive-word-inputs
         meta-d get
         stack-visitor get
+        terminated? get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )
     (inline-recursive-word)
-    [ consume-d ] [ output-d ] [ ] tri* #recursive, ;
+    [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
+    [ terminate ] when ;
 
 : check-call-height ( label -- )
     dup entry-stack-height current-stack-height >

basis/stack-checker/stack-checker-tests.factor

@@ -575,3 +575,8 @@ DEFER: eee'
 : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
 
 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
+
+: bogus-error ( x -- )
+    dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
+
+[ bogus-error ] must-infer

basis/state-parser/state-parser.factor

@@ -88,8 +88,7 @@ SYMBOL: prolog-data
 : next* ( -- )
     get-char [ (next) record ] when ;
 
-: skip-until ( quot -- )
-    #! quot: ( -- ? )
+: skip-until ( quot: ( -- ? ) -- )
     get-char [
         [ call ] keep swap [ drop ] [
             next skip-until

core/classes/mixin/mixin-tests.factor

@@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 [ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
 
 [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ "hi" empty-mixin? ] unit-test

core/classes/mixin/mixin.factor

@@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
     dup mixin-class? [
         drop
     ] [
-        { } redefine-mixin-class
+        [ { } redefine-mixin-class ]
+        [ update-classes ]
+        bi
     ] if ;
 
 TUPLE: check-mixin-class mixin ;

core/classes/tuple/tuple.factor

@@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
         tri* define-declared
     ] 3tri ;
 
+M: tuple-class update-generic
+    over new-class? [ 2drop ] [ call-next-method ] if ;
+
 M: tuple-class reset-class
     [
         dup "slots" word-prop [

core/generic/generic.factor

@@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
     [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
     values ;
 
-: update-generic ( class generic -- )
+GENERIC# update-generic 1 ( class generic -- )
+
+M: class update-generic
     affected-methods [ +called+ changed-definition ] each ;
 
 : with-methods ( class generic quot -- )

core/parser/parser.factor

@@ -24,7 +24,7 @@ t parser-notes set-global
 
 : note. ( str -- )
     parser-notes? [
-        file get [ path>> write ] when*
+        file get [ path>> write ":" write ] when* 
         lexer get line>> number>string write ": " write
         "Note: " write dup print
     ] when drop ;