make class< a bit faster, mutable strings

TODO.FACTOR.txt

@@ -1,4 +1,3 @@
-- remove <ushort*-array>, <char*-array>, <void*-array>
 - if cell is rebound, and we allocate c objects, bang
 - make-image leaks memory if there is an error while parsing files
 - runtime primitives like fopen: check for null input

library/bootstrap/primitives.factor

@@ -40,7 +40,6 @@ call
     { "<vector>" "vectors"                  }
     { "rehash-string" "strings"             }
     { "<sbuf>" "strings"                    }
-    { "sbuf>string" "strings"               }
     { ">fixnum" "math"                      }
     { ">bignum" "math"                      }
     { ">float" "math"                       }
@@ -338,7 +337,7 @@ num-types f <array> builtins set
 "string" "strings" create 12 "string?" "strings" create
 {
     { 1 { "length" "sequences" } f }
-    { 2 { "hashcode" "kernel" } f }
+    { 2 { "string-hashcode" "kernel-internals" } { "set-string-hashcode" "kernel-internals" } }
 } define-builtin
 
 "sbuf?" "strings" create t "inline" set-word-prop 

library/collections/hashtables.factor

@@ -127,7 +127,7 @@ IN: hashtables
         3drop f f
     ] if-key ;
 
-: hash-contains? ( key hash -- ? )
+: hash-member? ( key hash -- ? )
     [ 3drop t ] [ 3drop f ] if-key ;
 
 : ?hash* ( key hash -- value/f ? )
@@ -247,7 +247,7 @@ M: hashtable = ( obj hash -- ? )
     #! Searches for a key in a sequence of hashtables,
     #! where the most recently pushed hashtable is searched
     #! first.
-    [ dupd hash-contains? ] find-last nip ?hash ; flushable
+    [ dupd hash-member? ] find-last nip ?hash ; flushable
 
 : hash-intersect ( hash1 hash2 -- hash1/\hash2 )
     #! Remove all keys from hash2 not in hash1.
@@ -273,7 +273,7 @@ M: hashtable = ( obj hash -- ? )
 : remove-all ( hash seq -- seq )
     #! Remove all elements from the sequence that are keys
     #! in the hashtable.
