From 816f60a6e75beeaf0972de09a93bfbb51a194104 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 18 Aug 2006 03:50:59 +0000
Subject: [PATCH] Eliminate with-class<cache combinator in favor of a class<map
 that is always kept up to date

---
 library/bootstrap/boot-stage2.factor       | 51 ++++++++++------------
 library/bootstrap/image.factor             |  1 +
 library/bootstrap/primitives.factor        |  1 +
 library/compiler/compiler.factor           |  8 +---
 library/generic/classes.factor             | 49 ++++++++++++---------
 library/generic/classes.facts              | 10 -----
 library/test/collections/hashtables.factor |  7 +--
 library/test/generic.factor                | 51 +++++++++++-----------
 library/test/prettyprint.factor            | 12 ++---
 library/test/redefine.factor               |  4 +-
 10 files changed, 90 insertions(+), 104 deletions(-)

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index b6277c5d6f..64b347a900 100644
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -5,8 +5,8 @@ kernel-internals listener math memory namespaces optimizer
 parser sequences sequences-internals words ;
 
 [
-    ! Wrap everything in a catch which starts a listener so you can
-    ! see what went wrong, instead of dealing with a fep
+    ! Wrap everything in a catch which starts a listener so you
+    ! can see what went wrong, instead of dealing with a fep
     [
         "Cross-referencing..." print flush
         H{ } clone changed-words set-global
@@ -20,11 +20,28 @@ parser sequences sequences-internals words ;
         ] when
     
         "compile" get [
+            \ number= compile
+            \ + compile
+            \ nth compile
+            \ set-nth compile
+            \ = compile
+
+            ! Load UI backend
+            "cocoa" get [
+                "/library/compiler/alien/objc/load.factor" run-resource
+                "/library/ui/cocoa/load.factor" run-resource
+            ] when
+
+            "x11" get [
+                "/library/ui/x11/load.factor" run-resource
+            ] when
+
             windows? [
                 "/library/windows/load.factor" run-resource
                 "/library/ui/windows/load.factor" run-resource
             ] when
-    
+
+            ! Load native I/O code
             "native-io" get [
                 unix? [
                     "/library/io/unix/load.factor" run-resource
@@ -36,35 +53,11 @@ parser sequences sequences-internals words ;
     
             parse-command-line
     
-            "Compiling base..." print flush
-    
-            [
-                \ number= compile
-                \ + compile
-                \ nth compile
-                \ set-nth compile
-                \ = compile
-                { "kernel" "sequences" "assembler" } compile-vocabs
-    
-                "Compiling system..." print flush
-                compile-all
-            ] with-class<cache
-    
-            "cocoa" get [
-                "/library/compiler/alien/objc/load.factor" run-resource
-                "/library/ui/cocoa/load.factor" run-resource
-            ] when
-    
-            "x11" get [
-                "/library/ui/x11/load.factor" run-resource
-            ] when
-            
-            "Recompiling just in case..." print flush
-            recompile
+            compile-all
     
             "Initializing native I/O..." print flush
             "native-io" get [ init-io ] when
-    
+            
             ! We only do this if we are compiled, otherwise it
             ! takes too long.
             "Building online help search index..." print flush
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 9b4665fe6e..5c5ca54652 100644
--- a/library/bootstrap/image.factor
+++ b/library/bootstrap/image.factor
@@ -292,6 +292,7 @@ M: hashtable '
         {
             vocabularies typemap builtins c-types crossref
             articles parent-graph term-index changed-words
+            class<map
         } [ dup get swap bootstrap-word set ] each
     ] make-hash '
     global-offset fixup ;
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index d629376f1b..40bc1711c4 100644
--- a/library/bootstrap/primitives.factor
+++ b/library/bootstrap/primitives.factor
@@ -17,6 +17,7 @@ H{ } clone c-types set
 "syntax" vocab
 
 H{ } clone vocabularies set
+H{ } clone class<map set
 
 vocabularies get [ "syntax" set ] bind
 
diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 40c344f5ab..359594d790 100644
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -24,8 +24,7 @@ words ;
     dup [ f "no-effect" set-word-prop ] each
     [ try-compile ] each ;
 
-: compile-all ( -- )
-    [ vocabs compile-vocabs ] with-class<cache ;
+: compile-all ( -- ) vocabs compile-vocabs ;
 
 : compile-quot ( quot -- word )
     define-temp "compile" get [ dup compile ] when ;
@@ -33,11 +32,8 @@ words ;
 : compile-1 ( quot -- ) compile-quot execute ;
 
 : recompile ( -- )
-    #! If we are recompiling a lot of words, we can save time
-    #! with the class<cache.
     changed-words get [
-        dup hash-keys [ [ try-compile ] each clear-hash ]
-        over length 20 > [ with-class<cache ] [ call ] if
+        dup hash-keys [ try-compile ] each clear-hash
     ] when* ;
 
 [ recompile ] parse-hook set
diff --git a/library/generic/classes.factor b/library/generic/classes.factor
index 4edc3e79fe..2a0effde99 100644
--- a/library/generic/classes.factor
+++ b/library/generic/classes.factor
@@ -7,11 +7,12 @@ vectors math parser ;
 
 PREDICATE: word class ( obj -- ? ) "class" word-prop ;
 
-: classes ( -- seq ) [ class? ] word-subset ;
-
 SYMBOL: typemap
+SYMBOL: class<map
 SYMBOL: builtins
 
+: classes ( -- seq ) class<map get hash-keys ;
+
 : type>class ( n -- class ) builtins get nth ;
 
 : predicate-word ( word -- predicate )
@@ -31,7 +32,7 @@ SYMBOL: builtins
 
 : superclass ( class -- super ) "superclass" word-prop ;
 
-: members "members" word-prop ;
+: members ( class -- seq ) "members" word-prop ;
 
 : (flatten-class) ( class -- )
     dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
@@ -69,22 +70,8 @@ DEFER: (class<)
         { [ t ] [ union-class< ] }
     } cond ;
 
-SYMBOL: class<cache
-
 : class< ( class1 class2 -- ? )
-    class<cache get [ hash hash-member? ] [ (class<) ] if* ;
-
-: smaller-classes ( class seq -- )
-    [ swap (class<) ] subset-with ;
-
-: make-class<cache ( -- hash )
-    classes dup [
-        2dup swap smaller-classes [ dup ] map>hash
-    ] map>hash nip ;
-
-: with-class<cache ( quot -- )
-    [ make-class<cache class<cache set call ] with-scope ;
-    inline
+    class<map get hash hash-member? ;
 
 : class-compare ( class1 class2 -- n )
     2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
@@ -125,9 +112,24 @@ SYMBOL: class<cache
         tuck [ class< ] all-with? [ peek ] [ drop f ] if
     ] if ;
 
+: smaller-classes ( class -- seq )
+    classes [ swap (class<) ] subset-with ;
+
+: smaller-classes+ ( class -- )
+    [ smaller-classes [ dup ] map>hash ] keep
+    class<map get set-hash ;
+
+: bigger-classes ( class -- seq )
+    classes [ (class<) ] subset-with ;
+
+: bigger-classes+ ( class -- )
+    dup bigger-classes
+    [ dupd class<map get hash set-hash ] each-with ;
+
 : define-class ( class -- )
     dup t "class" set-word-prop
-    dup flatten-class typemap get set-hash ;
+    dup dup flatten-class typemap get set-hash
+    dup smaller-classes+ bigger-classes+ ;
 
 ! Predicate classes for generalized predicate dispatch.
 : define-predicate-class ( class predicate definition -- )
@@ -154,8 +156,15 @@ PREDICATE: class predicate "definition" word-prop ;
 PREDICATE: class union members ;
 
 ! Definition protocol
+: smaller-classes- ( class -- )
+    class<map get remove-hash ;
+
+: bigger-classes- ( class -- )
+    classes [ class<map get hash remove-hash ] each-with ;
+
 : forget-class ( class -- )
     dup "predicate" word-prop [ forget ] each
-    dup flatten-class typemap get remove-hash forget-word ;
+    dup dup flatten-class typemap get remove-hash forget-word
+    dup smaller-classes- bigger-classes- ;
 
 M: class forget forget-class ;
diff --git a/library/generic/classes.facts b/library/generic/classes.facts
index b85994002c..dea1f74d9f 100644
--- a/library/generic/classes.facts
+++ b/library/generic/classes.facts
@@ -70,16 +70,6 @@ HELP: class<
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 
-HELP: make-class<cache
-{ $values { "hash" "a hashtable" } }
-{ $description "Constructs a hashtable mapping classes to hashtables of classes which are smaller than them under " { $link class< } "." }
-{ $notes "This word should not be called directly. Instead, use " { $link with-class<cache } "." } ;
-
-HELP: with-class<cache
-{ $values { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope where the " { $link class<cache } " variable is bound to a hashtable output by " { $link make-class<cache } ". When this variable is bound, " { $link class< } " can be performed much more quickly than usual." }
-{ $notes "Calls to compile large numbers of words can be wrapped in this combinator to reduce compile time." } ;
-
 HELP: class-compare
 { $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
 { $description "Compares two classes, with the sign of the result indicating their sort order." }
diff --git a/library/test/collections/hashtables.factor b/library/test/collections/hashtables.factor
index 4e192114cc..0a742e1df2 100644
--- a/library/test/collections/hashtables.factor
+++ b/library/test/collections/hashtables.factor
@@ -12,7 +12,7 @@ USE: prettyprint
 
 [ "hi" V{ 1 2 3 } hash ] unit-test-fails
 
-[ H{ } ] [ { } [ ] map>hash ] unit-test
+[ H{ } ] [ { } [ dup ] map>hash ] unit-test
 
 [ ] [ 1000 [ dup sq ] map>hash "testhash" set ] unit-test
 
@@ -199,11 +199,6 @@ H{ } clone "cache-test" set
 
 [ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
 
-[ H{ } ] [ { } hash-concat ] unit-test
-[ H{ } ] [ { H{ } } hash-concat ] unit-test
-[ H{ { 1 2 } } ] [ { H{ { 1 2 } } } hash-concat ] unit-test
-[ H{ { 1 2 } { 3 4 } } ] [ { H{ { 1 2 } } H{ { 3 4 } } } hash-concat ] unit-test
-
 ! Resource leak...
 H{ } "x" set
 100 [ drop "x" get clear-hash ] each
diff --git a/library/test/generic.factor b/library/test/generic.factor
index 261874814f..755d9148f4 100644
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -56,33 +56,28 @@ M: very-funny gooey sq ;
 
 [ 1/4 ] [ 1/2 gooey ] unit-test
 
-: class<tests
-    [ object ] [ object object class-and ] unit-test
-    [ fixnum ] [ fixnum object class-and ] unit-test
-    [ fixnum ] [ object fixnum class-and ] unit-test
-    [ fixnum ] [ fixnum fixnum class-and ] unit-test
-    [ fixnum ] [ fixnum integer class-and ] unit-test
-    [ fixnum ] [ integer fixnum class-and ] unit-test
-    [ null ] [ vector fixnum class-and ] unit-test
-    [ number ] [ number object class-and ] unit-test
-    [ number ] [ object number class-and ] unit-test
-    
-    [ t ] [ \ fixnum \ integer class< ] unit-test
-    [ t ] [ \ fixnum \ fixnum class< ] unit-test
-    [ f ] [ \ integer \ fixnum class< ] unit-test
-    [ t ] [ \ integer \ object class< ] unit-test
-    [ f ] [ \ integer \ null class< ] unit-test
-    [ t ] [ \ null \ object class< ] unit-test
-    
-    [ t ] [ \ generic \ compound class< ] unit-test
-    [ f ] [ \ compound \ generic class< ] unit-test
-    
-    [ f ] [ \ reversed \ slice class< ] unit-test
-    [ f ] [ \ slice \ reversed class< ] unit-test ;
+[ object ] [ object object class-and ] unit-test
+[ fixnum ] [ fixnum object class-and ] unit-test
+[ fixnum ] [ object fixnum class-and ] unit-test
+[ fixnum ] [ fixnum fixnum class-and ] unit-test
+[ fixnum ] [ fixnum integer class-and ] unit-test
+[ fixnum ] [ integer fixnum class-and ] unit-test
+[ null ] [ vector fixnum class-and ] unit-test
+[ number ] [ number object class-and ] unit-test
+[ number ] [ object number class-and ] unit-test
 
-class<tests
+[ t ] [ \ fixnum \ integer class< ] unit-test
+[ t ] [ \ fixnum \ fixnum class< ] unit-test
+[ f ] [ \ integer \ fixnum class< ] unit-test
+[ t ] [ \ integer \ object class< ] unit-test
+[ f ] [ \ integer \ null class< ] unit-test
+[ t ] [ \ null \ object class< ] unit-test
 
-[ class<tests ] with-class<cache
+[ t ] [ \ generic \ compound class< ] unit-test
+[ f ] [ \ compound \ generic class< ] unit-test
+
+[ f ] [ \ reversed \ slice class< ] unit-test
+[ f ] [ \ slice \ reversed class< ] unit-test
 
 PREDICATE: word no-docs "documentation" word-prop not ;
 
@@ -182,3 +177,9 @@ TUPLE: delegating ;
 [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
 [ number ] [ \ number \ float math-class-max ] unit-test
 [ float ] [ \ real \ float math-class-max ] unit-test
+
+TUPLE: forget-class-test ;
+[ t ] [ forget-class-test tuple class<map get hash hash-member? ] unit-test
+[ ] [ forget-class-test forget ] unit-test
+[ f ] [ forget-class-test class<map get hash-member? ] unit-test
+[ f ] [ forget-class-test tuple class<map get hash hash-member? ] unit-test
diff --git a/library/test/prettyprint.factor b/library/test/prettyprint.factor
index 612189501a..58fb2641d2 100644
--- a/library/test/prettyprint.factor
+++ b/library/test/prettyprint.factor
@@ -1,5 +1,5 @@
-USING: alien io definitions kernel math prettyprint sequences
-test words inference namespaces vectors ;
+USING: alien definitions inference io kernel math namespaces
+parser prettyprint sequences test vectors words ;
 IN: temporary
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -43,19 +43,19 @@ unit-test
 [ [ \ bar see ] string-out ] unit-test
 
 [ "( a b -- c d )" ] [
-    { { "a" "b" } { "c" "d" } } effect>string
+    { "a" "b" } { "c" "d" } <effect> effect>string
 ] unit-test
 
 [ "( -- c d )" ] [
-    { { } { "c" "d" } } effect>string
+    { } { "c" "d" } <effect> effect>string
 ] unit-test
 
 [ "( a b -- )" ] [
-    { { "a" "b" } { } } effect>string
+    { "a" "b" } { } <effect> effect>string
 ] unit-test
 
 [ "( -- )" ] [
-    { { } { } } effect>string
+    { } { } <effect> effect>string
 ] unit-test
 
 [ ] [ \ fixnum see ] unit-test
diff --git a/library/test/redefine.factor b/library/test/redefine.factor
index 6b9617a9a0..039ee30723 100644
--- a/library/test/redefine.factor
+++ b/library/test/redefine.factor
@@ -2,8 +2,8 @@ USING: compiler definitions generic hashtables inference math
 namespaces parser test words ;
 IN: temporary
 
-DEFER: foo
-DEFER: bar
+DEFER: foo \ foo reset-generic
+DEFER: bar \ bar reset-generic
 
 [   ] [ \ foo [ 1 2 ] define-compound     ] unit-test
 [ { 0 2 } ] [ [ foo ] infer ] unit-test