From 53c6cb21790dda62edc403c457e5c0bde66bfd1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 26 Dec 2005 02:05:31 +0000 Subject: [PATCH] make class< a bit faster, mutable strings --- TODO.FACTOR.txt | 1 - library/bootstrap/primitives.factor | 3 +-- library/collections/hashtables.factor | 6 +++--- library/collections/sbuf.factor | 13 +++---------- library/collections/strings-epilogue.factor | 9 ++++----- library/collections/strings.factor | 16 ++++++++++++++-- library/generic/generic.factor | 20 +++++++++++++------- library/inference/known-words.factor | 3 --- library/io/string-streams.factor | 2 +- native/primitives.c | 1 - native/sbuf.c | 16 ---------------- native/sbuf.h | 13 ------------- 12 files changed, 39 insertions(+), 64 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 6cbec48ffe..9d25f79ee1 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,4 +1,3 @@ -- remove , , - 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 diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index da42c0a697..9779fcc607 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -40,7 +40,6 @@ call { "" "vectors" } { "rehash-string" "strings" } { "" "strings" } - { "sbuf>string" "strings" } { ">fixnum" "math" } { ">bignum" "math" } { ">float" "math" } @@ -338,7 +337,7 @@ num-types f 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 diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index f397653592..b6f066feaa 100644 --- a/library/collections/hashtables.factor +++ b/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 [ diff --git a/library/collections/sbuf.factor b/library/collections/sbuf.factor index e6b2ae99fe..96e11f2a9f 100644 --- a/library/collections/sbuf.factor +++ b/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 ; diff --git a/library/collections/strings-epilogue.factor b/library/collections/strings-epilogue.factor index 99a3638bb4..cd5a3159d6 100644 --- a/library/collections/strings-epilogue.factor +++ b/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 [ set-length ] keep ; inline - : padding ( string count char -- string ) >r swap length - 0 max r> ; flushable @@ -21,11 +18,13 @@ sequences strings ; : >sbuf ( seq -- sbuf ) dup length [ swap nappend ] keep ; inline -M: object >string >sbuf (sbuf>string) ; +: >string ( seq -- array ) + [ length 0 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 ; diff --git a/library/collections/strings.factor b/library/collections/strings.factor index 10ab87eef5..1fdd5c03e4 100644 --- a/library/collections/strings.factor +++ b/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? ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 63e7280883..8d77b6bdd5 100644 --- a/library/generic/generic.factor +++ b/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 - swap [ swap [ class< ] contains-with? ] all-with? ; + >r flatten r> flatten hash-keys swap + [ 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 - tuck [ class< ] all-with? over empty? not and - [ first ] [ drop f ] if ; + #! The input sequence should be sorted. + [ dupd classes-intersect? ] subset dup empty? [ + 2drop f + ] [ + tuck [ class< ] all-with? [ peek ] [ drop f ] if + ] if ; : define-class ( class -- ) dup t "class" set-word-prop diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index d3a20360ff..66a07da811 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -91,9 +91,6 @@ sequences strings vectors words prettyprint ; \ [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop \ 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 diff --git a/library/io/string-streams.factor b/library/io/string-streams.factor index 337cb3292b..6dcc7207b2 100644 --- a/library/io/string-streams.factor +++ b/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 [ [ drop dup pop ] inject drop ] keep ] if ; diff --git a/native/primitives.c b/native/primitives.c index 6458c03757..5bf6e833ba 100644 --- a/native/primitives.c +++ b/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, diff --git a/native/sbuf.c b/native/sbuf.c index b4aad23f44..964ac24a7e 100644 --- a/native/sbuf.c +++ b/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); diff --git a/native/sbuf.h b/native/sbuf.h index dc50b460c4..b89d59d49a 100644 --- a/native/sbuf.h +++ b/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);