-    [ swap hash-contains? not ] subset-with ; flushable
+    [ swap hash-member? not ] subset-with ; flushable
 
 : cache ( key hash quot -- value | quot: key -- value )
     pick pick hash [

library/collections/sbuf.factor

@@ -1,27 +1,20 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel-internals
-USING: kernel math strings sequences-internals ;
-
-: (sbuf>string) underlying dup rehash-string ;
-
 IN: strings
-USING: generic sequences ;
+USING: kernel math strings sequences-internals sequences ;
 
 M: string resize resize-string ;
 
 M: sbuf set-length ( n sbuf -- ) grow-length ;
 
-M: sbuf nth-unsafe underlying >r >fixnum r> char-slot ;
+M: sbuf nth-unsafe ( n sbuf -- ch ) underlying nth-unsafe ;
 
 M: sbuf nth ( n sbuf -- ch ) bounds-check nth-unsafe ;
 
 M: sbuf set-nth-unsafe ( ch n sbuf -- )
-    underlying >r >fixnum >r >fixnum r> r> set-char-slot ;
+    underlying set-nth-unsafe ;
 
 M: sbuf set-nth ( ch n sbuf -- )
     growable-check 2dup ensure set-nth-unsafe ;
 
-M: sbuf >string sbuf>string ;
-
 M: sbuf clone clone-growable ;

library/collections/strings-epilogue.factor

@@ -4,9 +4,6 @@ IN: strings
 USING: generic kernel kernel-internals lists math namespaces
 sequences strings ;
 
-: empty-sbuf ( len -- sbuf )
-    dup <sbuf> [ set-length ] keep ; inline
-
 : padding ( string count char -- string )
     >r swap length - 0 max r> <string> ; flushable
 
@@ -21,11 +18,13 @@ sequences strings ;
 : >sbuf ( seq -- sbuf )
     dup length <sbuf> [ swap nappend ] keep ; inline
 
-M: object >string >sbuf (sbuf>string) ;
+: >string ( seq -- array )
+    [ length 0 <string> 0 over ] keep copy-into ; inline
 
 M: string thaw >sbuf ;
 
-M: string like ( seq sbuf -- string ) drop >string ;
+M: string like ( seq sbuf -- string )
+    drop dup string? [ >string ] unless ;
 
 M: sbuf like ( seq sbuf -- sbuf )
     drop dup sbuf? [ >sbuf ] unless ;

library/collections/strings.factor

@@ -4,13 +4,25 @@ IN: strings
 USING: generic kernel kernel-internals lists math sequences
 sequences-internals ;
 
+M: string hashcode ( string -- n )
+    #! Recompute cached hashcode if necessary.
+    dup string-hashcode [ ] [
+        dup rehash-string string-hashcode
+    ] ?if ;
+
 M: string nth ( n str -- ch ) bounds-check char-slot ;
 
 M: string nth-unsafe ( n str -- ch ) >r >fixnum r> char-slot ;
 
-GENERIC: >string ( seq -- string ) flushable
+M: string set-nth ( ch n str -- )
+    bounds-check set-nth-unsafe ;
 
-M: string >string ;
+M: string set-nth-unsafe ( ch n str -- )
+    #! Reset cached hashcode.
+    f over set-string-hashcode
+    >r >fixnum >r >fixnum r> r> set-char-slot ;
+
+M: string clone ( string -- string ) (clone) ;
 
 ! Characters
 PREDICATE: integer blank     " \t\n\r" member? ;

library/generic/generic.factor

@@ -55,14 +55,17 @@ DEFER: class<
     >r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
-    [ flatten hash-keys ] 2apply
+    >r flatten r> flatten hash-keys swap
-    swap [ swap [ class< ] contains-with? ] all-with? ;
+    [ drop swap [ class< ] contains-with? ] hash-all-with? ;
+
+: class-empty? ( class -- ? )
+    members dup [ empty? ] when ;
 
 : class< ( cls1 cls2 -- ? )
     #! Test if class1 is a subclass of class2.
     {
         { [ 2dup eq? ] [ 2drop t ] }
-        { [ over flatten hash-empty? ] [ 2drop t ] }
+        { [ over class-empty? ] [ 2drop t ] }
         { [ 2dup superclass< ] [ 2drop t ] }
         { [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
         { [ t ] [ union-class< ] }
@@ -163,13 +166,16 @@ M: generic definer drop \ G: ;
     } cond ;
 
 : classes-intersect? ( class class -- ? )
-    class-and flatten hash-empty? not ;
+    class-and class-empty? not ;
 
 : min-class ( class seq -- class/f )
     #! Is this class the smallest class in the sequence?
-    [ dupd classes-intersect? ] subset reverse-slice
+    #! The input sequence should be sorted.
-    tuck [ class< ] all-with? over empty? not and
+    [ dupd classes-intersect? ] subset dup empty? [
-    [ first ] [ drop f ] if ;
+        2drop f
+    ] [
+        tuck [ class< ] all-with? [ peek ] [ drop f ] if
+    ] if ;
 
 : define-class ( class -- )
     dup t "class" set-word-prop

library/inference/known-words.factor

@@ -91,9 +91,6 @@ sequences strings vectors words prettyprint ;
 \ <sbuf> [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop
 \ <sbuf> t "flushable" set-word-prop
 
-\ sbuf>string [ [ sbuf ] [ string ] ] "infer-effect" set-word-prop
-\ sbuf>string t "flushable" set-word-prop
-
 \ >fixnum [ [ number ] [ fixnum ] ] "infer-effect" set-word-prop
 \ >fixnum t "flushable" set-word-prop
 \ >fixnum t "foldable" set-word-prop

library/io/string-streams.factor

@@ -25,7 +25,7 @@ M: sbuf stream-read ( count sbuf -- string )
     dup empty? [
         2drop f
     ] [
-        swap over length min empty-sbuf
+        swap over length min 0 <string>
         [ [ drop dup pop ] inject drop ] keep
     ] if ;
 

native/primitives.c

@@ -12,7 +12,6 @@ void* primitives[] = {
 	primitive_vector,
 	primitive_rehash_string,
 	primitive_sbuf,
-	primitive_sbuf_to_string,
 	primitive_to_fixnum,
 	primitive_to_bignum,
 	primitive_to_float,

native/sbuf.c

@@ -18,22 +18,6 @@ void primitive_sbuf(void)
 	drepl(tag_object(sbuf(size)));
 }
 
-void primitive_sbuf_to_string(void)
-{
-	F_STRING* result;
-	F_SBUF* sbuf = untag_sbuf(dpeek());
-	F_STRING* string = untag_string(sbuf->string);
-	CELL length = untag_fixnum_fast(sbuf->top);
-
-	result = allot_string(length);
-	memcpy(result + 1,
-		(void*)((CELL)(string + 1)),
-		CHARS * length);
-	rehash_string(result);
-
-	drepl(tag_object(result));
-}
-
 void fixup_sbuf(F_SBUF* sbuf)
 {
 	data_fixup(&sbuf->string);

native/sbuf.h

@@ -7,20 +7,7 @@ typedef struct {
 	CELL string;
 } F_SBUF;
 
-INLINE CELL sbuf_capacity(F_SBUF* sbuf)
-{
-	return untag_fixnum_fast(sbuf->top);
-}
-
-INLINE F_SBUF* untag_sbuf(CELL tagged)
-{
-	type_check(SBUF_TYPE,tagged);
-	return (F_SBUF*)UNTAG(tagged);
-}
-
 F_SBUF* sbuf(F_FIXNUM capacity);
-
 void primitive_sbuf(void);
-void primitive_sbuf_to_string(void);
 void fixup_sbuf(F_SBUF* sbuf);
 void collect_sbuf(F_SBUF* sbuf);