Optimizations aimed at reducing bootstrap time

Makefile

@@ -142,3 +142,8 @@ clean:
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
+
+boot:
+	echo "USE: image \"$(ARCH)\" make-image bye" | ./f factor.image
+	./f boot.image.$(ARCH) $(BOOTSTRAP_FLAGS)
+	

library/alien/aliens.factor

@@ -53,8 +53,8 @@ global [ "libraries" nest drop ] bind
     ] bind ;
 
 : add-simple-library ( name file -- ) 
-    os "win32" = ".dll" ".so" ? append
+    windows? ".dll" ".so" ? append
-    os "win32" = "stdcall" "cdecl" ? add-library ;
+    windows? "stdcall" "cdecl" ? add-library ;
 
 : library-abi ( library -- abi )
     library "abi" swap ?hash [ "cdecl" ] unless* ;

library/bootstrap/boot-stage1.factor

@@ -28,21 +28,20 @@ vectors words ;
 
         "/library/collections/sequences.factor"
         "/library/collections/growable.factor"
-        "/library/collections/cons.factor"
         "/library/collections/virtual-sequences.factor"
         "/library/collections/sequence-combinators.factor"
         "/library/collections/sequences-epilogue.factor"
         "/library/collections/arrays.factor"
         "/library/collections/strings.factor"
         "/library/collections/sbuf.factor"
-        "/library/collections/lists.factor"
         "/library/collections/vectors.factor"
         "/library/collections/hashtables.factor"
         "/library/collections/namespaces.factor"
         "/library/collections/sequence-eq.factor"
         "/library/collections/slicing.factor"
         "/library/collections/sequence-sort.factor"
-        "/library/collections/tree-each.factor"
+        "/library/collections/lists.factor"
+        "/library/collections/flatten.factor"
         "/library/collections/queues.factor"
 
         "/library/math/random.factor"
@@ -211,7 +210,7 @@ vectors words ;
         "/library/collections/sequences.facts"
         "/library/collections/slicing.facts"
         "/library/collections/strings.facts"
-        "/library/collections/tree-each.facts"
+        "/library/collections/flatten.facts"
         "/library/collections/vectors.facts"
         "/library/collections/virtual-sequences.facts"
         "/library/generic/early-generic.facts"

library/bootstrap/boot-stage2.factor

@@ -14,7 +14,7 @@ recrossref
             "/library/unix/load.factor" run-resource
         ] when
 
-        os "win32" = [
+        windows? [
             "/library/win32/load.factor" run-resource
         ] when
     ] when

library/cli.factor

@@ -48,8 +48,8 @@ parser sequences strings ;
     "compile" on
     "native-io" on
     "null-stdio" off
-    os "macosx" = "cocoa" set
+    macosx? "cocoa" set
-    unix? os "macosx" = not and "x11" set
+    unix? macosx? not and "x11" set
     default-shell "shell" set ;
 
 : parse-command-line ( -- )

library/cocoa/init-cocoa.factor

@@ -19,40 +19,8 @@ USING: cocoa compiler io kernel objc sequences words ;
     "NSObject"
     "NSOpenGLContext"
     "NSOpenGLView"
-    "NSSpeechSynthesizer"
-    "NSURLRequest"
     "NSView"
     "NSWindow"
 } [
     f import-objc-class
 ] each
-
-{
-    "PDFDocument"
-    "PDFView"
-} [
-    [
-        "/System/Library/Frameworks/Quartz.framework/Frameworks/PDFKit.framework"
-        load-framework
-    ] import-objc-class
-] each
-
-{
-    "QTMovie"
-    "QTMovieView"
-} [
-    [
-        "/System/Library/Frameworks/QTKit.framework"
-        load-framework
-    ] import-objc-class
-] each
-
-{
-    "WebFrame"
-    "WebView"
-} [
-    [
-        "/System/Library/Frameworks/WebKit.framework"
-        load-framework
-    ] import-objc-class
-] each

library/cocoa/runtime.factor

@@ -12,6 +12,11 @@ FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
 
 FUNCTION: SEL sel_registerName ( char* str ) ;
 
