Debugging stack checking

basis/compiler/tests/redefine0.factor

@@ -0,0 +1,74 @@
+IN: compiler.tests.redefine0
+USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ;
+
+! Test ripple-up behavior
+: test-1 ( -- a ) 3 ;
+: test-2 ( -- ) test-1 ;
+
+[ test-2 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
+
+{ 0 0 } [ test-1 ] must-infer-as
+
+[ ] [ test-2 ] unit-test
+
+[ ] [
+    [
+        \ test-1 forget
+        \ test-2 forget
+    ] with-compilation-unit
+] unit-test
+
+: test-3 ( a -- ) drop ;
+: test-4 ( -- ) [ 1 2 3 ] test-3 ;
+
+[ ] [ test-4 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
+
+[ test-4 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+    [
+        \ test-3 forget
+        \ test-4 forget
+    ] with-compilation-unit
+] unit-test
+
+: test-5 ( a -- quot ) ;
+: test-6 ( a -- b ) test-5 ;
+
+[ 31337 ] [ 31337 test-6 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
+
+[ 31337 test-6 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+    [
+        \ test-5 forget
+        \ test-6 forget
+    ] with-compilation-unit
+] unit-test
+
+GENERIC: test-7 ( a -- b )
+
+M: integer test-7 + ;
+
+: test-8 ( a -- b ) 255 bitand 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
+
+[ 4 ] [ 1 3 test-7 ] unit-test
+[ 4 ] [ 1 259 test-8 ] unit-test
+
+[ ] [
+    [
+        \ test-7 forget
+        \ test-8 forget
+    ] with-compilation-unit
+] unit-test

basis/compiler/tests/redefine16.factor

@@ -7,3 +7,5 @@ quotations stack-checker ;
 [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
 [ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
 [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test

basis/compiler/tree/builder/builder.factor

@@ -25,7 +25,7 @@ IN: compiler.tree.builder
             [ f initial-recursive-state infer-quot ] bi*
         ] with-tree-builder
         unclip-last in-d>>
-    ] [ "OOPS" USE: io print flush 3drop f f ] recover ;
+    ] [ 3drop f f ] recover ;
 
 : build-sub-tree ( #call quot -- nodes/f )
     [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with

basis/compiler/tree/optimizer/optimizer.factor

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

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

@@ -166,9 +166,9 @@ SYMBOL: history
     [ history [ swap suffix ] change ]
     bi ;
 
-:: inline-word-def ( #call word quot -- ? )
+:: inline-word ( #call word -- ? )
     word history get memq? [ f ] [
-        #call quot splicing-nodes [
+        #call word specialized-def splicing-nodes [
             [
                 word remember-inlining
                 [ ] [ count-nodes ] [ (propagate) ] tri
@@ -177,9 +177,6 @@ SYMBOL: history
         ] [ f ] if*
     ] if ;
 
-: inline-word ( #call word -- ? )
-    dup specialized-def inline-word-def ;
-
 : inline-method-body ( #call word -- ? )
     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
@@ -199,10 +196,6 @@ SYMBOL: history
     call( #call -- word/quot/f )
     object swap eliminate-dispatch ;
 
-: inline-instance-check ( #call word -- ? )
-    over in-d>> second value-info literal>> dup class?
-    [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
-
 : (do-inlining) ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
@@ -214,7 +207,6 @@ SYMBOL: history
     #! discouraged, but it should still work.)
     {
         { [ dup never-inline-word? ] [ 2drop f ] }
-        { [ dup \ instance? eq? ] [ inline-instance-check ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -341,6 +341,11 @@ generic-comparison-ops [
     ] [ 2drop object-info ] if
 ] "outputs" set-word-prop
 
+\ instance? [
+    in-d>> second value-info literal>> dup class?
+    [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
 \ equal? [
     ! If first input has a known type and second input is an
     ! object, we convert this to [ swap equal? ].

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

@@ -216,7 +216,10 @@ M: object infer-call*
     dispatch <tuple-boa> exit load-local load-locals get-local
     drop-locals do-primitive alien-invoke alien-indirect
     alien-callback
-} [ t "special" set-word-prop ] each
+} [
+    [ t "special" set-word-prop ]
+    [ t "no-compile" set-word-prop ] bi
+] each
 
 M\ quotation call t "no-compile" set-word-prop
 M\ curry call t "no-compile" set-word-prop

core/classes/tuple/tuple-tests.factor

@@ -5,7 +5,7 @@ generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting summary
 columns math.order classes.private slots slots.private eval see
-words.symbol ;
+words.symbol compiler.errors ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -34,9 +34,7 @@ C: <redefinition-test> redefinition-test
 ! Make sure we handle changing shapes!
 TUPLE: point x y ;
 
-C: <point> point
-
-[ ] [ 100 200 <point> "p" set ] unit-test
+[ ] [ 100 200 point boa "p" set ] unit-test
 
 ! Use eval to sequence parsing explicitly
 [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
@@ -199,17 +197,6 @@ TUPLE: erg's-reshape-problem a b c d ;
 
 C: <erg's-reshape-problem> erg's-reshape-problem
 
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
-: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
-
-[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-
 ! Inheritance
 TUPLE: computer cpu ram ;
 C: <computer> computer
@@ -287,7 +274,7 @@ test-server-slot-values
 ! Dynamically changing inheritance hierarchy
 TUPLE: electronic-device ;
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 [ f ] [ electronic-device laptop class<= ] unit-test
 [ t ] [ server electronic-device class<= ] unit-test
@@ -303,17 +290,17 @@ TUPLE: electronic-device ;
 [ f ] [ "server" get laptop? ] unit-test
 [ t ] [ "server" get server? ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 [ f ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 test-laptop-slot-values
 test-server-slot-values
 
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 test-laptop-slot-values
 test-server-slot-values
@@ -326,7 +313,7 @@ TUPLE: make-me-some-accessors voltage grounded? ;
 [ ] [ "laptop" get 220 >>voltage drop ] unit-test
 [ ] [ "server" get 110 >>voltage drop ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
 
 test-laptop-slot-values
 test-server-slot-values
@@ -334,7 +321,7 @@ test-server-slot-values
 [ 220 ] [ "laptop" get voltage>> ] unit-test
 [ 110 ] [ "server" get voltage>> ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 test-laptop-slot-values
 test-server-slot-values
@@ -343,7 +330,7 @@ test-server-slot-values
 [ 110 ] [ "server" get voltage>> ] unit-test
 
 ! Reshaping superclass and subclass simultaneously
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
 
 test-laptop-slot-values
 test-server-slot-values
@@ -354,9 +341,7 @@ test-server-slot-values
 ! Reshape crash
 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
 
-C: <test2> test2
-
-"a" "b" <test2> "test" set
+"a" "b" test2 boa "test" set
 
 : test-a/b ( -- )
     [ "a" ] [ "test" get a>> ] unit-test
@@ -412,15 +397,17 @@ TUPLE: constructor-update-1 xxx ;
 
 TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
 
-C: <constructor-update-2> constructor-update-2
+: <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
 
 { 3 1 } [ <constructor-update-2> ] must-infer-as
 
 [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
 
-{ 5 1 } [ <constructor-update-2> ] must-infer-as
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
 
-[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+[ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
+
+[ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
 
 ! Redefinition problem
 TUPLE: redefinition-problem ;
@@ -623,7 +610,7 @@ must-fail-with
 
 : blah ( -- vec ) vector new ;
 
-\ blah must-infer
+[ vector new ] must-infer
 
 [ V{ } ] [ blah ] unit-test
 

core/compiler/units/units-tests.factor

@@ -1,4 +1,4 @@
-USING: definitions compiler.units tools.test arrays sequences words kernel
+USING: compiler definitions compiler.units tools.test arrays sequences words kernel
 accessors namespaces fry eval ;
 IN: compiler.units.tests
 
@@ -14,11 +14,13 @@ IN: compiler.units.tests
 
 ! Non-optimizing compiler bugs
 [ 1 1 ] [
-    "A" "B" <word> [ [ 1 ] dip ] 2array 1array modify-code-heap
+    "A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
     1 swap execute
 ] unit-test
 
 [ "A" "B" ] [
+    disable-compiler
+
     gensym "a" set
     gensym "b" set
     [
@@ -30,6 +32,8 @@ IN: compiler.units.tests
         "a" get [ "B" ] define
     ] with-compilation-unit
     "b" get execute
+
+    enable-compiler
 ] unit-test
 
 ! Notify observers even if compilation unit did nothing