steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

hashtables bootstrap correctly

cvs
Slava Pestov 2005-01-28 01:06:10 +00:00
parent 0dfb0cf01e
commit 67af634d00
26 changed files with 225 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -24,7 +24,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
native/unix/read.o \
native/unix/write.o \
native/unix/ffi.o \
native/debug.o
native/debug.o \
native/hashtable.o
default:
@echo "Run 'make' with one of the following parameters:"

14
library/arrays.factor
View File

@ -29,6 +29,7 @@ IN: kernel-internals
USE: generic
USE: math-internals
USE: kernel
USE: lists
! An array is a range of memory storing pointers to other
! objects. Arrays are not used directly, and their access words
@ -42,7 +43,7 @@ USE: kernel
BUILTIN: array 8
: array-capacity ( array -- n ) 1 integer-slot ; inline
: array-capacity ( array -- n ) 1 slot ; inline
: vector-array ( vec -- array ) 2 slot ; inline
: set-vector-array ( array vec -- ) 2 set-slot ; inline
@ -51,3 +52,14 @@ BUILTIN: array 8
: set-array-nth ( obj n array -- )
swap 2 fixnum+ set-slot ; inline
: (array>list) ( n i array -- list )
pick pick fixnum<= [
3drop [ ]
] [
2dup array-nth >r >r 1 fixnum+ r> (array>list) r>
swap cons
] ifte ;
: array>list ( n array -- list )
0 swap (array>list) ;

41
library/bootstrap/image.factor
View File

