Refactor compiler.tree.builder to fix various regressions

basis/bootstrap/compiler/compiler.factor

@@ -108,7 +108,7 @@ nl
 
 "." write flush
 
-{ (compile) } compile-unoptimized
+{ compile-word } compile-unoptimized
 
 "." write flush
 

basis/compiler/cfg/debugger/debugger.factor

@@ -16,7 +16,7 @@ M: callable test-cfg
     build-tree optimize-tree gensym build-cfg ;
 
 M: word test-cfg
-    [ build-tree-from-word optimize-tree ] keep build-cfg ;
+    [ build-tree optimize-tree ] keep build-cfg ;
 
 SYMBOL: allocate-registers?
 

basis/compiler/compiler-docs.factor

@@ -27,12 +27,12 @@ $nl
 { $subsection compile-queue }
 "Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
 $nl
-"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
+"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
 { $list
-  { "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
+  { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
   { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
   { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
-  { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." }
+  { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
 }
 "If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
 $nl
@@ -60,7 +60,7 @@ HELP: decompile
 { $values { "word" word } }
 { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
 
-HELP: (compile)
+HELP: compile-word
 { $values { "word" word } }
 { $description "Compile a single word." }
 { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

basis/compiler/tests/optimizer.factor

@@ -303,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ;
 : member-test ( obj -- ? ) { + - * / /i } member? ;
 
 \ member-test def>> must-infer
-[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
+[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
 [ t ] [ \ + member-test ] unit-test
 [ f ] [ \ append member-test ] unit-test
 

basis/compiler/tests/redefine0.factor

@@ -1,5 +1,6 @@
 IN: compiler.tests.redefine0
-USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ;
+USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
+namespaces macros assocs ;
 
 ! Test ripple-up behavior
 : test-1 ( -- a ) 3 ;
@@ -61,7 +62,7 @@ M: integer test-7 + ;
 [ 1 test-7 ] [ not-compiled? ] must-fail-with
 [ 1 test-8 ] [ not-compiled? ] must-fail-with
 
-[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
 
 [ 4 ] [ 1 3 test-7 ] unit-test
 [ 4 ] [ 1 259 test-8 ] unit-test
@@ -72,3 +73,35 @@ M: integer test-7 + ;
         \ test-8 forget
     ] with-compilation-unit
 ] unit-test
+
+! Indirect dependency on an unoptimized word
+: test-9 ( -- ) ;
+<< SYMBOL: quot
+[ test-9 ] quot set-global >>
+MACRO: test-10 ( -- quot ) quot get ;
+: test-11 ( -- ) test-10 ;
+
+[ ] [ test-11 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
+
+! test-11 should get recompiled now
+
+[ test-11 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
+
+[ ] [ test-11 ] unit-test
+
+quot global delete-at
+
+[ ] [
+    [
+        \ test-9 forget
+        \ test-10 forget
+        \ test-11 forget
+        \ quot forget
+    ] with-compilation-unit
+] unit-test

basis/compiler/tree/builder/builder-docs.factor

@@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ;
 IN: compiler.tree.builder
 
 HELP: build-tree
-{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
+{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } }
 { $description "Attempts to construct tree SSA IR from a quotation." }
 { $notes "This is the first stage of the compiler." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
-HELP: build-tree-with
+HELP: build-sub-tree
-{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
+{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } }
-{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
+{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;
-{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;

basis/compiler/tree/builder/builder-tests.factor

@@ -4,24 +4,24 @@ compiler.tree stack-checker stack-checker.errors ;
 
 : inline-recursive ( -- ) inline-recursive ; inline recursive
 
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
+[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test
 
 : bad-recursion-1 ( a -- b )
     dup [ drop bad-recursion-1 5 ] [ ] if ;
 
-[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with
+[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with
 
 FORGET: bad-recursion-1
 
 : bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
 
-[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with
+[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with
 
 FORGET: bad-recursion-2
 
 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
 
-[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with
+[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with
 
 FORGET: bad-bin

basis/compiler/tree/builder/builder.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces
+USING: fry locals accessors quotations kernel sequences namespaces
 assocs words arrays vectors hints combinators continuations
 effects compiler.tree
 stack-checker
@@ -11,53 +11,55 @@ stack-checker.backend
 stack-checker.recursive-state ;
 IN: compiler.tree.builder
 
-: with-tree-builder ( quot -- nodes )
+<PRIVATE
-    '[ V{ } clone stack-visitor set @ ]
-    with-infer nip ; inline
 
-: build-tree ( quot -- nodes )
+GENERIC: (build-tree) ( quot -- )
-    [ f initial-recursive-state infer-quot ] with-tree-builder ;
 
-: build-tree-with ( in-stack quot -- nodes out-stack )
+M: callable (build-tree) f initial-recursive-state infer-quot ;
-    [
-        [
-            [ >vector \ meta-d set ]
-            [ f initial-recursive-state infer-quot ] bi*
-        ] with-tree-builder
-        unclip-last in-d>>
-    ] [ 3drop f f ] recover ;
-
-: build-sub-tree ( #call quot -- nodes/f )
-    [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
-    {
-        { [ over not ] [ 3drop f ] }
-        { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] }
-        [ rot #copy suffix ]
-    } cond ;
 
 : check-no-compile ( word -- )
     dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
 
-: (build-tree-from-word) ( word -- )
-    dup initial-recursive-state recursive-state set
-    dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
-    [ 1quotation ] [ specialized-def ] if
-    infer-quot-here ;
-
 : check-effect ( word effect -- )
     swap required-stack-effect 2dup effect<=
     [ 2drop ] [ effect-error ] if ;
 
-: finish-word ( word -- )
+: inline-recursive? ( word -- ? )
-    current-effect check-effect ;
+    [ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
 
-: build-tree-from-word ( word -- nodes )
+: word-body ( word -- quot )
-    [
+    dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
+
+M: word (build-tree)
+    {
+        [ initial-recursive-state recursive-state set ]
         [ check-no-compile ]
-        [ (build-tree-from-word) ]
+        [ word-body infer-quot-here ]
-        [ finish-word ]
+        [ current-effect check-effect ]
-        tri
+    } cleave ;
-    ] with-tree-builder ;
+
+: build-tree-with ( in-stack word/quot -- nodes )
+    [
+        V{ } clone stack-visitor set
+        [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+        [ (build-tree) ]
+        bi*
+    ] with-infer nip ;
+
+PRIVATE>
+
+: build-tree ( word/quot -- nodes )
+    [ f ] dip build-tree-with ;
+
+:: build-sub-tree ( #call word/quot -- nodes/f )
+    [
+        #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+        {
+            { [ dup not ] [ ] }
+            { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
+            [ in-d #call out-d>> #copy suffix ]
+        } cond
+    ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
 
 : contains-breakpoints? ( word -- ? )
     def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/checker/checker.factor

@@ -144,13 +144,15 @@ M: #terminate check-stack-flow*
 
 SYMBOL: branch-out
 
-: check-branch ( nodes -- stack )
+: check-branch ( nodes -- datastack )
     [
         datastack [ clone ] change
-        V{ } clone retainstack set
+        retainstack [ clone ] change
-        (check-stack-flow)
+        retainstack get clone [ (check-stack-flow) ] dip
-        terminated? get [ assert-retainstack-empty ] unless
+        terminated? get [ drop f ] [
-        terminated? get f datastack get ?
+            retainstack get assert=
+            datastack get
+        ] if
     ] with-scope ;
 
 M: #branch check-stack-flow*

basis/compiler/tree/debugger/debugger.factor

@@ -142,8 +142,7 @@ SYMBOL: node-count
 
 : make-report ( word/quot -- assoc )
     [
-        dup word? [ build-tree-from-word ] [ build-tree ] if
+        build-tree optimize-tree
-        optimize-tree
 
         H{ } clone words-called set
         H{ } clone generics-called set

basis/compiler/tree/optimizer/optimizer.factor

@@ -29,6 +29,7 @@ SYMBOL: check-optimizer?
     normalize
     propagate
     cleanup
+    ?check
     dup run-escape-analysis? [
         escape-analysis
         unbox-tuples

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

@@ -28,12 +28,10 @@ SYMBOL: node-count
 SYMBOL: inlining-count
 
 ! Splicing nodes
-GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f )
+: splicing-call ( #call word -- nodes )
-
-M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
-M: callable splicing-nodes
+: splicing-body ( #call quot/word -- nodes/f )
     build-sub-tree dup [ analyze-recursive normalize ] when ;
 
 ! Dispatch elimination
@@ -43,6 +41,12 @@ M: callable splicing-nodes
 : propagate-body ( #call -- ? )
     body>> (propagate) t ;
 
+GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
+
+M: word splicing-nodes splicing-call ;
+
+M: callable splicing-nodes splicing-body ;
+
 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
     dup [
         [ >>class ] dip
@@ -168,7 +172,7 @@ SYMBOL: history
 
 :: inline-word ( #call word -- ? )
     word history get memq? [ f ] [
-        #call word specialized-def splicing-nodes [
+        #call word splicing-body [
             [
                 word remember-inlining
                 [ ] [ count-nodes ] [ (propagate) ] tri

basis/stack-checker/backend/backend.factor

@@ -84,11 +84,8 @@ M: object apply-object push-literal ;
     meta-r empty? [ too-many->r ] unless ;
 
 : infer-quot-here ( quot -- )
-    meta-r [
+    [ apply-object terminated? get not ] all?
-        V{ } clone \ meta-r set
+    [ commit-literals ] [ literals get delete-all ] if ;
-        [ apply-object terminated? get not ] all?
-        [ commit-literals check->r ] [ literals get delete-all ] if
-    ] dip \ meta-r set ;
 
 : infer-quot ( quot rstate -- )
     recursive-state get [
@@ -116,10 +113,14 @@ M: object apply-object push-literal ;
     ] if ;
 
 : infer->r ( n -- )
-    consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
+    terminated? get [ drop ] [
+        consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi
+    ] if ;
 
 : infer-r> ( n -- )
-    consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
+    terminated? get [ drop ] [
+        consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi
+    ] if ;
 
 : (consume/produce) ( effect -- inputs outputs )
     [ in>> length consume-d ] [ out>> length produce-d ] bi ;
@@ -130,6 +131,7 @@ M: object apply-object push-literal ;
     bi ; inline
 
 : end-infer ( -- )
+    terminated? get [ check->r ] unless
     meta-d clone #return, ;
 
 : required-stack-effect ( word -- effect )

basis/stack-checker/known-words/known-words.factor

@@ -221,6 +221,10 @@ M: object infer-call*
     [ t "no-compile" set-word-prop ] bi
 ] each
 
+! Exceptions to the above
+\ curry f "no-compile" set-word-prop
+\ compose f "no-compile" set-word-prop
+
 M\ quotation call t "no-compile" set-word-prop
 M\ curry call t "no-compile" set-word-prop
 M\ compose call t "no-compile" set-word-prop

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

@@ -299,7 +299,7 @@ ERROR: custom-error ;
     [ custom-error inference-error ] infer
 ] unit-test
 
-[ T{ effect f 1 2 t } ] [
+[ T{ effect f 1 1 t } ] [
     [ dup [ 3 throw ] dip ] infer
 ] unit-test
 

basis/stack-checker/state/state.factor

@@ -42,6 +42,7 @@ SYMBOL: literals
 : init-inference ( -- )
     terminated? off
     V{ } clone \ meta-d set
+    V{ } clone \ meta-r set
     V{ } clone literals set
     0 d-in set ;