+BEGIN-STRUCT: objc-super
+    FIELD: id receiver
+    FIELD: void* class
+END-STRUCT
+
 : CLS_CLASS        HEX: 1   ;
 : CLS_META         HEX: 2   ;
 : CLS_INITIALIZED  HEX: 4   ;

library/cocoa/ui.factor

@@ -139,12 +139,21 @@ H{ } clone views set-global
     { "acceptsFirstResponder" "bool" { "id" "SEL" }
         [ 2drop 1 ]
     }
+    
+    { "dealloc" "void" { "id" "SEL" }
+        [
+            drop
+            dup view dup remove-notify free-fonts
+            dup views get remove-hash
+            SUPER-> [dealloc]
+        ]
+    }
 } { } define-objc-class
 
 : <FactorView> ( gadget -- view )
     FactorView over rect-dim <GLView>
     dup "updateFactorGadgetSize:" add-resize-observer
-    [ over set-world-handle register-view ] keep ;
+    [ over set-world-handle dup add-notify register-view ] keep ;
 
 : <FactorWindow> ( gadget title -- window )
     >r <FactorView> r> <ViewWindow> ;

library/cocoa/utilities.factor

@@ -122,7 +122,21 @@ H{
 : make-dip ( quot n -- quot )
     dup \ >r <array> -rot \ r> <array> append3 ;
 
-: selector-quot ( string -- ) <selector> [ selector ] curry ;
+: <super> ( receiver class -- super )
+    "objc-super" <c-object>
+    [ set-objc-super-class ] keep
+    [ set-objc-super-receiver ] keep ;
+
+: SUPER-> \ SUPER-> on ; inline
+
+: ?super ( obj -- class )
+    objc-object-isa \ SUPER-> [ f ] change
+    [ objc-class-super-class ] when ; inline
+
+: selector-quot ( string -- )
+    [
+        [ >r dup ?super <super> r> ] % <selector> , \ selector ,
+    ] [ ] make ;
 
 : make-objc-invoke
     [
@@ -131,13 +145,13 @@ H{
 
 : make-objc-send ( returns args selector -- )
     selector-quot
-    [ swap , [ f "objc_msgSend" ] % , ] make-objc-invoke ;
+    [ swap , [ f "objc_msgSendSuper" ] % , ] make-objc-invoke ;
 
 : make-objc-send-stret ( returns args selector -- )
     >r swap [ <c-object> dup ] curry 1 make-dip r>
     selector-quot append [
         "void" ,
-        [ f "objc_msgSend_stret" ] %
+        [ f "objc_msgSendSuper_stret" ] %
         { "void*" } swap append ,
     ] make-objc-invoke ;
 

library/collections/cons.factor

@@ -1,35 +0,0 @@
-! Copyright (C) 2003, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: lists USING: generic kernel sequences ;
-
-! This file contains vital list-related words that everything
-! else depends on, and is loaded early in bootstrap.
-! lists.factor has everything else.
-
-! We borrow an idiom from Common Lisp. The car/cdr of an empty
-! list is the empty list.
-M: f car ;
-M: f cdr ;
-
-UNION: general-list POSTPONE: f cons ;
-
-GENERIC: >list ( seq -- list )
-M: general-list >list ( list -- list ) ;
-
-: last ( list -- last )
-    #! Last cons of a list.
-    dup cdr cons? [ cdr last ] when ; foldable
-
-PREDICATE: general-list list ( list -- ? )
-    #! Proper list test. A proper list is either f, or a cons
-    #! cell whose cdr is a proper list.
-    dup [ last cdr ] when not ;
-
-: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
-: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline
-
-: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
-: unit ( a -- [ a ] ) f cons ; inline
-
-: 2car ( cons cons -- car car ) [ car ] 2apply ; inline
-: 2cdr ( cons cons -- car car ) [ cdr ] 2apply ; inline

library/collections/flatten.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: sequences
+USING: generic kernel lists namespaces strings ;
+
+GENERIC: flatten* ( obj -- )
+
+M: object flatten* , ;
+
+M: sequence flatten* [ flatten* ] each ;
+
+M: string flatten* , ;
+
+M: sbuf flatten* , ;
+
+M: cons flatten* uncons >r flatten* r> flatten* ;
+
+M: wrapper flatten* wrapped flatten* ;
+
+: flatten ( obj -- seq ) [ flatten* ] { } make ;

library/collections/flatten.facts

@@ -0,0 +1,6 @@
+USING: help sequences ;
+
+HELP: flatten "( seq -- seq)"
+{ $values { "obj" "an object" } { "seq" "a new sequence" } }
+{ $description "Recursively descends into lists, arrays, vectors and wrappers. Leaf elements are collected into a new sequence which is output at the end of the traversal." }
+{ $notes "This word does not descend into virtual sequences, or user-defined sequences." } ;

library/collections/hashtables.factor

@@ -215,6 +215,20 @@ M: hashtable = ( obj hash -- ? )
         { [ t ] [ hashtable= ] }
     } cond ;
 
+: hashtable-hashcode ( n hashtable -- n )
+    >r 1- r> 0 swap [
+        >r >r
+        over r> hashcode* bitxor
+        over r> hashcode* -1 shift bitxor
+    ] hash-each nip ;
+
+M: hashtable hashcode* ( n hash -- n )
+    dup hash-size 1 number=
+    [ hashtable-hashcode ] [ nip hash-size ] if ;
+
+M: hashtable hashcode ( hash -- n )
+    2 swap hashcode* ;
+
 : ?hash ( key hash/f -- value/f )
     dup [ hash ] [ 2drop f ] if ; flushable
 

library/collections/lists.factor

@@ -2,19 +2,32 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: lists USING: errors generic kernel math sequences ;
 
+M: f car ;
+M: f cdr ;
+
+UNION: general-list POSTPONE: f cons ;
+
+GENERIC: >list ( seq -- list )
+M: general-list >list ( list -- list ) ;
+
+PREDICATE: general-list list ( list -- ? )
+    #! Proper list test. A proper list is either f, or a cons
+    #! cell whose cdr is a proper list.
+    [ cdr list? ] [ t ] if* ;
+
+: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
+: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline
+
+: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
+: unit ( a -- [ a ] ) f cons ; inline
+
+: 2car ( cons cons -- car car ) [ car ] 2apply ; inline
+: 2cdr ( cons cons -- car car ) [ cdr ] 2apply ; inline
+
 ! Sequence protocol
 M: f length drop 0 ;
 M: cons length cdr length 1+ ;
 
-M: f empty? drop t ;
-M: cons empty? drop f ;
-
-M: f peek ( f -- f ) ;
-
-M: cons peek ( list -- last )
-    #! Last element of a list.
-    last car ;
-
 : (list-each) ( list quot -- )
     over [
         [ >r car r> call ] 2keep >r cdr r> (list-each)
@@ -54,20 +67,8 @@ M: general-list reverse-slice ( list -- list )
 
 M: general-list reverse reverse-slice ;
 
-M: general-list head ( n list -- list )
-    #! Return the first n elements of the list.
-    over 0 > [
-        unswons >r >r 1- r> head r> swons
-    ] [
-        2drop f
-    ] if ;
-
-M: general-list tail ( n list -- tail )
-    #! Return the rest of the list, from the nth index onward.
-    swap [ cdr ] times ;
-
 M: general-list nth ( n list -- element )
-    over zero? [ nip car ] [ >r 1- r> cdr nth ] if ;
+    over 0 <= [ nip car ] [ >r 1- r> cdr nth ] if ;
 
 M: cons = ( obj cons -- ? )
     {
@@ -79,3 +80,14 @@ M: cons = ( obj cons -- ? )
 : curry ( obj quot -- quot ) >r literalize r> cons ;
 
 : assoc ( key alist -- value ) [ car = ] find-with nip cdr ;
+
+: (>list) ( n i seq -- list )
+    pick pick <= [
+        3drop [ ]
+    ] [
+        2dup nth >r >r 1+ r> (>list) r> swons
+    ] if ;
+
+M: object >list ( seq -- list ) dup length 0 rot (>list) ;
+
+M: general-list like drop >list ;

library/collections/sequences-epilogue.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: sequences
-USING: errors generic kernel kernel-internals lists math
+USING: errors generic kernel kernel-internals math
 sequences-internals strings vectors words ;
 
 : first2 ( { x y } -- x y )
@@ -15,17 +15,6 @@ sequences-internals strings vectors words ;
 
 M: object like drop ;
 
-M: object empty? ( seq -- ? ) length zero? ;
-
-: (>list) ( n i seq -- list )
-    pick pick <= [
-        3drop [ ]
-    ] [
-        2dup nth >r >r 1+ r> (>list) r> swons
-    ] if ;
-
-M: object >list ( seq -- list ) dup length 0 rot (>list) ;
-
 : index   ( obj seq -- n )     [ = ] find-with drop ; flushable
 : index*  ( obj i seq -- n )   [ = ] find-with* drop ; flushable
 : member? ( obj seq -- ? )     [ = ] contains-with? ; flushable
@@ -84,8 +73,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
 : append3 ( s1 s2 s3 -- s1+s2+s3 )
     rot [ [ rot nappend ] keep swap nappend ] immutable ; flushable
 
-M: object peek ( sequence -- element )
+: peek ( sequence -- element ) dup length 1- swap nth ;
-    dup length 1- swap nth ;
 
 : pop* ( sequence -- )
     [ length 1- ] keep

library/collections/sequences.factor

@@ -3,7 +3,6 @@
 IN: sequences
 USING: errors generic kernel math math-internals strings vectors ;
 
-GENERIC: empty? ( sequence -- ? ) flushable
 GENERIC: length ( sequence -- n ) flushable
 GENERIC: set-length ( n sequence -- )
 GENERIC: nth ( n sequence -- obj ) flushable
@@ -12,9 +11,8 @@ GENERIC: thaw ( seq -- mutable-seq ) flushable
 GENERIC: like ( seq seq -- seq ) flushable
 GENERIC: reverse ( seq -- seq ) flushable
 GENERIC: reverse-slice ( seq -- seq ) flushable
-GENERIC: peek ( seq -- elt ) flushable
+
-GENERIC: head ( n seq -- seq ) flushable
+: empty? ( seq -- ? ) length zero? ;
-GENERIC: tail ( n seq -- seq ) flushable
 
 : first 0 swap nth ; inline
 : second 1 swap nth ; inline

library/collections/slicing.factor

@@ -16,11 +16,11 @@ strings vectors ;
 
 : subseq ( from to seq -- seq ) [ <slice> ] keep like ; flushable
 
-M: object head ( index seq -- seq ) [ head-slice ] keep like ;
+: head ( index seq -- seq ) [ head-slice ] keep like ;
 
 : head* ( n seq -- seq ) [ head-slice* ] keep like ; flushable
 
-M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
+: tail ( index seq -- seq ) [ tail-slice ] keep like ;
 
 : tail* ( n seq -- seq ) [ tail-slice* ] keep like ; flushable
 
@@ -114,12 +114,3 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
 : join ( seq glue -- seq )
     [ swap [ % ] [ dup % ] interleave drop ] over make ;
     flushable
-
-IN: strings
-
-: completion? ( partial completion quot -- ? )
-    #! Test if 'partial' is a completion of 'completion', by
-    #! comparing each "-"-delimited chunk using 'quot'. The
-    #! quotation is usually either [ subseq? ] or [ swap head? ].
-    >r [ "-" split ] 2apply 2dup [ length ] 2apply <=
-    [ r> 2map [ ] all? ] [ r> 3drop f ] if ; inline

library/collections/tree-each.factor

@@ -1,31 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: sequences
-USING: generic kernel lists strings sequences-internals ;
-
-G: tree-each* ( obj quot -- | quot: elt -- )
-    1 standard-combination ; inline
-
-: tree-each ( obj quot -- | quot: elt -- )
-    [ call ] 2keep tree-each* ; inline
-
-: tree-each-with ( obj obj quot -- )
-    swap [ with ] tree-each 2drop ; inline
-
-M: object tree-each* 2drop ;
-
-M: sequence tree-each* swap [ swap tree-each ] each-with ;
-
-M: string tree-each* 2drop ;
-
-M: cons tree-each* ( cons quot -- )
-    >r uncons r> tuck >r >r tree-each r> r> tree-each ;
-
-M: wrapper tree-each* ( wrapper quot -- )
-    >r wrapped r> tree-each ;
-
-: tree-subset ( obj quot -- seq )
-    [ tree-each ] select ; inline
-
-: tree-subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
-    swap [ with rot ] tree-subset 2nip ; inline

library/collections/tree-each.facts

@@ -1,6 +0,0 @@
-USING: help sequences ;
-
-HELP: tree-each "( seq quot -- )"
-{ $values { "obj" "an object" } { "quot" "a quotation with stack effect" { $snippet "( elt -- )" } } }
-{ $description "Traverses a tree where the root is the given object, the branches are arrays, vectors, lists and wrappers, and the leaves are all other types of objects. Traversal is pre-order; the quotation is first applied to a branch, then to the children." }
-{ $notes "This word does not descend into virtual sequences, or user-defined sequences." } ;

library/collections/vectors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: vectors
-USING: arrays errors generic kernel kernel-internals lists math
+USING: arrays errors generic kernel kernel-internals math
 math-internals sequences sequences-internals ;
 
 M: vector set-length ( len vec -- )
@@ -23,8 +23,6 @@ M: object thaw drop V{ } clone ;
 
 M: vector clone ( vector -- vector ) clone-growable ;
 
-M: general-list like drop >list ;
-
 M: vector like
     drop dup vector? [
         dup array? [ array>vector ] [ >vector ] if

library/compiler/compiler.factor

@@ -3,20 +3,24 @@
 IN: compiler
 USING: compiler-backend compiler-frontend errors hashtables
 inference io kernel lists math namespaces optimizer prettyprint
-sequences words ;
+sequences test words ;
 
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
     dup word-def dataflow optimize linearize
     [ split-blocks simplify generate ] hash-each ;
 
+: benchmark-compile
+    [ [ (compile) ] keep ] benchmark nip
+    "compile-time" set-word-prop ;
+
 : inform-compile ( word -- ) "Compiling " write . flush ;
 
 : compile-postponed ( -- )
     compile-words get dup empty? [
         dup pop
         dup inform-compile
-        (compile)
+        benchmark-compile
         compile-postponed
     ] unless drop ;
 
@@ -44,3 +48,5 @@ sequences words ;
     "compile" get [ dup compile ] when ;
 
 : compile-1 ( quot -- ) compile-quot execute ;
+
+\ dataflow profile

library/compiler/ppc/architecture.factor

@@ -19,5 +19,5 @@ M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
 
 ! Mach-O -vs- Linux/PPC
-: stack@ os "macosx" = 24 8 ? + ;
+: stack@ macosx? 24 8 ? + ;
-: lr@ os "macosx" = 8 4 ? + ;
+: lr@ macosx? 8 4 ? + ;

library/compiler/vops.factor

@@ -42,7 +42,7 @@ M: int-regs reg-size drop cell ;
 
 : (inc-reg-class)
     dup class inc
-    os "macosx" = [ reg-size stack-params +@ ] [ drop ] if ;
+    macosx? [ reg-size stack-params +@ ] [ drop ] if ;
 
 M: int-regs inc-reg-class
     (inc-reg-class) ;
@@ -51,7 +51,7 @@ M: float-regs reg-size float-regs-size ;
 
 M: float-regs inc-reg-class
     dup (inc-reg-class)
-    os "macosx" = [ reg-size 4 / int-regs +@ ] [ drop ] if ;
+    macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;

library/freetype/freetype.factor

@@ -3,7 +3,7 @@
 USING: alien kernel ;
 IN: freetype
 
-os "win32" = [
+windows? [
     "freetype" "freetype6.dll" "cdecl" add-library
 ] when
 

library/generic/generic.factor

@@ -26,13 +26,14 @@ SYMBOL: builtins
 
 : members "members" word-prop ;
 
-: (flatten) ( class -- )
+: (flatten-class) ( class -- )
-    dup members [ [ (flatten) ] each ] [ dup set ] ?if ;
+    dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
 
-: flatten ( class -- classes ) [ (flatten) ] make-hash ;
+: flatten-class ( class -- classes )
+    [ (flatten-class) ] make-hash ;
 
 : (types) ( class -- )
-    flatten [
+    flatten-class [
         drop dup superclass
         [ (types) ] [ "type" word-prop dup set ] ?if
     ] hash-each ;
@@ -46,7 +47,7 @@ DEFER: class<
     >r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
-    >r flatten r> flatten hash-keys swap
+    >r flatten-class r> flatten-class hash-keys swap
     [ drop swap [ class< ] contains-with? ] hash-all-with? ;
 
 : class-empty? ( class -- ? )
@@ -145,7 +146,7 @@ M: generic definer drop \ G: ;
 
 : define-class ( class -- )
     dup t "class" set-word-prop
-    dup flatten typemap get set-hash ;
+    dup flatten-class typemap get set-hash ;
 
 : implementors ( class -- list )
     [ "methods" word-prop ?hash* nip ] word-subset-with ;

library/generic/generic.facts

@@ -43,7 +43,7 @@ HELP: members "( class -- seq )"
 { $values { "class" "a class word" } { "seq" "a sequence of union members, or " { $link f } } }
 { $description "If " { $snippet "class" } " is a union class, outputs a sequence of members, otherwise outputs " { $link f } "." } ;
 
-HELP: flatten "( class -- seq )"
+HELP: flatten-class "( class -- seq )"
 { $values { "class" "a class word" } { "seq" "a sequence of classes" } }
 { $description "Outputs a sequence of classes whose union is the given class. Unless the given class is a union class, the output is just a singleton sequence consisting of the given class." } ;
 

library/generic/standard-combination.factor

@@ -45,7 +45,8 @@ math namespaces sequences vectors words ;
 
 : vtable-methods ( dispatch# alist-seq -- alist-seq )
     dup length [
-        type>class [ swap simplify-alist ] [ car second [ ] ] if*
+        type>class
+        [ swap simplify-alist ] [ car second [ ] ] if*
         >r over r> class-predicates alist>quot
     ] 2map nip ;
 
@@ -55,7 +56,10 @@ math namespaces sequences vectors words ;
     >r methods >list r> swons r> sort-methods vtable-methods ;
 
 : small-generic ( dispatch# word -- def )
-    2dup methods class-predicates >r empty-method r> alist>quot ;
+    2dup empty-method object bootstrap-word swap 2array
+    swap methods >list cons
+    object bootstrap-word swap simplify-alist
+    swapd class-predicates alist>quot ;
 
 : big-generic ( dispatch# word n dispatcher -- def )
     [ >r pick picker % r> , <vtable> , \ dispatch , ] [ ] make ;

library/generic/tuple.factor

@@ -3,6 +3,9 @@
 IN: kernel-internals
 USING: arrays errors hashtables kernel lists math namespaces parser sequences sequences-internals strings vectors words ;
 
+: class-tuple ( object -- class )
+    dup tuple? [ 2 slot ] [ drop f ] if ; inline
+
 : tuple= ( tuple tuple -- ? )
     2dup [ array-capacity ] 2apply number= [
         dup array-capacity
@@ -11,14 +14,15 @@ USING: arrays errors hashtables kernel lists math namespaces parser sequences se
         2drop f
     ] if ; inline
 
+: tuple-hashcode ( n tuple -- n )
+    dup class-tuple hashcode >r >r 1- r>
+    4 slot hashcode* r> bitxor ;
+
 IN: generic
 
 : class ( object -- class )
     dup tuple? [ 2 slot ] [ type type>class ] if ; inline
 
-: class-tuple ( object -- class )
-    dup tuple? [ 2 slot ] [ drop f ] if ; inline
-
 : tuple-predicate ( word -- )
     dup predicate-word
     [ \ class-tuple , over literalize , \ eq? , ] [ ] make
@@ -73,7 +77,14 @@ PREDICATE: word tuple-class "tuple-size" word-prop ;
 M: tuple clone ( tuple -- tuple )
     (clone) dup delegate clone over set-delegate ;
 
-M: tuple hashcode ( vec -- n ) array-capacity ;
+M: tuple hashcode* ( n tuple -- n )
+    {
+        { [ over 0 <= ] [ 2drop 0 ] }
+        { [ dup array-capacity 2 <= ] [ nip class-tuple hashcode ] }
+        { [ t ] [ tuple-hashcode ] }
+    } cond ;
+
+M: tuple hashcode ( tuple -- n ) 2 swap hashcode* ;
 
 M: tuple = ( obj tuple -- ? )
     2dup eq?

library/inference/class-infer.factor

@@ -69,10 +69,12 @@ M: node child-ties ( node -- seq )
         [ value-class* class-and ] keep set-value-class*
     ] 2each ;
 
+: set-tie ( tie tie -- ) ties get set-hash ;
+
 : type/tag-ties ( node n -- )
     over node-out-d first over [ <literal-tie> ] map-with
     >r swap node-in-d first swap [ type>class <class-tie> ] map-with r>
-    [ ties get set-hash ] 2each ;
+    [ set-tie ] 2each ;
 
 \ type [ num-types type/tag-ties ] "create-ties" set-word-prop
 
@@ -82,7 +84,7 @@ M: node child-ties ( node -- seq )
     dup node-in-d second value? [
         dup node-in-d first2 value-literal* <literal-tie>
         over node-out-d first general-t <class-tie>
-        ties get set-hash
+        set-tie
     ] when drop
 ] "create-ties" set-word-prop
 
@@ -95,7 +97,7 @@ M: node child-ties ( node -- seq )
         drop dup node-param "predicating" word-prop dup [
             >r dup node-in-d first r> <class-tie>
             swap node-out-d first general-t <class-tie>
-            ties get set-hash
+            set-tie
         ] [
             2drop
         ] if

library/inference/kill-literals.factor

@@ -14,10 +14,10 @@ GENERIC: literals* ( node -- seq )
 : literals ( node -- hash )
     [ literals* ] node-union ;
 
-GENERIC: flushable-values* ( node -- seq )
+! GENERIC: flushable-values* ( node -- seq )
-
+! 
-: flushable-values ( node -- hash )
+! : flushable-values ( node -- hash )
-    [ flushable-values* ] node-union ;
+!     [ flushable-values* ] node-union ;
 
 GENERIC: live-values* ( node -- seq )
 
@@ -44,7 +44,7 @@ GENERIC: live-values* ( node -- seq )
 ! Generic nodes
 M: node literals* ( node -- ) drop { } ;
 
-M: node flushable-values* ( node -- ) drop { } ;
+! M: node flushable-values* ( node -- ) drop { } ;
 
 M: node live-values* ( node -- ) node-values ;
 
@@ -54,9 +54,9 @@ M: #shuffle literals* ( node -- seq )
     [ [ value? ] subset ] 2apply append ;
 
 ! #call
-M: #call flushable-values* ( node -- )
+! M: #call flushable-values* ( node -- )
-    dup node-param "flushable" word-prop
+!     dup node-param "flushable" word-prop
-    [ node-out-d ] [ drop { } ] if ;
+!     [ node-out-d ] [ drop { } ] if ;
 
 ! #return
 M: #return live-values* ( node -- seq )

library/kernel.factor

@@ -10,6 +10,9 @@ USING: generic kernel-internals math-internals ;
 GENERIC: hashcode ( obj -- n ) flushable
 M: object hashcode drop 0 ;
 
+GENERIC: hashcode* ( n obj -- n ) flushable
+M: object hashcode* nip hashcode ;
+
 GENERIC: = ( obj obj -- ? ) flushable
 M: object = eq? ;
 
@@ -30,6 +33,8 @@ M: object clone ;
 
 : cpu ( -- arch ) 7 getenv ;
 : os ( -- os ) 11 getenv ;
+: windows? ( -- ? ) os "win32" = ;
+: macosx? os "macosx" = ;
 
 : slip >r call r> ; inline
 

library/opengl/gl.factor

@@ -6,7 +6,7 @@
 IN: opengl 
 USING: alien kernel ;
 
-os "win32" = [
+windows? [
     "gl" "opengl32.dll" "stdcall" add-library
     "glu" "glu32.dll" "stdcall" add-library
 ]

library/syntax/see.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2003, 2005 Slava Pestov.
+! Copyright (C) 2003, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: prettyprint
 USING: arrays generic hashtables io kernel lists math namespaces
 sequences strings styles words ;
@@ -117,9 +117,9 @@ M: word class. drop ;
         newline
     ] with-pprint ;
 
-: (apropos) ( substring -- seq )
+: completions ( substring words -- seq )
-    all-words [ word-name [ subseq? ] completion? ] subset-with ;
+    [ word-name subseq? ] subset-with ;
 
 : apropos ( substring -- )
-    (apropos) natural-sort
+    all-words completions natural-sort
     [ [ synopsis ] keep simple-object terpri ] each ;

library/test/test.factor

@@ -14,10 +14,13 @@ M: assert summary drop "Assertion failed" ;
 : print-test ( input output -- )
     "--> " write 2array . flush ;
 
+: benchmark ( quot -- gctime runtime )
+    millis >r gc-time >r call gc-time r> - millis r> - ;
+
 : time ( code -- )
     #! Evaluates the given code and prints the time taken to
     #! execute it.
-    millis >r gc-time >r call gc-time r> - millis r> -
+    benchmark
     [ # " ms run / " % # " ms GC time" % ] "" make print flush ;
 
 : unit-test ( output input -- )

library/ui/editors.factor

@@ -87,7 +87,7 @@ TUPLE: editor line caret font color ;
     swap [ first complete ] with-editor ;
 
 : do-completion ( editor -- )
-    dup [ completions ] with-editor {
+    dup [ line-completions ] with-editor {
         { [ dup empty? ] [ 2drop ] }
         { [ dup length 1 = ] [ do-completion-1 ] }
         { [ t ] [ completion-menu ] }

library/ui/line-editor.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: line-editor
-USING: kernel math namespaces sequences strings vectors ;
+USING: kernel math namespaces prettyprint sequences strings
+vectors ;
 
 SYMBOL: history
 SYMBOL: history-index
@@ -140,12 +141,11 @@ M: document-elt prev-elt* 3drop 0 ;
     history-index get dup 1+ history-length >=
     [ drop ] [ 1+ goto-history ] if ;
 
-: completions ( -- seq )
+: line-completions ( -- seq )
     T{ word-elt } prev-elt@ 2dup = [
         2drop f
     ] [
-        line-text get subseq possibilities get
+        line-text get subseq possibilities get completions
-        [ [ swap head? ] completion? ] subset-with
     ] if ;
 
 : complete ( completion -- )

library/ui/world.factor

@@ -18,6 +18,9 @@ TUPLE: world glass status focus fonts handle ;
 : font-sprites ( font world -- sprites )
     world-fonts [ drop V{ } clone ] cache ;
 
+: close-world ( world -- )
+    dup remove-notify dup free-fonts f swap set-world-handle ;
+
 C: world ( gadget status dim -- world )
     <stack> over set-delegate
     t over set-gadget-root?

library/words.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: words
-USING: generic hashtables kernel kernel-internals lists math
+USING: hashtables kernel kernel-internals lists math
 namespaces sequences strings vectors ;
 
 M: word <=> [ word-name ] 2apply <=> ;
@@ -38,7 +38,8 @@ M: word word-xt ( w -- xt ) 7 integer-slot ;
 GENERIC: set-word-xt
 M: word set-word-xt ( xt w -- ) 7 set-integer-slot ;
 
-: uses ( word -- uses ) word-def [ word? ] tree-subset prune ;
+: uses ( word -- uses )
+    word-def flatten [ word? ] subset prune ;
 
 SYMBOL: crossref