@ -41,6 +41,7 @@
IN: image
USE: errors
USE: generic
USE: kernel-internals
USE: hashtables
USE: kernel
USE: lists
@ -86,12 +87,12 @@ SYMBOL: boot-quot
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: f-type 6 ; inline
: t-type 7 ; inline
: array-type 8 ; inline
: vector-type 11 ; inline
: string-type 12 ; inline
: word-type 17 ; inline
: t-type 7 ; inline
: array-type 8 ; inline
: hashtable-type 10 ; inline
: vector-type 11 ; inline
: string-type 12 ; inline
: word-type 17 ; inline
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) object-tag immediate ;
@ -142,6 +143,8 @@ GENERIC: ' ( obj -- ptr )
( Fixnums )
: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
( Bignums )
@ -154,7 +157,7 @@ M: bignum ' ( bignum -- tagged )
[[ 0 [ 1 0 ] ]]
[[ -1 [ 2 1 1 ] ]]
[[ 1 [ 2 0 1 ] ]]
] assoc [ emit ] each align-here r> ;
] assoc unswons emit-fixnum [ emit ] each align-here r> ;
( Special objects )
@ -175,7 +178,7 @@ M: f ' ( obj -- ptr )
: -1, -1 >bignum ' drop ;
( Beginning of the image )
! The image proper begins with the header, then T,
! The image begins with the header, then T,
! and the bignums 0, 1, and -1.
: begin ( -- ) header t, 0, 1, -1, ;
@ -249,7 +252,7 @@ M: cons ' ( c -- tagged )
object-tag here-as swap
string-type >header emit
dup str-length emit
dup hashcode fixnum-tag immediate emit
dup hashcode emit-fixnum
pack-string
align-here ;
@ -266,7 +269,7 @@ M: string ' ( string -- pointer )
[ ' ] map
object-tag here-as >r
array-type >header emit
dup length emit
dup length emit-fixnum
( elements -- ) [ emit ] each
align-here r> ;
@ -274,7 +277,7 @@ M: string ' ( string -- pointer )
dup vector>list emit-array swap vector-length
object-tag here-as >r
vector-type >header emit
emit ( length )
emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
@ -284,24 +287,30 @@ M: vector ' ( vector -- pointer )
: rehash ( hashtable -- )
! Now make a rehashing boot quotation
dup hash>alist [
>r dup vector-length [
[ f swap pick set-vector-nth ] keep
] repeat r>
over hash-clear
[ unswons rot set-hash ] each-with
] cons cons
boot-quot [ append ] change ;
: emit-hashtable ( hash -- pointer )
dup buckets>list emit-array swap hash-size
object-tag here-as >r
hashtable-type >header emit
emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
M: hashtable ' ( hashtable -- pointer )
#! Only hashtables are pooled, not vectors!
dup pooled-object [
[ dup emit-vector [ pool-object ] keep ] keep rehash
[ dup emit-hashtable [ pool-object ] keep ] keep rehash
] ?unless ;
( End of the image )
: vocabularies, ( vocabularies -- )
[
cdr dup vector? [
cdr dup hashtable? [
[
cdr dup word? [ word, ] [ drop ] ifte
] hash-each

3
library/bootstrap/primitives.factor
View File

@ -218,11 +218,14 @@ vocabularies get [
[[ "vectors" ">vector" ]]
[[ "strings" ">string" ]]
[[ "words" ">word" ]]
[[ "hashtables" ">hashtable" ]]
[[ "kernel-internals" "slot" ]]
[[ "kernel-internals" "set-slot" ]]
[[ "kernel-internals" "integer-slot" ]]
[[ "kernel-internals" "set-integer-slot" ]]
[[ "kernel-internals" "grow-array" ]]
[[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop

4
library/generic/traits.factor
View File

@ -39,7 +39,7 @@ USE: vectors
! Traits metaclass for user-defined classes based on hashtables
: traits ( object -- symbol )
dup vector? [ \ traits swap hash ] [ drop f ] ifte ;
dup hashtable? [ \ traits swap hash ] [ drop f ] ifte ;
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
@ -58,7 +58,7 @@ SYMBOL: delegate
] ifte ;
: add-traits-dispatch ( word vtable -- )
>r unit [ car traits-dispatch call ] cons \ vector r>
>r unit [ car traits-dispatch call ] cons \ hashtable r>
set-vtable ;
\ traits [

85
library/hashtables.factor
View File

@ -25,37 +25,45 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel-internals
IN: hashtables
USE: generic
USE: kernel
USE: lists
USE: math
USE: vectors
: hash-array vector-array ; inline
: bucket-count >vector hash-array array-capacity ; inline
BUILTIN: hashtable 10
! A hashtable is implemented as an array of buckets. The
! array index is determined using a hash function, and the
! buckets are associative lists which are searched
! linearly.
IN: kernel-internals
: hash-array 2 slot ; inline
: hash-bucket ( n hash -- alist )
swap >fixnum swap >vector hash-array array-nth ; inline
swap >fixnum swap >hashtable hash-array array-nth ; inline
: set-hash-bucket ( obj n hash -- )
>r >fixnum r> hash-array set-array-nth ; inline
swap >fixnum swap >hashtable hash-array set-array-nth ;
inline
: hash-size+ ( hash -- )
>hashtable dup 1 slot 1 + swap 1 set-slot ; inline
: hash-size- ( hash -- )
>hashtable dup 1 slot 1 - swap 1 set-slot ; inline
IN: hashtables
! Note that the length of a hashtable vector must not change
! for the lifetime of the hashtable, otherwise problems will
! occur. Do not use vector words with hashtables.
: hash-size ( hash -- n )
#! Number of elements in the hashtable.
>hashtable 1 slot ;
PREDICATE: vector hashtable ( obj -- ? )
[ assoc? ] vector-all? ;
: <hashtable> ( buckets -- )
#! A hashtable is implemented as an array of buckets. The
#! array index is determined using a hash function, and the
#! buckets are associative lists which are searched
#! linearly. The number of buckets must be a power of two.
empty-vector ;
: bucket-count ( hash -- n )
>hashtable hash-array array-capacity ; inline
: (hashcode) ( key table -- index )
#! Compute the index of the bucket for a key.
@ -74,6 +82,8 @@ PREDICATE: vector hashtable ( obj -- ? )
: set-hash* ( key table quot -- )
#! Apply the quotation to yield a new association list.
#! If the association list already contains the key,
#! decrement the hash size, since it will get removed.
>r
2dup (hashcode)
r> pick >r
@ -86,27 +96,46 @@ PREDICATE: vector hashtable ( obj -- ? )
#! Store the value in the hashtable. Either replaces an
#! existing value in the appropriate bucket, or adds a new
#! key/value pair.
dup hash-size+
[ set-assoc ] set-hash* ;
: remove-hash ( key table -- )
#! Remove a value from a hashtable.
[ remove-assoc ] set-hash* ;
: hash-each ( hash code -- )
#! Apply the code to each key/value pair of the hashtable.
swap [ swap dup >r each r> ] vector-each drop ; inline
: hash-clear ( hash -- )
#! Remove all entries from a hashtable.
dup bucket-count [
[ f swap pick set-hash-bucket ] keep
] repeat drop ;
: buckets>list ( hash -- list )
#! Push a list of key/value pairs in a hashtable.
dup bucket-count swap hash-array array>list ;
: (hash>alist) ( alist n hash -- alist )
2dup bucket-count >= [
2drop
] [
[ hash-bucket [ swons ] each ] 2keep
>r 1 + r> (hash>alist)
] ifte ;
: hash>alist ( hash -- alist )
#! Push a list of key/value pairs in a hashtable.
[ ] 0 rot (hash>alist) ;
: alist>hash ( alist -- hash )
dup length <hashtable> swap [ unswons pick set-hash ] each ;
: hash-keys ( hash -- list )
#! Push a list of keys in a hashtable.
[ ] swap [ car swons ] hash-each ;
hash>alist [ car ] map ;
: hash-values ( hash -- alist )
#! Push a list of values in a hashtable.
[ ] swap [ cdr swons ] hash-each ;
hash>alist [ cdr ] map ;
: hash>alist ( hash -- list )
#! Push a list of key/value pairs in a hashtable.
[ ] swap [ swons ] hash-each ;
: alist>hash ( alist -- hash )
37 <hashtable> swap [ unswons pick set-hash ] each ;
: hash-each ( hash code -- )
#! Apply the code to each key/value pair of the hashtable.
>r hash>alist r> each ; inline

2
library/namespaces.factor
View File

@ -61,7 +61,7 @@ USE: math
: >n ( namespace -- n:namespace )
#! Push a namespace on the namespace stack.
>vector namestack cons set-namestack ; inline
>hashtable namestack cons set-namestack ; inline
: n> ( n:namespace -- namespace )
#! Pop the top of the namespace stack.

6
library/primitives.factor
View File

@ -26,6 +26,7 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: alien
USE: hashtables
DEFER: alien
DEFER: dll
@ -215,12 +216,15 @@ USE: words
[ >cons [ [ object ] [ cons ] ] ]
[ >vector [ [ object ] [ vector ] ] ]
[ >string [ [ object ] [ string ] ] ]
[ >word [ [ word ] [ word ] ] ]
[ >word [ [ object ] [ word ] ] ]
[ >hashtable [ [ object ] [ hashtable ] ] ]
[ slot [ [ object fixnum ] [ object ] ] ]
[ set-slot [ [ object object fixnum ] [ ] ] ]
[ integer-slot [ [ object fixnum ] [ integer ] ] ]
[ set-integer-slot [ [ integer object fixnum ] [ ] ] ]
[ grow-array [ [ integer array ] [ object ] ] ]
[ <hashtable> [ [ number ] [ hashtable ] ] ]
[ <array> [ [ number ] [ array ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property

14
library/test/hashtables.factor
View File

@ -58,3 +58,17 @@ f 100000000000000000000000000 "testhash" get set-hash
"visual basic" "testhash" get remove-hash
"visual basic" "testhash" get hash*
] unit-test
[ 4 ] [
"hey"
{{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode)
>r buckets>list r> [ cdr ] times car assoc
] unit-test
! Testing the hash element counting
<namespace> "counting" set
"key" "value" "counting" get set-hash
[ 1 ] [ "counting" get hash-size ] unit-test
"key" "value" "counting" get set-hash
[ 1 ] [ "counting" get hash-size ] unit-test

2
library/test/vectors.factor
View File

@ -78,7 +78,7 @@ unit-test
[ "funky" ] [ "funny-stack" get vector-pop ] unit-test
[ t ] [
10 <vector> dup vector-array array-capacity
{ 1 2 3 4 } dup vector-array array-capacity
>r vector-clone vector-array array-capacity r>
=
] unit-test

15
library/vectors.factor
View File

@ -36,11 +36,11 @@ USE: math-internals
BUILTIN: vector 11
: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
: vector-length ( vec -- len ) >vector 1 slot ; inline
IN: kernel-internals
: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
: (set-vector-length) ( len vec -- ) 1 set-slot ; inline
: assert-positive ( fx -- )
0 fixnum<
@ -107,15 +107,8 @@ IN: vectors
: >pop> ( stack -- stack )
dup vector-pop drop ;
: (vector>list) ( i vec -- list )
2dup vector-length >= [
2drop [ ]
] [
2dup vector-nth >r >r 1 + r> (vector>list) r> swons
] ifte ;
: vector>list ( str -- list )
0 swap (vector>list) ;
: vector>list ( vec -- list )
dup vector-length swap vector-array array>list ;
: vector-each ( vector quotation -- )
#! Execute the quotation with each element of the vector

29
native/array.c
View File

@ -5,7 +5,7 @@ F_ARRAY* allot_array(CELL type, CELL capacity)
{
F_ARRAY* array;
array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
array->capacity = capacity;
array->capacity = tag_fixnum(capacity);
return array;
}
@ -22,20 +22,30 @@ F_ARRAY* array(CELL capacity, CELL fill)
return array;
}
void primitive_array(void)
{
F_FIXNUM capacity = to_fixnum(dpop());
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
maybe_garbage_collection();
dpush(tag_object(array(capacity,F)));
}
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
int i;
F_ARRAY* new_array;
CELL curr_cap = untag_fixnum_fast(array->capacity);
if(array->capacity >= capacity)
if(curr_cap >= capacity)
return array;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,array->capacity * CELLS);
for(i = array->capacity; i < capacity; i++)
for(i = curr_cap; i < capacity; i++)
put(AREF(new_array,i),fill);
return new_array;
@ -43,8 +53,11 @@ F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
void primitive_grow_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = to_fixnum(dpop());
F_ARRAY* array;
CELL capacity;
maybe_garbage_collection();
array = untag_array(dpop());
capacity = to_fixnum(dpop());
dpush(tag_object(grow_array(array,capacity,F)));
}
@ -58,13 +71,15 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
void fixup_array(F_ARRAY* array)
{
int i = 0;
for(i = 0; i < array->capacity; i++)
CELL capacity = untag_fixnum_fast(array->capacity);
for(i = 0; i < capacity; i++)
data_fixup((void*)AREF(array,i));
}
void collect_array(F_ARRAY* array)
{
int i = 0;
for(i = 0; i < array->capacity; i++)
CELL capacity = untag_fixnum_fast(array->capacity);
for(i = 0; i < capacity; i++)
copy_object((void*)AREF(array,i));
}

9
native/array.h
View File

@ -1,17 +1,18 @@
typedef struct {
CELL header;
/* untagged */
/* tagged */
CELL capacity;
} F_ARRAY;
INLINE F_ARRAY* untag_array(CELL tagged)
{
/* type_check(ARRAY_TYPE,tagged); */
return (F_ARRAY*)UNTAG(tagged); /* FIXME */
type_check(ARRAY_TYPE,tagged);
return (F_ARRAY*)UNTAG(tagged);
}
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL capacity, CELL fill);
void primitive_array(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
@ -19,7 +20,7 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define ASIZE(pointer) align8(sizeof(F_ARRAY) + \
((F_ARRAY*)(pointer))->capacity * CELLS)
untag_fixnum_fast(((F_ARRAY*)(pointer))->capacity) * CELLS)
void fixup_array(F_ARRAY* array);
void collect_array(F_ARRAY* array);

1
native/factor.h
View File

@ -135,6 +135,7 @@ typedef unsigned char BYTE;
#include "image.h"
#include "primitives.h"
#include "vector.h"
#include "hashtable.h"
#include "stack.h"
#include "compiler.h"
#include "relocate.h"

3
native/gc.c
View File

@ -71,6 +71,9 @@ INLINE void collect_object(CELL scan)
case ARRAY_TYPE:
collect_array((F_ARRAY*)scan);
break;
case HASHTABLE_TYPE:
collect_hashtable((F_HASHTABLE*)scan);
break;
case VECTOR_TYPE:
collect_vector((F_VECTOR*)scan);
break;

3
native/gc.h
View File

@ -27,6 +27,9 @@ INLINE void copy_object(CELL* handle)
if(tag == FIXNUM_TYPE)
return;
if(headerp(pointer))
critical_error("Asked to copy header",pointer);
header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
newpointer = UNTAG(header);

33
native/hashtable.c Normal file
View File

@ -0,0 +1,33 @@
#include "factor.h"
F_HASHTABLE* hashtable(F_FIXNUM capacity)
{
F_HASHTABLE* hash;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR));
hash->count = tag_fixnum(0);
hash->array = tag_object(array(capacity,F));
return hash;
}
void primitive_hashtable(void)
{
maybe_garbage_collection();
drepl(tag_object(hashtable(to_fixnum(dpeek()))));
}
void primitive_to_hashtable(void)
{
type_check(HASHTABLE_TYPE,dpeek());
}
void fixup_hashtable(F_HASHTABLE* hashtable)
{
data_fixup(&hashtable->array);
}
void collect_hashtable(F_HASHTABLE* hashtable)
{
copy_object(&hashtable->array);
}

15
native/hashtable.h Normal file
View File

@ -0,0 +1,15 @@
typedef struct {
/* always tag_header(HASHTABLE_TYPE) */
CELL header;
/* tagged */
CELL count;
/* tagged */
CELL array;
} F_HASHTABLE;
F_HASHTABLE* hashtable(F_FIXNUM capacity);
void primitive_hashtable(void);
void primitive_to_hashtable(void);
void fixup_hashtable(F_HASHTABLE* hashtable);
void collect_hashtable(F_HASHTABLE* hashtable);

5
native/primitives.c
View File

@ -168,11 +168,14 @@ void* primitives[] = {
primitive_to_vector,
primitive_to_string,
primitive_to_word,
primitive_to_hashtable,
primitive_slot,
primitive_set_slot,
primitive_integer_slot,
primitive_set_integer_slot,
primitive_grow_array
primitive_grow_array,
primitive_hashtable,
primitive_array
};
CELL primitive_to_xt(CELL primitive)

3
native/relocate.c
View File

@ -10,6 +10,9 @@ void relocate_object(CELL relocating)
case ARRAY_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
case HASHTABLE_TYPE:
fixup_hashtable((F_HASHTABLE*)relocating);
break;
case VECTOR_TYPE:
fixup_vector((F_VECTOR*)relocating);
break;

2
native/s48_bignumint.h
View File

@ -83,7 +83,7 @@ typedef long bignum_length_type;
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
#define BIGNUM_LENGTH(bignum) ((bignum)->capacity - 1)
#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)

4
native/stack.c
View File

@ -81,7 +81,7 @@ F_VECTOR* stack_to_vector(CELL bottom, CELL top)
F_VECTOR* v = vector(depth);
F_ARRAY* a = untag_array(v->array);
memcpy(a + 1,(void*)bottom,depth * CELLS);
v->top = depth;
v->top = tag_fixnum(depth);
return v;
}
@ -101,7 +101,7 @@ void primitive_callstack(void)
CELL vector_to_stack(F_VECTOR* vector, CELL bottom)
{
CELL start = bottom;
CELL len = vector->top * CELLS;
CELL len = untag_fixnum_fast(vector->top) * CELLS;
memcpy((void*)start,untag_array(vector->array) + 1,len);
return start + len - CELLS;
}

3
native/types.c
View File

@ -55,6 +55,9 @@ CELL untagged_object_size(CELL pointer)
case BIGNUM_TYPE:
size = ASIZE(pointer);
break;
case HASHTABLE_TYPE:
size = sizeof(F_HASHTABLE);
break;
case VECTOR_TYPE:
size = sizeof(F_VECTOR);
break;

1
native/types.h
View File

@ -27,6 +27,7 @@ CELL T;
#define F_TYPE 9
#define F RETAG(0,OBJECT_TYPE)
#define HASHTABLE_TYPE 10
#define VECTOR_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13

2
native/vector.c
View File

@ -6,7 +6,7 @@ F_VECTOR* vector(F_FIXNUM capacity)
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = 0;
vector->top = tag_fixnum(0);
vector->array = tag_object(array(capacity,F));
return vector;
}

2
native/vector.h
View File

@ -1,7 +1,7 @@
typedef struct {
/* always tag_header(VECTOR_TYPE) */
CELL header;
/* untagged */
/* tagged */
CELL top;
/* tagged */
CELL array;