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

more dataflow work, minor native cleanup

cvs
Slava Pestov 2004-11-28 03:26:05 +00:00
parent 6364f415ed
commit 99651292cb
27 changed files with 1087 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -60,7 +60,7 @@ solaris:
f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
$(STRIP) $@
#$(STRIP) $@
clean:
rm -f $(OBJS)

1075
doc/new-guide.tex
View File

File diff suppressed because it is too large Load Diff

26
examples/quadratic.factor
View File

@ -25,24 +25,22 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
USE: combinators
IN: quadratic
USE: math
USE: stack
: quadratic-complete ( a b c -- a b c a b )
>r 2dup r> -rot ;
: quadratic-e ( b a -- -b/2a )
2 * / neg ;
: quadratic-d ( c a b -- sqrt[b^2 - 4*a*c] )
sq -rot 4 * * - sqrt ;
: quadratic-d ( a b c -- d )
pick 4 * * swap sq swap - swap sq 4 * / sqrt ;
: quadratic-root ( x y -- -y/x/2 )
neg swap / 2 / ;
: quadratic-roots ( a b d -- alpha beta )
3dup - quadratic-root >r + quadratic-root r> ;
: quadratic-roots ( d e -- alpha beta )
2dup + -rot - ;
: quadratic ( a b c -- alpha beta )
#! Finds both roots of the polynomial a*x^2 + b*x + c using
#! the quadratic formula.
quadratic-complete quadratic-d quadratic-roots ;
#! Finds both roots of the polynomial a*x^2 + b*x + c
#! using the quadratic formula.
3dup quadratic-d
nip swap rot quadratic-e
swap quadratic-roots ;

4
library/bootstrap/image.factor
View File

