Bootstrap performance improvement and assorted cleanups

Makefile

@@ -111,7 +111,7 @@ macosx.app:
 	cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
 
 	chmod +x cp_dir
-	find doc library contrib \( -name '*.factor' \
+	find doc library contrib examples \( -name '*.factor' \
 		-o -name '*.facts' \
 		-o -name '*.txt' \
 		-o -name '*.html' \

TODO.FACTOR.txt

@@ -3,7 +3,7 @@ should fix in 0.82:
 - clean up fp-scratch
 - intrinsic fixnum>float float>fixnum
 - update amd64 backend
-
+- float= on powerpc doesn't consider nans equal
 - amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums

library/bootstrap/boot-stage2.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler help io io-internals kernel
+USING: compiler generic help io io-internals kernel
 kernel-internals lists math memory namespaces optimizer parser
 sequences sequences-internals words ;
 
@@ -23,15 +23,14 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
-    \ slot \ set-slot [ usage ] 2apply append
+    [
-    [ try-compile ] each
-
         \ + compile
         \ = compile
         { "kernel" "sequences" "assembler" } compile-vocabs
     
         "Compiling system..." print flush
         compile-all
+    ] with-class<cache
     
     terpri
     "Unless you're working on the compiler, ignore the errors above." print

library/compiler/compiler.factor

@@ -6,11 +6,8 @@ namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
     [
-        [
+        [ dup specialized-def dataflow optimize generate ] keep
-            dup specialized-def dataflow optimize generate
+    ] benchmark nip "compile-time" set-word-prop ;
-        ] keep
-    ] benchmark nip
-    "compile-time" set-word-prop ;
 
 : inform-compile ( word -- ) "Compiling " write . flush ;
 

library/compiler/inference/dataflow.factor

@@ -31,6 +31,7 @@ M: node = eq? ;
 : param-node ( label) { } { } { } { } ;
 : in-node ( inputs) >r f r> { } { } { } ;
 : out-node ( outputs) >r f { } r> { } { } ;
+: meta-d-node meta-d get clone in-node ;
 
 : d-tail ( n -- list ) meta-d get tail* ;
 : r-tail ( n -- list ) meta-r get tail* ;
@@ -43,7 +44,8 @@ C: #label make-node ;
 
 TUPLE: #entry ;
 C: #entry make-node ;
-: #entry ( -- node ) meta-d get clone in-node <#entry> ;
+
+: #entry ( -- node ) meta-d-node <#entry> ;
 
 TUPLE: #call ;
 C: #call make-node ;
@@ -55,7 +57,7 @@ C: #call-label make-node ;
 
 TUPLE: #push ;
 C: #push make-node ;
-: #push ( outputs -- node ) d-tail out-node <#push> ;
+: #push ( -- node ) peek-d out-node <#push> ;
 : >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
 
 TUPLE: #shuffle ;
@@ -64,23 +66,22 @@ C: #shuffle make-node ;
 
 TUPLE: #values ;
 C: #values make-node ;
-: #values ( -- node ) meta-d get clone in-node <#values> ;
+: #values ( -- node ) meta-d-node <#values> ;
 
 TUPLE: #return ;
 C: #return make-node ;
 : #return ( label -- node )
     #! The parameter is the label we are returning from, or if
     #! f, this is a top-level return.
-    meta-d get clone in-node <#return>
+    meta-d-node <#return> [ set-node-param ] keep ;
-    [ set-node-param ] keep ;
 
 TUPLE: #if ;
 C: #if make-node ;
-: #if ( in -- node ) 1 d-tail in-node <#if> ;
+: #if ( in -- node ) peek-d in-node <#if> ;
 
 TUPLE: #dispatch ;
 C: #dispatch make-node ;
-: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
+: #dispatch ( in -- node ) peek-d in-node <#dispatch> ;
 
 TUPLE: #merge ;
 C: #merge make-node ;

library/compiler/inference/inference.factor

@@ -76,7 +76,7 @@ GENERIC: apply-object
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    <value> push-d  1 #push node, ;
+    <value> push-d #push node, ;
 
 M: object apply-object apply-literal ;
 

library/compiler/inference/words.factor

@@ -104,7 +104,7 @@ M: #call-label collect-recursion* ( label node -- )
 
 : infer-compound ( word base-case -- terminates? effect )
     #! Infer a word's stack effect in a separate inferencer
-    #! instance. Outputs a boolean if the word terminates
+    #! instance. Outputs a true boolean if the word terminates
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [

library/compiler/optimizer/inline-methods.factor

@@ -66,26 +66,9 @@ kernel-internals lists math namespaces sequences words ;
 : math-both-known? ( word left right -- ? )
     math-class-max specific-method ;
 
-: max-tag ( class -- n ) types peek 1+ num-tags min ;
-
-: left-partial-math ( word left right -- quot/t )
-    #! The left type is known; dispatch on right
-    \ dup swap max-tag
-    [ >r 2dup r> math-method ] math-vtable* 2nip ;
-
-: right-partial-math ( word left right -- quot/t )
-    #! The right type is known; dispatch on left
-    \ over rot max-tag
-    [ >r 2dup r> swap math-method ] math-vtable* 2nip ;
-
 : will-inline-math-method ( word left right -- quot/t )
     #! t indicates failure
-    {
+    3dup math-both-known? [ math-method ] [ 3drop t ] if ;
-        { [ 3dup math-both-known? ] [ math-method ] }
-        ! { [ 3dup drop specific-method ] [ left-partial-math ] }
-        ! { [ 3dup nip specific-method ] [ right-partial-math ] }
-        { [ t ] [ 3drop t ] }
-    } cond ;
 
 : inline-math-method ( #call -- node )
     dup node-param over 1 node-class# pick 0 node-class#

library/generic/generic.factor

@@ -1,10 +1,14 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: generic
 USING: arrays errors hashtables kernel kernel-internals lists
 namespaces parser sequences strings words vectors math
 math-internals ;
 
+: class? ( word -- ? ) "class" word-prop ;
+
+: classes ( -- list ) [ class? ] word-subset ;
+
 SYMBOL: typemap
 SYMBOL: builtins
 
@@ -41,19 +45,19 @@ SYMBOL: builtins
 : types ( class -- types )
     [ (types) ] make-hash hash-keys natural-sort ;
 
-DEFER: class<
+DEFER: (class<)
 
 : superclass< ( cls1 cls2 -- ? )
-    >r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
+    >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
     >r flatten-class r> flatten-class hash-keys swap
-    [ drop swap [ class< ] contains-with? ] hash-all-with? ;
+    [ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
 
 : class-empty? ( class -- ? )
     members dup [ empty? ] when ;
 
-: class< ( cls1 cls2 -- ? )
+: (class<) ( cls1 cls2 -- ? )
     {
         { [ 2dup eq? ] [ 2drop t ] }
         { [ over class-empty? ] [ 2drop t ] }
@@ -62,6 +66,21 @@ DEFER: class<
         { [ t ] [ union-class< ] }
     } cond ;
 
+SYMBOL: class<cache
+
+: class< ( cls1 cls2 -- ? )
+    class<cache get [ hash hash-member? ] [ (class<) ] if* ;
+
+: smaller-classes ( class -- )
+    classes [ swap (class<) ] subset-with ;
+
+: make-class<cache ( -- hash )
+    classes [ dup smaller-classes [ dup ] map>hash ] map>hash ;
+
+: with-class<cache ( quot -- )
+    [ make-class<cache class<cache set call ] with-scope ;
+    inline
+
 : class-compare ( cls1 cls2 -- -1/0/1 )
     2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
 
@@ -80,8 +99,6 @@ M: generic definer drop \ G: ;
 : make-generic ( word -- )
     dup dup "combination" word-prop call define-compound ;
 
-: class? ( word -- ? ) "class" word-prop ;
-
 : check-method ( class generic -- )
     dup generic? [
         dup word-name " is not a generic word" append throw
@@ -146,13 +163,12 @@ M: generic definer drop \ G: ;
 
 : define-class ( class -- )
     dup t "class" set-word-prop
+    dup H{ } clone "class<" set-word-prop
     dup flatten-class typemap get set-hash ;
 
 : implementors ( class -- list )
     [ "methods" word-prop ?hash* nip ] word-subset-with ;
 
-: classes ( -- list ) [ class? ] word-subset ;
-
 ! Predicate classes for generalized predicate dispatch.
 : define-predicate-class ( class predicate definition -- )
     pick define-class

library/generic/tuple.factor

@@ -1,11 +1,18 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
-IN: kernel-internals
+IN: generic
-USING: arrays errors hashtables kernel lists math namespaces parser sequences sequences-internals strings vectors words ;
+USING: arrays errors hashtables kernel kernel-internals lists
+math namespaces parser sequences sequences-internals strings
+vectors words ;
+
+: class ( object -- class )
+    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
 
 : class-tuple ( object -- class )
     dup tuple? [ 2 slot ] [ drop f ] if ; inline
 
+IN: kernel-internals
+
 : tuple= ( tuple tuple -- ? )
     2dup [ array-capacity ] 2apply number= [
         dup array-capacity
@@ -15,14 +22,10 @@ USING: arrays errors hashtables kernel lists math namespaces parser sequences se
     ] if ; inline
 
 : tuple-hashcode ( n tuple -- n )
-    dup class-tuple hashcode >r >r 1- r>
+    dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
-    4 slot hashcode* r> bitxor ;
 
 IN: generic
 
-: class ( object -- class )
-    dup tuple? [ 2 slot ] [ type type>class ] if ; inline
-
 : tuple-predicate ( word -- )
     dup predicate-word
     [ \ class-tuple , over literalize , \ eq? , ] [ ] make
@@ -80,7 +83,7 @@ M: tuple clone ( tuple -- tuple )
 M: tuple hashcode* ( n tuple -- n )
     {
         { [ over 0 <= ] [ 2drop 0 ] }
-        { [ dup array-capacity 2 <= ] [ nip class-tuple hashcode ] }
+        { [ dup array-capacity 2 <= ] [ nip class hashcode ] }
         { [ t ] [ tuple-hashcode ] }
     } cond ;
 

library/test/generic.factor

@@ -69,6 +69,7 @@ M: very-funny gooey sq ;
 
 [ cons ] [ [ 1 2 ] class ] 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
@@ -96,7 +97,11 @@ M: very-funny gooey sq ;
     [ f ] [ \ list \ cons class< ] unit-test
     
     [ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+    [ f ] [ \ slice \ reversed class< ] unit-test ;
+
+class<tests
+
+[ class<tests ] with-class<cache
 
 PREDICATE: word no-docs "documentation" word-prop not ;
 

library/tools/interpreter.factor

@@ -12,9 +12,11 @@ namespaces prettyprint sequences strings vectors words ;
 SYMBOL: meta-r
 : push-r meta-r get push ;
 : pop-r meta-r get pop ;
+: peek-r meta-r get peek ;
 SYMBOL: meta-d
 : push-d meta-d get push ;
 : pop-d meta-d get pop ;
+: peek-d meta-d get peek ;
 SYMBOL: meta-n
 SYMBOL: meta-c