Bootstrap performance improvement and assorted cleanups

diff --git a/Makefile b/Makefile
index 3c54e6696282aa743af2400b9a748cc3bb718f70..e0ae8576005ef85cb037ce78e69c4fb070797709 100644 (file)
--- a/Makefile
+++ b/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' \

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 3ae4c2acc8586eeb3df5aaa38793fe36131c04ad..98489f1e8a6e544706d5c9d4350dad1c93ada4f9 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/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

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 0b5ee6173fa852172afd1ea997268369a417fc94..09acfeaaaed3122938316f733445e4f3b9ed861f 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/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
+    [
+        \ + 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

diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor
index 9381b125078a02579a194bcdc93d87a0c3b3e888..f89403be918ebde5f72b9b1eac3899b540b18ef0 100644 (file)
--- a/library/compiler/compiler.factor
+++ b/library/compiler/compiler.factor
@@ -6,11 +6,8 @@ namespaces optimizer prettyprint sequences test words ;
 
 : (compile) ( word -- )
     [
-        [
-            dup specialized-def dataflow optimize generate
-        ] keep
-    ] benchmark nip
-    "compile-time" set-word-prop ;
+        [ dup specialized-def dataflow optimize generate ] keep
+    ] benchmark nip "compile-time" set-word-prop ;
 
 : inform-compile ( word -- ) "Compiling " write . flush ;
 

diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor
index ae37bf2d0881bd2a933a3acd95c434ecd321077c..f50e1e1cb58cd25d199bd2e8f79c06b7f2ed4a09 100644 (file)
--- a/library/compiler/inference/dataflow.factor
+++ b/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>
-    [ set-node-param ] keep ;
+    meta-d-node <#return> [ 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 ;

diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor
index af22fb903ea244b36028a599272e3bdb3cc08622..818b204d52a5126a286ddf68d6d52c2393d61959 100644 (file)
--- a/library/compiler/inference/inference.factor
+++ b/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 ;
 

diff --git a/library/compiler/inference/words.factor b/library/compiler/inference/words.factor
index 3b14dd4d843379ee2313025436af0c088bbcc5df..4e2a150b9db3e774c7502851ee4e66d5e6ae4202 100644 (file)
--- a/library/compiler/inference/words.factor
+++ b/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.
     [

diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor
index 4873389ded19ad3e56c46b56ee72db9d2b485b84..44f6918b5d953b85d5cec2d191ded472a9749e23 100644 (file)
--- a/library/compiler/optimizer/inline-methods.factor
+++ b/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 ] }
-        ! { [ 3dup drop specific-method ] [ left-partial-math ] }
-        ! { [ 3dup nip specific-method ] [ right-partial-math ] }
-        { [ t ] [ 3drop t ] }
-    } cond ;
+    3dup math-both-known? [ math-method ] [ 3drop t ] if ;
 
 : inline-math-method ( #call -- node )
     dup node-param over 1 node-class# pick 0 node-class#

diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index 50dd6536992b91b023b31d7fbad91abf0a2d087f..125410510f48182549ac229f890915046d18a807 100644 (file)
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -1,10 +1,14 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! 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

diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index 767c0932c919985253ce71341fd80b504eda701b..13ff6990a70ee14af7d695406a4a93cb956cd2ee 100644 (file)
--- a/library/generic/tuple.factor
+++ b/library/generic/tuple.factor
@@ -1,11 +1,18 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel-internals
-USING: arrays errors hashtables kernel lists math namespaces parser sequences sequences-internals strings vectors words ;
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: generic
+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>
-    4 slot hashcode* r> bitxor ;
+    dup class hashcode >r >r 1- r> 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 ;
 

diff --git a/library/test/generic.factor b/library/test/generic.factor
index c1075377e2c0fb9ef265c59cc64c6338964ef8ad..7ba806f6bd99aba1fdf7648520b1bb61da27fc5f 100644 (file)
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -69,34 +69,39 @@ M: very-funny gooey sq ;
 
 [ cons ] [ [ 1 2 ] 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
-
-[ 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 ] [ \ list \ general-list class< ] unit-test
-[ t ] [ \ list \ object class< ] unit-test
-[ t ] [ \ null \ list class< ] unit-test
-
-[ t ] [ \ generic \ compound class< ] unit-test
-[ f ] [ \ compound \ generic class< ] unit-test
-
-[ f ] [ \ cons \ list class< ] unit-test
-[ f ] [ \ list \ cons class< ] unit-test
-
-[ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed 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
+    [ 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 ] [ \ list \ general-list class< ] unit-test
+    [ t ] [ \ list \ object class< ] unit-test
+    [ t ] [ \ null \ list class< ] unit-test
+    
+    [ t ] [ \ generic \ compound class< ] unit-test
+    [ f ] [ \ compound \ generic class< ] unit-test
+    
+    [ f ] [ \ cons \ list class< ] unit-test
+    [ f ] [ \ list \ cons class< ] unit-test
+    
+    [ f ] [ \ reversed \ slice class< ] unit-test
+    [ f ] [ \ slice \ reversed class< ] unit-test ;
+
+class<tests
+
+[ class<tests ] with-class<cache
 
 PREDICATE: word no-docs "documentation" word-prop not ;
 

diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor
index df03029438dffc35b01f0c2011f98751d1a97778..27882139df7163924de2ce7954d20845ca599576 100644 (file)
--- a/library/tools/interpreter.factor
+++ b/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