@ -283,9 +283,9 @@ DEFER: '
( Arrays and vectors )
: 'array ( list -- untagged )
: 'array ( list -- pointer )
[ ' ] map
here >r
object-tag here-as >r
array-type >header emit
dup length emit
( elements -- ) [ emit ] each

14
library/inference/dataflow.factor
View File

@ -26,9 +26,14 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: inference
USE: interpreter
USE: lists
USE: math
USE: namespaces
USE: stack
USE: words
USE: combinators
USE: vectors
! We build a dataflow graph for the compiler.
SYMBOL: dataflow-graph
@ -55,5 +60,10 @@ SYMBOL: 2GENERIC
: dataflow-literal, ( lit -- )
>r f PUSH r> dataflow, ;
: dataflow-word, ( in word -- )
>r count CALL r> dataflow, ;
: inputs ( count -- vector )
meta-d get [ vector-length swap - ] keep vector-tail ;
: dataflow-word, ( word -- )
[
"infer-effect" word-property car inputs CALL
] keep dataflow, ;

4
library/inference/inference.factor
View File

@ -58,7 +58,7 @@ SYMBOL: entry-effect
: gensym-vector ( n -- vector )
dup <vector> swap [ gensym over vector-push ] times ;
: inputs ( count stack -- stack )
: add-inputs ( count stack -- stack )
#! Add this many inputs to the given stack.
>r gensym-vector dup r> vector-append ;
@ -66,7 +66,7 @@ SYMBOL: entry-effect
#! Ensure stack has this many elements. Return number of
#! elements added.
2dup vector-length > [
[ vector-length - dup ] keep inputs
[ vector-length - dup ] keep add-inputs
] [
>r drop 0 r>
] ifte ;

8
library/inference/words.factor
View File

@ -45,9 +45,9 @@ USE: hashtables
#! either execute the word in the meta interpreter (if it is
#! side-effect-free and all parameters are literal), or
#! simply apply its stack effect to the meta-interpreter.
dup car pick dataflow-word,
dup car ensure-d over dataflow-word,
swap "infer" word-property dup [
swap car ensure-d call
nip call
] [
drop consume/produce
] ifte ;
@ -73,8 +73,7 @@ USE: hashtables
dup "inline" word-property [
inline-compound
] [
dup infer-compound dup car rot dataflow-word,
consume/produce
dup infer-compound consume/produce dataflow-word,
] ifte ;
: current-word ( -- word )
@ -119,7 +118,6 @@ USE: hashtables
] ifte ;
: infer-call ( [ rstate | quot ] -- )
1 \ drop dataflow-word,
[
dataflow-graph off
pop-d uncons recursive-state set (infer)

15
library/test/dataflow.factor Normal file
View File

@ -0,0 +1,15 @@
IN: scratchpad
USE: inference
USE: lists
USE: math
USE: test
USE: logic
USE: combinators
[ t ] [ \ + [ 2 2 + ] dataflow tree-contains? >boolean ] unit-test
[ t ] [ 3 [ [ sq ] [ 3 + ] ifte ] dataflow tree-contains? >boolean ] unit-test
: inline-test
car car ; inline
[ t ] [ \ car [ inline-test ] dataflow tree-contains? >boolean ] unit-test

8
library/test/inference.factor
View File

@ -161,16 +161,16 @@ SYMBOL: sym-test
[ [ 1 | 2 ] ] [ [ uncons ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ unit ] infer ] unit-test
[ [ 1 | 2 ] ] [ [ unswons ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
! [ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ length ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ reverse ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ contains? ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ tree-contains? ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ remove ] infer ] unit-test
[ [ 1 | 1 ] ] [ [ prune ] infer ] unit-test
! [ [ 1 | 1 ] ] [ [ prune ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ bitor ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ bitand ] infer ] unit-test

5
library/test/vectors.factor
View File

@ -48,3 +48,8 @@ unit-test
[ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ]
[ { 1 2 3 4 } { 5 6 7 8 } vector-zip ]
unit-test
[ { } ] [ 0 { } vector-tail ] unit-test
[ { } ] [ 2 { 1 2 } vector-tail ] unit-test
[ { 3 4 } ] [ 2 { 1 2 3 4 } vector-tail ] unit-test
[ 2 { } vector-tail ] unit-test-fails

7
library/vectors.factor
View File

@ -113,3 +113,10 @@ DEFER: vector-map
0 swap 4 [
over ?vector-nth hashcode rot bitxor swap
] times* drop ;
: vector-tail ( n vector -- vector )
#! Return a new vector, with all elements from the nth
#! index upwards.
2dup vector-length swap - [
pick + over vector-nth
] vector-project nip nip ;

6
native/array.c
View File

@ -59,9 +59,3 @@ void collect_array(ARRAY* array)
for(i = 0; i < array->capacity; i++)
copy_object((void*)AREF(array,i));
}
/* copy an array to newspace */
ARRAY* copy_array(ARRAY* array)
{
return copy_untagged_object(array,ASIZE(array));
}

5
native/array.h
View File

@ -6,8 +6,8 @@ typedef struct {
INLINE ARRAY* untag_array(CELL tagged)
{
type_check(ARRAY_TYPE,tagged);
return (ARRAY*)UNTAG(tagged);
/* type_check(ARRAY_TYPE,tagged); */
return (ARRAY*)UNTAG(tagged); /* FIXME */
}
ARRAY* allot_array(CELL type, FIXNUM capacity);
@ -34,4 +34,3 @@ INLINE void set_array_nth(ARRAY* array, CELL index, CELL value)
void fixup_array(ARRAY* array);
void collect_array(ARRAY* array);
ARRAY* copy_array(ARRAY* array);

11
native/gc.c
View File

@ -10,15 +10,6 @@ INLINE void gc_debug(char* msg, CELL x) {
#endif
}
/* Given a pointer to oldspace, copy it to newspace. */
void* copy_untagged_object(void* pointer, CELL size)
{
void* newpointer = allot(size);
memcpy(newpointer,pointer,size);
return newpointer;
}
/*
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
@ -33,7 +24,7 @@ void copy_object(CELL* handle)
if(tag == FIXNUM_TYPE || pointer == F)
return;
if(in_zone(&active,pointer))
critical_error("copy_object given newspace ptr",pointer);

10
native/gc.h
View File

@ -2,7 +2,15 @@ CELL scan;
bool gc_in_progress;
long long gc_time;
void* copy_untagged_object(void* pointer, CELL size);
/* Given a pointer to oldspace, copy it to newspace. */
INLINE void* copy_untagged_object(void* pointer, CELL size)
{
void* newpointer = allot(size);
memcpy(newpointer,pointer,size);
return newpointer;
}
void copy_object(CELL* handle);
void collect_object(void);
void collect_next(void);

2
native/io.c
View File

@ -83,7 +83,7 @@ bool perform_copy_from_io_task(PORT* port, PORT* other_port)
if(can_write(other_port,port->buf_fill))
{
write_string_raw(other_port,
(BYTE*)(port->buffer + 1),
(BYTE*)(untag_string(port->buffer) + 1),
port->buf_fill);
port->buf_pos = port->buf_fill = 0;
}

11
native/port.c
View File

@ -19,7 +19,6 @@ PORT* port(PORT_MODE type, CELL fd)
port->type = type;
port->closed = false;
port->fd = fd;
port->buffer = NULL;
port->line = F;
port->client_host = F;
port->client_port = F;
@ -31,9 +30,9 @@ PORT* port(PORT_MODE type, CELL fd)
port->io_error = F;
if(type == PORT_SPECIAL)
port->buffer = NULL;
port->buffer = F;
else
port->buffer = string(BUF_SIZE,'\0');
port->buffer = tag_object(string(BUF_SIZE,'\0'));
if(fcntl(port->fd,F_SETFL,O_NONBLOCK,1) == -1)
io_error(__FUNCTION__);
@ -50,8 +49,7 @@ void init_line_buffer(PORT* port, FIXNUM count)
void fixup_port(PORT* port)
{
port->fd = -1;
if(port->buffer != 0)
port->buffer = fixup_untagged_string(port->buffer);
fixup(&port->buffer);
fixup(&port->line);
fixup(&port->client_host);
fixup(&port->client_port);
@ -60,8 +58,7 @@ void fixup_port(PORT* port)
void collect_port(PORT* port)
{
if(port->buffer != 0)
port->buffer = copy_untagged_string(port->buffer);
copy_object(&port->buffer);
copy_object(&port->line);
copy_object(&port->client_host);
copy_object(&port->client_port);

2
native/port.h
View File

@ -12,7 +12,7 @@ typedef struct {
PORT_MODE type;
bool closed;
FIXNUM fd;
STRING* buffer;
CELL buffer;
/* top of buffer */
CELL buf_fill;

19
native/read.c
View File

@ -4,21 +4,18 @@
bool read_step(PORT* port)
{
FIXNUM amount = 0;
STRING* buffer = untag_string(port->buffer);
CELL capacity = buffer->capacity;
if(port->type == PORT_RECV)
{
/* try reading OOB data. */
amount = recv(port->fd,
port->buffer + 1,
port->buffer->capacity * 2,
MSG_OOB);
amount = recv(port->fd,buffer + 1,capacity * CHARS,MSG_OOB);
}
if(amount <= 0)
{
amount = read(port->fd,
port->buffer + 1,
port->buffer->capacity * 2);
amount = read(port->fd,buffer + 1,capacity * CHARS);
}
if(amount < 0)
@ -45,16 +42,17 @@ bool read_line_step(PORT* port)
BYTE ch;
SBUF* line = untag_sbuf(port->line);
STRING* buffer = untag_string(port->buffer);
for(i = port->buf_pos; i < port->buf_fill; i++)
{
ch = bget((CELL)port->buffer + sizeof(STRING) + i);
ch = bget((CELL)buffer + sizeof(STRING) + i);
if(ch == '\r')
{
if(i != port->buf_fill - 1)
{
ch = bget((CELL)port->buffer
ch = bget((CELL)buffer
+ sizeof(STRING) + i + 1);
if(ch == '\n')
i++;
@ -169,10 +167,11 @@ bool read_count_step(PORT* port)
BYTE ch;
SBUF* line = untag_sbuf(port->line);
STRING* buffer = untag_string(port->buffer);
for(i = port->buf_pos; i < port->buf_fill; i++)
{
ch = bget((CELL)port->buffer + sizeof(STRING) + i);
ch = bget((CELL)buffer + sizeof(STRING) + i);
set_sbuf_nth(line,line->top,ch);
if(line->top == port->count)
{

37
native/sbuf.c
View File

@ -4,7 +4,7 @@ SBUF* sbuf(FIXNUM capacity)
{
SBUF* sbuf = allot_object(SBUF_TYPE,sizeof(SBUF));
sbuf->top = 0;
sbuf->string = string(capacity,'\0');
sbuf->string = tag_object(string(capacity,'\0'));
return sbuf;
}
@ -23,16 +23,18 @@ void primitive_set_sbuf_length(void)
{
SBUF* sbuf;
FIXNUM length;
STRING* str;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
str = untag_string(sbuf->string);
length = to_fixnum(dpop());
if(length < 0)
range_error(tag_object(sbuf),length,sbuf->top);
sbuf->top = length;
if(length > sbuf->string->capacity)
sbuf->string = grow_string(sbuf->string,length,F);
if(length > str->capacity)
sbuf->string = tag_object(grow_string(str,length,F));
}
void primitive_sbuf_nth(void)
@ -42,15 +44,15 @@ void primitive_sbuf_nth(void)
if(index < 0 || index >= sbuf->top)
range_error(tag_object(sbuf),index,sbuf->top);
dpush(string_nth(sbuf->string,index));
dpush(string_nth(untag_string(sbuf->string),index));
}
void sbuf_ensure_capacity(SBUF* sbuf, FIXNUM top)
{
STRING* string = sbuf->string;
STRING* string = untag_string(sbuf->string);
CELL capacity = string->capacity;
if(top >= capacity)
sbuf->string = grow_string(string,top * 2 + 1,F);
sbuf->string = tag_object(grow_string(string,top * 2 + 1,F));
sbuf->top = top;
}
@ -62,7 +64,7 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value)
sbuf_ensure_capacity(sbuf,index + 1);
/* the following does not check bounds! */
set_string_nth(sbuf->string,index,value);
set_string_nth(untag_string(sbuf->string),index,value);
}
void primitive_set_sbuf_nth(void)
@ -84,8 +86,10 @@ void sbuf_append_string(SBUF* sbuf, STRING* string)
{
CELL top = sbuf->top;
CELL strlen = string->capacity;
STRING* str;
sbuf_ensure_capacity(sbuf,top + strlen);
memcpy((void*)((CELL)sbuf->string + sizeof(STRING) + top * CHARS),
str = untag_string(sbuf->string);
memcpy((void*)((CELL)str + sizeof(STRING) + top * CHARS),
(void*)((CELL)string + sizeof(STRING)),strlen * CHARS);
}
@ -122,7 +126,7 @@ void primitive_sbuf_to_string(void)
maybe_garbage_collection();
sbuf = untag_sbuf(dpeek());
s = string_clone(sbuf->string,sbuf->top);
s = string_clone(untag_string(sbuf->string),sbuf->top);
rehash_string(s);
drepl(tag_object(s));
}
@ -130,7 +134,7 @@ void primitive_sbuf_to_string(void)
void primitive_sbuf_reverse(void)
{
SBUF* sbuf = untag_sbuf(dpop());
string_reverse(sbuf->string,sbuf->top);
string_reverse(untag_string(sbuf->string),sbuf->top);
}
void primitive_sbuf_clone(void)
@ -143,7 +147,7 @@ void primitive_sbuf_clone(void)
s = untag_sbuf(dpeek());
new_s = sbuf(s->top);
sbuf_append_string(new_s,s->string);
sbuf_append_string(new_s,untag_string(s->string));
drepl(tag_object(new_s));
}
@ -152,7 +156,10 @@ bool sbuf_eq(SBUF* s1, SBUF* s2)
if(s1 == s2)
return true;
else if(s1->top == s2->top)
return (string_compare_head(s1->string,s2->string,s1->top) == 0);
{
return (string_compare_head(untag_string(s1->string),
untag_string(s2->string),s1->top) == 0);
}
else
return false;
}
@ -170,15 +177,15 @@ void primitive_sbuf_eq(void)
void primitive_sbuf_hashcode(void)
{
SBUF* sbuf = untag_sbuf(dpop());
dpush(tag_fixnum(hash_string(sbuf->string,sbuf->top)));
dpush(tag_fixnum(hash_string(untag_string(sbuf->string),sbuf->top)));
}
void fixup_sbuf(SBUF* sbuf)
{
sbuf->string = fixup_untagged_string(sbuf->string);
fixup(&sbuf->string);
}
void collect_sbuf(SBUF* sbuf)
{
sbuf->string = copy_untagged_string(sbuf->string);
copy_object(&sbuf->string);
}

4
native/sbuf.h
View File

@ -3,8 +3,8 @@ typedef struct {
CELL header;
/* untagged */
CELL top;
/* untagged */
STRING* string;
/* tagged */
CELL string;
} SBUF;
INLINE SBUF* untag_sbuf(CELL tagged)

4
native/stack.c
View File

@ -98,7 +98,7 @@ VECTOR* stack_to_vector(CELL bottom, CELL top)
{
CELL depth = (top - bottom + CELLS) / CELLS;
VECTOR* v = vector(depth);
ARRAY* a = v->array;
ARRAY* a = untag_array(v->array);
memcpy(a + 1,(void*)bottom,depth * CELLS);
v->top = depth;
return v;
@ -121,7 +121,7 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom)
{
CELL start = bottom;
CELL len = vector->top * CELLS;
memcpy((void*)start,vector->array + 1,len);
memcpy((void*)start,untag_array(vector->array) + 1,len);
return start + len - CELLS;
}

10
native/string.c
View File

@ -330,13 +330,3 @@ void primitive_string_reverse(void)
rehash_string(s);
drepl(tag_object(s));
}
STRING* fixup_untagged_string(STRING* str)
{
return (STRING*)((CELL)str + (active.base - relocation_base));
}
STRING* copy_untagged_string(STRING* str)
{
return copy_untagged_object(str,SSIZE(str));
}

2
native/string.h
View File

@ -52,5 +52,3 @@ void primitive_substring(void);
void string_reverse(STRING* s, int len);
STRING* string_clone(STRING* s, int len);
void primitive_string_reverse(void);
STRING* fixup_untagged_string(STRING* str);
STRING* copy_untagged_string(STRING* str);

22
native/vector.c
View File

@ -4,7 +4,7 @@ VECTOR* vector(FIXNUM capacity)
{
VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(VECTOR));
vector->top = 0;
vector->array = array(capacity,F);
vector->array = tag_object(array(capacity,F));
return vector;
}
@ -23,16 +23,19 @@ void primitive_set_vector_length(void)
{
VECTOR* vector;
FIXNUM length;
ARRAY* array;
maybe_garbage_collection();
vector = untag_vector(dpop());
length = to_fixnum(dpop());
array = untag_array(vector->array);
if(length < 0)
range_error(tag_object(vector),length,vector->top);
vector->top = length;
if(length > vector->array->capacity)
vector->array = grow_array(vector->array,length,F);
if(length > array->capacity)
vector->array = tag_object(grow_array(array,length,F));
}
void primitive_vector_nth(void)
@ -42,17 +45,17 @@ void primitive_vector_nth(void)
if(index < 0 || index >= vector->top)
range_error(tag_object(vector),index,vector->top);
dpush(array_nth(vector->array,index));
dpush(array_nth(untag_array(vector->array),index));
}
void vector_ensure_capacity(VECTOR* vector, CELL index)
{
ARRAY* array = vector->array;
ARRAY* array = untag_array(vector->array);
CELL capacity = array->capacity;
if(index >= capacity)
array = grow_array(array,index * 2 + 1,F);
vector->top = index + 1;
vector->array = array;
vector->array = tag_object(array);
}
void primitive_set_vector_nth(void)
@ -73,16 +76,15 @@ void primitive_set_vector_nth(void)
vector_ensure_capacity(vector,index);
/* the following does not check bounds! */
set_array_nth(vector->array,index,value);
set_array_nth(untag_array(vector->array),index,value);
}
void fixup_vector(VECTOR* vector)
{
vector->array = (ARRAY*)((CELL)vector->array
+ (active.base - relocation_base));
fixup(&vector->array);
}
void collect_vector(VECTOR* vector)
{
vector->array = copy_array(vector->array);
copy_object(&vector->array);
}

4
native/vector.h
View File

@ -3,8 +3,8 @@ typedef struct {
CELL header;
/* untagged */
CELL top;
/* untagged */
ARRAY* array;
/* tagged */
CELL array;
} VECTOR;
INLINE VECTOR* untag_vector(CELL tagged)

10
native/write.c
View File

@ -3,7 +3,7 @@
/* Return true if write was done */
void write_step(PORT* port)
{
BYTE* chars = (BYTE*)port->buffer + sizeof(STRING);
BYTE* chars = (BYTE*)untag_string(port->buffer) + sizeof(STRING);
FIXNUM amount = write(port->fd,chars + port->buf_pos,
port->buf_fill - port->buf_pos);
@ -24,12 +24,12 @@ bool can_write(PORT* port, FIXNUM len)
if(port->type != PORT_WRITE)
general_error(ERROR_INCOMPATIBLE_PORT,tag_object(port));
buf_capacity = port->buffer->capacity * CHARS;
buf_capacity = untag_string(port->buffer)->capacity * CHARS;
/* Is the string longer than the buffer? */
if(port->buf_fill == 0 && len > buf_capacity)
{
/* Increase the buffer to fit the string */
port->buffer = allot_string(len / CHARS + 1);
port->buffer = tag_object(allot_string(len / CHARS + 1));
return true;
}
else
@ -86,7 +86,7 @@ void write_char_8(PORT* port, FIXNUM ch)
if(!can_write(port,1))
io_error(__FUNCTION__);
bput((CELL)port->buffer + sizeof(STRING) + port->buf_fill,c);
bput((CELL)untag_string(port->buffer) + sizeof(STRING) + port->buf_fill,c);
port->buf_fill++;
}
@ -94,7 +94,7 @@ void write_char_8(PORT* port, FIXNUM ch)
void write_string_raw(PORT* port, BYTE* str, CELL len)
{
/* Append string to buffer */
memcpy((void*)((CELL)port->buffer + sizeof(STRING)
memcpy((void*)((CELL)untag_string(port->buffer) + sizeof(STRING)
+ port->buf_fill),str,len);
port->buf_fill += len;