Fix two problems with recompilation: predicate constant folding was recording unsatisfied dependencies in some cases, and literal tuple instances of forgotten classes would cause problems for method inlining

basis/compiler/crossref/crossref-tests.factor

@@ -0,0 +1,9 @@
+USING: compiler.crossref fry kernel sequences tools.test vocabs words ;
+IN: compiler.crossref.tests
+
+! Dependencies of all words should always be satisfied unless we're
+! in the middle of recompiling something
+[ { } ] [
+    all-words dup [ subwords ] map concat append
+    H{ } clone '[ _ dependencies-satisfied? not ] filter
+] unit-test

basis/compiler/tests/redefine22.factor

@@ -0,0 +1,11 @@
+IN: compiler.tests.redefine22
+USING: kernel sequences compiler.units vocabs tools.test definitions ;
+
+TUPLE: ttt ;
+INSTANCE: ttt sequence
+M: ttt new-sequence 2drop ttt new ;
+
+: www-1 ( a -- b ) T{ ttt } new-sequence ;
+
+! This used to break with a compiler error in the above word
+[ ] [ [ \ ttt forget ] with-compilation-unit ] unit-test

basis/compiler/tests/redefine23.factor

@@ -0,0 +1,13 @@
+IN: compiler.tests.redefine23
+USING: classes.struct specialized-arrays alien.c-types sequences
+compiler.units vocabs tools.test ;
+
+STRUCT: my-struct { x int } ;
+SPECIALIZED-ARRAY: my-struct
+: my-word ( a -- b ) iota [ my-struct <struct-boa> ] my-struct-array{ } map-as ;
+
+[ ] [
+    [
+        "specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
+    ] with-compilation-unit
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -51,11 +51,16 @@ GENERIC: cleanup* ( node -- node/nodes )
     [ in-d>> #drop ]
     bi prefix ;
 
-: record-predicate-folding ( #call -- )
+: >predicate-folding< ( #call -- value-info class result )
-    [ node-input-infos first class>> ]
+    [ node-input-infos first ]
     [ word>> "predicating" word-prop ]
-    [ node-output-infos first literal>> ] tri
+    [ node-output-infos first literal>> ] tri ;
-    [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+
+: record-predicate-folding ( #call -- )
+    >predicate-folding< pick literal?>>
+    [ [ literal>> ] 2dip depends-on-instance-predicate ]
+    [ [ class>> ] 2dip depends-on-class-predicate ]
+    if ;
 
 : record-folding ( #call -- )
     dup word>> predicate?

basis/compiler/tree/propagation/info/info.factor

@@ -1,10 +1,11 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals namespaces
+classes.tuple.private classes.singleton kernel accessors math
-sequences sequences.private words combinators memoize
+math.intervals namespaces sequences sequences.private words
-combinators.short-circuit byte-arrays strings arrays layouts
+combinators memoize combinators.short-circuit byte-arrays
-cpu.architecture compiler.tree.propagation.copy ;
+strings arrays layouts cpu.architecture
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -65,9 +66,17 @@ DEFER: <literal-info>
 
 UNION: fixed-length array byte-array string ;
 
+: literal-class ( obj -- class )
+    #! Handle forgotten tuples and singleton classes properly
+    dup singleton-class? [
+        class dup class? [
+            drop tuple
+        ] unless
+    ] unless ;
+
 : init-literal-info ( info -- info )
     empty-interval >>interval
-    dup literal>> class >>class
+    dup literal>> literal-class >>class
     dup literal>> {
         { [ dup real? ] [ [a,a] >>interval ] }
         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }

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

@@ -648,7 +648,7 @@ M: array iterate first t ; inline
     ] final-info drop
 ] unit-test
 
-[ V{ word } ] [
+[ V{ t } ] [
     [ { hashtable } declare hashtable instance? ] final-classes
 ] unit-test
 
@@ -660,7 +660,7 @@ M: array iterate first t ; inline
     [ { assoc } declare hashtable instance? ] final-classes
 ] unit-test
 
-[ V{ word } ] [
+[ V{ t } ] [
     [ { string } declare string? ] final-classes
 ] unit-test
 
@@ -774,7 +774,7 @@ MIXIN: empty-mixin
     [ { fixnum } declare log2 ] final-classes
 ] unit-test
 
-[ V{ word } ] [
+[ V{ t } ] [
     [ { fixnum } declare log2 0 >= ] final-classes
 ] unit-test
 

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences sequences.private assocs
 words namespaces classes.algebra combinators
@@ -93,11 +93,8 @@ M: #declare propagate-before
     recover ;
 
 : predicate-output-infos/class ( info class -- info )
-    [ class>> ] dip {
+    [ class>> ] dip compare-classes
-        { [ 2dup class<= ] [ t <literal-info> ] }
+    dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
-        { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
-        [ object-info ]
-    } cond 2nip ;
 
 : predicate-output-infos ( info class -- info )
     over literal?>>

basis/stack-checker/dependencies/dependencies.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors classes.algebra fry generic kernel math
+USING: assocs accessors classes classes.algebra fry generic
-namespaces sequences words sets combinators.short-circuit
+kernel math namespaces sequences words sets
-classes.tuple ;
+combinators.short-circuit classes.tuple ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: stack-checker.dependencies
 
@@ -57,28 +57,26 @@ GENERIC: satisfied? ( dependency -- ? )
     boa conditional-dependencies get
     dup [ conjoin ] [ 2drop ] if ; inline
 
-TUPLE: depends-on-class<= class1 class2 ;
+TUPLE: depends-on-class-predicate class1 class2 result ;
 
-: depends-on-class<= ( class1 class2 -- )
+: depends-on-class-predicate ( class1 class2 result -- )
-    \ depends-on-class<= add-conditional-dependency ;
+    \ depends-on-class-predicate add-conditional-dependency ;
 
-M: depends-on-class<= satisfied?
+M: depends-on-class-predicate satisfied?
     {
-        [ class1>> classoid? ]
+        [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
-        [ class2>> classoid? ]
+        [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
-        [ [ class1>> ] [ class2>> ] bi class<= ]
     } 1&& ;
 
-TUPLE: depends-on-classes-disjoint class1 class2 ;
+TUPLE: depends-on-instance-predicate object class result ;
 
-: depends-on-classes-disjoint ( class1 class2 -- )
+: depends-on-instance-predicate ( object class result -- )
-    \ depends-on-classes-disjoint add-conditional-dependency ;
+    \ depends-on-instance-predicate add-conditional-dependency ;
 
-M: depends-on-classes-disjoint satisfied?
+M: depends-on-instance-predicate satisfied?
     {
-        [ class1>> classoid? ]
+        [ class>> classoid? ]
-        [ class2>> classoid? ]
+        [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
-        [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
     } 1&& ;
 
 TUPLE: depends-on-next-method class generic next-method ;

core/classes/algebra/algebra.factor

@@ -234,3 +234,12 @@ ERROR: topological-sort-failed ;
 
 : flatten-class ( class -- assoc )
     [ (flatten-class) ] H{ } make-assoc ;
+
+SYMBOL: +incomparable+
+
+: compare-classes ( class1 class2 -- ? )
+    {
+        { [ 2dup class<= ] [ t ] }
+        { [ 2dup classes-intersect? not ] [ f ] }
+        [ +incomparable+ ]
+    } cond 2nip ;