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

memory management change, allocating primitives call gc directly

cvs
Slava Pestov 2004-10-13 03:49:43 +00:00
parent 9c2166b0be
commit be8eb34102
31 changed files with 351 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Makefile
View File

@ -1,5 +1,5 @@
CC = gcc
DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer
DEFAULT_CFLAGS = -Os -Wall -export-dynamic -fomit-frame-pointer $(SITE_CFLAGS)
DEFAULT_LIBS = -lm
STRIP = strip
@ -22,6 +22,7 @@ default:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "bsd"
@echo "bsd-nopthread - on FreeBSD 4, if you want to use profiling"
@echo "linux"
@echo "solaris"
@echo ""
@ -36,6 +37,11 @@ bsd:
CFLAGS="$(DEFAULT_CFLAGS) -DFFI -pthread" \
LIBS="$(DEFAULT_LIBS)"
bsd-nopthread:
$(MAKE) f \
CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
LIBS="$(DEFAULT_LIBS)"
linux:
$(MAKE) f \
CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \

2
library/cross-compiler.factor
View File

@ -74,7 +74,6 @@ DEFER: os-env
DEFER: type
DEFER: size
DEFER: address
DEFER: dump
DEFER: heap-stats
IN: strings
@ -357,7 +356,6 @@ IN: image
(random-int)
type
size
dump
cwd
cd
compiled-offset

1
library/platform/native/primitives.factor
View File

@ -209,7 +209,6 @@ USE: words
[ allot-profiling | " depth -- " ]
[ allot-count | " word -- n " ]
[ set-allot-count | " n word -- n " ]
[ dump | " obj -- " ]
[ cwd | " -- dir " ]
[ cd | " dir -- " ]
[ compiled-offset | " -- ptr " ]

31
library/platform/native/profiler.factor
View File

@ -36,8 +36,9 @@ USE: stack
USE: words
USE: vectors
! The variable "profile-top-only" toggles between
! The variable "only-top" toggles between
! culminative counts, and top of call stack counts.
SYMBOL: only-top
: reset-counts ( -- )
[ 0 over set-call-count 0 swap set-allot-count ] each-word ;
@ -47,11 +48,7 @@ USE: vectors
: call-count, ( word -- )
#! Add to constructing list if call count is non-zero.
dup call-count dup 0 = [
2drop
] [
cons ,
] ifte ;
dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
: counts. ( alist -- )
sort-counts [ . ] each ;
@ -61,27 +58,21 @@ USE: vectors
[, [ call-count, ] each-word ,] counts. ;
: profile-depth ( -- n )
"profile-top-only" get [
-1
] [
callstack vector-length
] ifte ;
only-top get [ -1 ] [ callstack vector-length ] ifte ;
: call-profile ( quot -- )
#! Execute a quotation with the CPU profiler enabled.
: (call-profile) ( quot -- )
reset-counts
profile-depth call-profiling
call
f call-profiling
call-counts. ;
f call-profiling ;
: call-profile ( quot -- )
#! Execute a quotation with the CPU profiler enabled.
(call-profile) call-counts. ;
: allot-count, ( word -- )
#! Add to constructing list if allot count is non-zero.
dup allot-count dup 0 = [
2drop
] [
cons ,
] ifte ;
dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
: allot-counts. ( -- alist )
#! Print word/allot count pairs.

39
library/test/math/irrational.factor
View File

@ -2,24 +2,29 @@ IN: scratchpad
USE: kernel
USE: math
USE: test
USE: real-math
[ 4.0 ] [ 16 ] [ sqrt ] test-word
[ #{ 0 4.0 } ] [ -16 ] [ sqrt ] test-word
! Lets get the argument order correct, eh?
[ 0.0 ] [ 0 1 fatan2 ] unit-test
[ 0.25 ] [ 2 -2 fpow ] unit-test
[ 4.0 ] [ 2 2 ] [ ^ ] test-word
[ 0.25 ] [ 2 -2 ] [ ^ ] test-word
[ t ] [ 2 0.5 ^ 2 ^ ] [ 2 2.00001 between? ] test-word
[ t ] [ e pi i * ^ real ] [ -1.0 = ] test-word
[ t ] [ e pi i * ^ imaginary ] [ -0.00001 0.00001 between? ] test-word
[ 4.0 ] [ 16 sqrt ] unit-test
[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test
[ 1.0 ] [ 0 ] [ cosh ] test-word
[ 0.0 ] [ 1 ] [ acosh ] test-word
[ 4.0 ] [ 2 2 ^ ] unit-test
[ 0.25 ] [ 2 -2 ^ ] unit-test
[ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
[ t ] [ e pi i * ^ real -1.0 = ] unit-test
[ t ] [ e pi i * ^ imaginary -0.00001 0.00001 between? ] unit-test
[ 1.0 ] [ 0 ] [ cos ] test-word
[ 0.0 ] [ 1 ] [ acos ] test-word
[ 0.0 ] [ 0 ] [ sinh ] test-word
[ 0.0 ] [ 0 ] [ asinh ] test-word
[ 0.0 ] [ 0 ] [ sin ] test-word
[ 0.0 ] [ 0 ] [ asin ] test-word
[ 1.0 ] [ 0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
[ 1.0 ] [ 0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
[ 0.0 ] [ 0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test

45
native/bignum.c
View File

@ -55,6 +55,7 @@ ARRAY* to_bignum(CELL tagged)
void primitive_to_bignum(void)
{
maybe_garbage_collection();
drepl(tag_object(to_bignum(dpeek())));
}
@ -65,38 +66,39 @@ void primitive_bignum_eq(void)
dpush(tag_boolean(s48_bignum_equal_p(x,y)));
}
#define GC_AND_POP_BIGNUMS(x,y) \
ARRAY *x, *y; \
maybe_garbage_collection(); \
y = to_bignum(dpop()); \
x = to_bignum(dpop());
void primitive_bignum_add(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_add(x,y)));
}
void primitive_bignum_subtract(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_subtract(x,y)));
}
void primitive_bignum_multiply(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_multiply(x,y)));
}
void primitive_bignum_divint(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_quotient(x,y)));
}
void primitive_bignum_divfloat(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(make_float(
s48_bignum_to_double(x) /
s48_bignum_to_double(y))));
@ -104,9 +106,8 @@ void primitive_bignum_divfloat(void)
void primitive_bignum_divmod(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
ARRAY *q, *r;
GC_AND_POP_BIGNUMS(x,y);
s48_bignum_divide(x,y,&q,&r);
dpush(tag_object(q));
dpush(tag_object(r));
@ -114,36 +115,35 @@ void primitive_bignum_divmod(void)
void primitive_bignum_mod(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_remainder(x,y)));
}
void primitive_bignum_and(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_and(x,y)));
}
void primitive_bignum_or(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_ior(x,y)));
}
void primitive_bignum_xor(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_xor(x,y)));
}
void primitive_bignum_shift(void)
{
FIXNUM y = to_fixnum(dpop());
ARRAY* x = to_bignum(dpop());
FIXNUM y;
ARRAY* x;
maybe_garbage_collection();
y = to_fixnum(dpop());
x = to_bignum(dpop());
dpush(tag_object(s48_bignum_arithmetic_shift(x,y)));
}
@ -207,6 +207,7 @@ void primitive_bignum_greatereq(void)
void primitive_bignum_not(void)
{
maybe_garbage_collection();
drepl(tag_object(s48_bignum_bitwise_not(
untag_bignum(dpeek()))));
}

8
native/complex.c
View File

@ -62,8 +62,12 @@ void primitive_to_rect(void)
void primitive_from_rect(void)
{
CELL imaginary = dpop();
CELL real = dpop();
CELL imaginary, real;
maybe_garbage_collection();
imaginary = dpop();
real = dpop();
if(!realp(imaginary))
type_error(REAL_TYPE,imaginary);

6
native/cons.c
View File

@ -10,8 +10,10 @@ CELL cons(CELL car, CELL cdr)
void primitive_cons(void)
{
CELL cdr = dpop();
CELL car = dpop();
CELL car, cdr;
maybe_garbage_collection();
cdr = dpop();
car = dpop();
dpush(cons(car,cdr));
}

4
native/error.c
View File

@ -69,8 +69,8 @@ void type_error(CELL type, CELL tagged)
general_error(ERROR_TYPE,c);
}
void range_error(CELL tagged, CELL index, CELL max)
void range_error(CELL tagged, FIXNUM index, CELL max)
{
CELL c = cons(tagged,cons(tag_fixnum(index),cons(tag_fixnum(max),F)));
CELL c = cons(tagged,cons(tag_integer(index),cons(tag_cell(max),F)));
general_error(ERROR_RANGE,c);
}

2
native/error.h
View File

@ -21,4 +21,4 @@ void throw_error(CELL object);
void general_error(CELL error, CELL tagged);
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
void range_error(CELL tagged, CELL index, CELL max);
void range_error(CELL tagged, FIXNUM index, CELL max);

7
native/factor.h
View File

@ -33,6 +33,11 @@
typedef unsigned long int CELL;
#define CELLS ((signed)sizeof(CELL))
#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
#define FIXNUM long int /* unboxed */
#define WORD_SIZE (CELLS*8)
#define HALF_WORD_SIZE (CELLS*4)
#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
@ -46,7 +51,7 @@ typedef unsigned char BYTE;
/* Memory heap size */
#define DEFAULT_ARENA (64 * 1024 * 1024)
#define COMPILE_ZONE_SIZE (5 * 1024 * 1024)
#define COMPILE_ZONE_SIZE (4 * 1024 * 1024)
#define STACK_SIZE 16384

20
native/ffi.c
View File

@ -12,9 +12,14 @@ DLL* untag_dll(CELL tagged)
void primitive_dlopen(void)
{
#ifdef FFI
char* path = unbox_c_string();
void* dllptr = dlopen(path,RTLD_LAZY);
char* path;
void* dllptr;
DLL* dll;
maybe_garbage_collection();
path = unbox_c_string();
dllptr = dlopen(path,RTLD_LAZY);
if(dllptr == NULL)
{
@ -81,7 +86,9 @@ void primitive_alien(void)
#ifdef FFI
CELL length = unbox_integer();
CELL ptr = unbox_integer();
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
ALIEN* alien;
maybe_garbage_collection();
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
alien->ptr = ptr;
alien->length = length;
alien->local = false;
@ -95,8 +102,11 @@ void primitive_local_alien(void)
{
#ifdef FFI
CELL length = unbox_integer();
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
STRING* local = string(length / CHARS,'\0');
ALIEN* alien;
STRING* local;
maybe_garbage_collection();
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
local = string(length / CHARS,'\0');
alien->ptr = (CELL)local + sizeof(STRING);
alien->length = length;
alien->local = true;

29
native/file.c
View File

@ -4,9 +4,13 @@ void primitive_open_file(void)
{
bool write = untag_boolean(dpop());
bool read = untag_boolean(dpop());
char* path = unbox_c_string();
int mode;
int fd;
char* path;
int mode, fd;
maybe_garbage_collection();
path = unbox_c_string();
if(read && write)
mode = O_RDWR | O_CREAT;
@ -28,7 +32,11 @@ void primitive_open_file(void)
void primitive_stat(void)
{
struct stat sb;
STRING* path = untag_string(dpop());
STRING* path;
maybe_garbage_collection();
path = untag_string(dpop());
if(stat(to_c_string(path),&sb) < 0)
dpush(F);
else
@ -50,14 +58,19 @@ void primitive_stat(void)
void primitive_read_dir(void)
{
STRING* path = untag_string(dpop());
DIR* dir = opendir(to_c_string(path));
STRING* path;
DIR* dir;
CELL result = F;
maybe_garbage_collection();
path = untag_string(dpop());
dir = opendir(to_c_string(path));
if(dir != NULL)
{
struct dirent* file;
while(file = readdir(dir))
while((file = readdir(dir)) != NULL)
{
CELL name = tag_object(from_c_string(
file->d_name));
@ -73,6 +86,7 @@ void primitive_read_dir(void)
void primitive_cwd(void)
{
char wd[MAXPATHLEN];
maybe_garbage_collection();
if(getcwd(wd,MAXPATHLEN) < 0)
io_error(__FUNCTION__);
box_c_string(wd);
@ -80,5 +94,6 @@ void primitive_cwd(void)
void primitive_cd(void)
{
maybe_garbage_collection();
chdir(unbox_c_string());
}

5
native/fixnum.h
View File

@ -1,8 +1,3 @@
#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
#define FIXNUM long int /* unboxed */
INLINE FIXNUM untag_fixnum_fast(CELL tagged)
{
return ((FIXNUM)tagged) >> TAG_BITS;

68
native/float.c
View File

@ -27,15 +27,22 @@ double to_float(CELL tagged)
void primitive_to_float(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(to_float(dpeek()))));
}
void primitive_str_to_float(void)
{
STRING* str = untag_string(dpeek());
char* c_str = to_c_string(str);
char* end = c_str;
double f = strtod(c_str,&end);
STRING* str;
char *c_str, *end;
double f;
maybe_garbage_collection();
str = untag_string(dpeek());
c_str = to_c_string(str);
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + str->capacity)
general_error(ERROR_FLOAT_FORMAT,tag_object(str));
drepl(tag_object(make_float(f)));
@ -44,6 +51,9 @@ void primitive_str_to_float(void)
void primitive_float_to_str(void)
{
char tmp[33];
maybe_garbage_collection();
snprintf(tmp,32,"%.16g",to_float(dpop()));
tmp[32] = '\0';
box_c_string(tmp);
@ -51,43 +61,49 @@ void primitive_float_to_str(void)
void primitive_float_to_bits(void)
{
double f = untag_float(dpeek());
long long f_raw = *(long long*)&f;
double f;
long long f_raw;
maybe_garbage_collection();
f = untag_float(dpeek());
f_raw = *(long long*)&f;
drepl(tag_object(s48_long_long_to_bignum(f_raw)));
}
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_garbage_collection(); \
y = to_float(dpop()); \
x = to_float(dpop());
void primitive_float_eq(void)
{
double y = to_float(dpop());
double x = to_float(dpop());
GC_AND_POP_FLOATS(x,y);
dpush(tag_boolean(x == y));
}
void primitive_float_add(void)
{
double y = to_float(dpop());
double x = to_float(dpop());
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x + y)));
}
void primitive_float_subtract(void)
{
double y = to_float(dpop());
double x = to_float(dpop());
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x - y)));
}
void primitive_float_multiply(void)
{
double y = to_float(dpop());
double x = to_float(dpop());
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x * y)));
}
void primitive_float_divfloat(void)
{
double y = to_float(dpop());
double x = to_float(dpop());
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x / y)));
}
@ -121,64 +137,72 @@ void primitive_float_greatereq(void)
void primitive_facos(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(acos(to_float(dpeek())))));
}
void primitive_fasin(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(asin(to_float(dpeek())))));
}
void primitive_fatan(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(atan(to_float(dpeek())))));
}
void primitive_fatan2(void)
{
double x = to_float(dpop());
double y = to_float(dpop());
dpush(tag_object(make_float(atan2(y,x))));
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(atan2(x,y))));
}
void primitive_fcos(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(cos(to_float(dpeek())))));
}
void primitive_fexp(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(exp(to_float(dpeek())))));
}
void primitive_fcosh(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(cosh(to_float(dpeek())))));
}
void primitive_flog(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(log(to_float(dpeek())))));
}
void primitive_fpow(void)
{
double x = to_float(dpop());
double y = to_float(dpop());
dpush(tag_object(make_float(pow(y,x))));
GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(pow(x,y))));
}
void primitive_fsin(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(sin(to_float(dpeek())))));
}
void primitive_fsinh(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(sinh(to_float(dpeek())))));
}
void primitive_fsqrt(void)
{
maybe_garbage_collection();
drepl(tag_object(make_float(sqrt(to_float(dpeek())))));
}

21
native/gc.c
View File

@ -132,6 +132,7 @@ void collect_roots(void)
void primitive_gc(void)
{
fprintf(stderr,"GC!\n");
gc_in_progress = true;
flip_zones();
@ -149,3 +150,23 @@ void primitive_gc(void)
gc_in_progress = false;
}
/* WARNING: only call this from a context where all local variables
are also reachable via the GC roots. */
void maybe_garbage_collection(void)
{
if(active.here > active.alarm)
{
if(active.here > active.limit)
{
fprintf(stderr,"Out of memory\n");
fprintf(stderr,"active.base = %ld\n",active.base);
fprintf(stderr,"active.here = %ld\n",active.here);
fprintf(stderr,"active.limit = %ld\n",active.limit);
fflush(stderr);
exit(1);
}
else
primitive_gc();
}
}

1
native/gc.h
View File

@ -7,3 +7,4 @@ void collect_object(void);
void collect_next(void);
void collect_roots(void);
void primitive_gc(void);
void maybe_garbage_collection(void);

20
native/memory.c
View File

@ -36,7 +36,6 @@ void init_arena(CELL size)
init_zone(&prior,size);
allot_profiling = false;
gc_in_progress = false;
gc_protect = false;
}
void allot_profile_step(CELL a)
@ -58,25 +57,6 @@ void allot_profile_step(CELL a)
executing->allot_count += a;
}
void garbage_collection_later(void)
{
if(gc_protect)
return;
if(active.here > active.limit)
{
fprintf(stderr,"Out of memory\n");
fprintf(stderr,"active.base = %ld\n",active.base);
fprintf(stderr,"active.here = %ld\n",active.here);
fprintf(stderr,"active.limit = %ld\n",active.limit);
fflush(stderr);
exit(1);
}
/* Execute the 'garbage-collection' word */
call(userenv[GC_ENV]);
}
void flip_zones()
{
ZONE z = active;

6
native/memory.h
View File

@ -10,15 +10,11 @@ ZONE prior;
bool allot_profiling;
/* we can temporarily disable GC */
bool gc_protect;
void* alloc_guarded(CELL size);
void init_zone(ZONE* zone, CELL size);
void init_arena(CELL size);
void flip_zones();
void garbage_collection_later(void);
void allot_profile_step(CELL a);
INLINE CELL align8(CELL a)
@ -32,8 +28,6 @@ INLINE void* allot(CELL a)
active.here += align8(a);
if(allot_profiling)
allot_profile_step(align8(a));
if(active.here > active.alarm)
garbage_collection_later();
return (void*)h;
}

20
native/misc.c
View File

@ -7,8 +7,12 @@ void primitive_exit(void)
void primitive_os_env(void)
{
char* name = unbox_c_string();
char* value = getenv(name);
char *name, *value;
maybe_garbage_collection();
name = unbox_c_string();
value = getenv(name);
if(value == NULL)
dpush(F);
else
@ -24,6 +28,7 @@ void primitive_millis(void)
{
struct timeval t;
gettimeofday(&t,NULL);
maybe_garbage_collection();
dpush(tag_object(s48_long_long_to_bignum(
(long long)t.tv_sec * 1000 + t.tv_usec/1000)));
}
@ -41,15 +46,6 @@ void primitive_init_random(void)
void primitive_random_int(void)
{
maybe_garbage_collection();
dpush(tag_object(s48_long_to_bignum(random())));
}
void primitive_dump(void)
{
/* Take an object, and print its memory. Later, return a vector */
CELL obj = dpop();
CELL size = object_size(obj);
int i;
for(i = 0; i < size; i += CELLS)
fprintf(stderr,"%lx\n",get(UNTAG(obj) + i));
}

1
native/misc.h
View File

@ -4,4 +4,3 @@ void primitive_eq(void);
void primitive_millis(void);
void primitive_init_random(void);
void primitive_random_int(void);
void primitive_dump(void);

1
native/primitives.c
View File

@ -169,7 +169,6 @@ XT primitives[] = {
primitive_random_int,
primitive_type,
primitive_size,
primitive_dump,
primitive_cwd,
primitive_cd,
primitive_compiled_offset,

8
native/ratio.c
View File

@ -4,8 +4,12 @@
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
CELL denominator = dpop();
CELL numerator = dpop();
CELL numerator, denominator;
maybe_garbage_collection();
denominator = dpop();
numerator = dpop();
if(zerop(denominator))
raise(SIGFPE);
if(onep(denominator))

44
native/read.c
View File

@ -107,8 +107,12 @@ void primitive_can_read_line(void)
void primitive_add_read_line_io_task(void)
{
CELL callback = dpop();
CELL port = dpop();
CELL callback, port;
maybe_garbage_collection();
callback = dpop();
port = dpop();
add_io_task(IO_TASK_READ_LINE,port,F,callback,
read_io_tasks,&read_fd_count);
@ -140,7 +144,11 @@ bool perform_read_line_io_task(PORT* port)
void primitive_read_line_8(void)
{
PORT* port = untag_port(dpeek());
PORT* port;
maybe_garbage_collection();
port = untag_port(dpeek());
pending_io_error(port);
@ -199,16 +207,27 @@ bool can_read_count(PORT* port, FIXNUM count)
void primitive_can_read_count(void)
{
PORT* port = untag_port(dpop());
FIXNUM len = to_fixnum(dpop());
PORT* port;
FIXNUM len;
maybe_garbage_collection();
port = untag_port(dpop());
len = to_fixnum(dpop());
dpush(tag_boolean(can_read_count(port,len)));
}
void primitive_add_read_count_io_task(void)
{
CELL callback = dpop();
PORT* port = untag_port(dpop());
FIXNUM count = to_fixnum(dpop());
CELL callback;
PORT* port;
FIXNUM count;
maybe_garbage_collection();
callback = dpop();
port = untag_port(dpop());
count = to_fixnum(dpop());
add_io_task(IO_TASK_READ_COUNT,
tag_object(port),F,callback,
read_io_tasks,&read_fd_count);
@ -233,8 +252,13 @@ bool perform_read_count_io_task(PORT* port)
void primitive_read_count_8(void)
{
PORT* port = untag_port(dpop());
FIXNUM len = to_fixnum(dpop());
PORT* port;
FIXNUM len;
maybe_garbage_collection();
port = untag_port(dpop());
len = to_fixnum(dpop());
if(port->count != len)
critical_error("read# counts don't match",tag_object(port));

51
native/sbuf.c
View File

@ -10,6 +10,7 @@ SBUF* sbuf(FIXNUM capacity)
void primitive_sbuf(void)
{
maybe_garbage_collection();
drepl(tag_object(sbuf(to_fixnum(dpeek()))));
}
@ -20,8 +21,13 @@ void primitive_sbuf_length(void)
void primitive_set_sbuf_length(void)
{
SBUF* sbuf = untag_sbuf(dpop());
FIXNUM length = to_fixnum(dpop());
SBUF* sbuf;
FIXNUM length;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
length = to_fixnum(dpop());
if(length < 0)
range_error(tag_object(sbuf),length,sbuf->top);
sbuf->top = length;
@ -61,9 +67,15 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value)
void primitive_set_sbuf_nth(void)
{
SBUF* sbuf = untag_sbuf(dpop());
FIXNUM index = to_fixnum(dpop());
CELL value = dpop();
SBUF* sbuf;
FIXNUM index;
CELL value;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
index = to_fixnum(dpop());
value = dpop();
set_sbuf_nth(sbuf,index,value);
}
@ -79,8 +91,14 @@ void sbuf_append_string(SBUF* sbuf, STRING* string)
void primitive_sbuf_append(void)
{
SBUF* sbuf = untag_sbuf(dpop());
CELL object = dpop();
SBUF* sbuf;
CELL object;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
object = dpop();
switch(type_of(object))
{
case FIXNUM_TYPE:
@ -98,8 +116,13 @@ void primitive_sbuf_append(void)
void primitive_sbuf_to_string(void)
{
SBUF* sbuf = untag_sbuf(dpeek());
STRING* s = string_clone(sbuf->string,sbuf->top);
SBUF* sbuf;
STRING* s;
maybe_garbage_collection();
sbuf = untag_sbuf(dpeek());
s = string_clone(sbuf->string,sbuf->top);
rehash_string(s);
drepl(tag_object(s));
}
@ -112,8 +135,14 @@ void primitive_sbuf_reverse(void)
void primitive_sbuf_clone(void)
{
SBUF* s = untag_sbuf(dpeek());
SBUF* new_s = sbuf(s->top);
SBUF* s;
SBUF* new_s;
maybe_garbage_collection();
s = untag_sbuf(dpeek());
new_s = sbuf(s->top);
sbuf_append_string(new_s,s->string);
drepl(tag_object(new_s));
}

21
native/socket.c
View File

@ -45,8 +45,14 @@ int make_client_socket(const char* hostname, uint16_t port)
void primitive_client_socket(void)
{
uint16_t p = (uint16_t)to_fixnum(dpop());
char* host = unbox_c_string();
int sock = make_client_socket(host,p);
char* host;
int sock;
maybe_garbage_collection();
host = unbox_c_string();
sock = make_client_socket(host,p);
dpush(tag_object(port(PORT_RECV,sock)));
dpush(tag_object(port(PORT_WRITE,sock)));
}
@ -91,13 +97,16 @@ int make_server_socket(uint16_t port)
void primitive_server_socket(void)
{
uint16_t p = (uint16_t)to_fixnum(dpop());
maybe_garbage_collection();
dpush(tag_object(port(PORT_SPECIAL,make_server_socket(p))));
}
void primitive_add_accept_io_task(void)
{
CELL callback = dpop();
CELL port = dpop();
CELL callback, port;
maybe_garbage_collection();
callback = dpop();
port = dpop();
add_io_task(IO_TASK_ACCEPT,port,F,callback,
read_io_tasks,&read_fd_count);
}
@ -131,7 +140,9 @@ CELL accept_connection(PORT* p)
void primitive_accept_fd(void)
{
PORT* p = untag_port(dpop());
PORT* p;
maybe_garbage_collection();
p = untag_port(dpop());
dpush(p->client_host);
dpush(p->client_port);
dpush(tag_object(port(PORT_RECV,p->client_socket)));

5
native/stack.c
View File

@ -94,15 +94,14 @@ VECTOR* stack_to_vector(CELL bottom, CELL top)
void primitive_datastack(void)
{
maybe_garbage_collection();
dpush(tag_object(stack_to_vector(ds_bot,ds)));
}
void primitive_callstack(void)
{
/* we don't want gc word to end up on callstack. */
gc_protect = true;
maybe_garbage_collection();
dpush(tag_object(stack_to_vector(cs_bot,cs)));
gc_protect = false;
}
/* Returns top of stack */

17
native/string.c
View File

@ -274,9 +274,14 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
/* start end string -- string */
void primitive_substring(void)
{
STRING* string = untag_string(dpop());
CELL end = to_fixnum(dpop());
CELL start = to_fixnum(dpop());
STRING* string;
CELL end, start;
maybe_garbage_collection();
string = untag_string(dpop());
end = to_fixnum(dpop());
start = to_fixnum(dpop());
dpush(tag_object(substring(start,end,string)));
}
@ -305,7 +310,11 @@ STRING* string_clone(STRING* s, int len)
void primitive_string_reverse(void)
{
STRING* s = untag_string(dpeek());
STRING* s;
maybe_garbage_collection();
s = untag_string(dpeek());
s = string_clone(s,s->capacity);
string_reverse(s,s->capacity);
rehash_string(s);

22
native/vector.c
View File

@ -10,6 +10,7 @@ VECTOR* vector(FIXNUM capacity)
void primitive_vector(void)
{
maybe_garbage_collection();
drepl(tag_object(vector(to_fixnum(dpeek()))));
}
@ -20,8 +21,13 @@ void primitive_vector_length(void)
void primitive_set_vector_length(void)
{
VECTOR* vector = untag_vector(dpop());
FIXNUM length = to_fixnum(dpop());
VECTOR* vector;
FIXNUM length;
maybe_garbage_collection();
vector = untag_vector(dpop());
length = to_fixnum(dpop());
if(length < 0)
range_error(tag_object(vector),length,vector->top);
vector->top = length;
@ -51,9 +57,15 @@ void vector_ensure_capacity(VECTOR* vector, CELL index)
void primitive_set_vector_nth(void)
{
VECTOR* vector = untag_vector(dpop());
FIXNUM index = to_fixnum(dpop());
CELL value = dpop();
VECTOR* vector;
FIXNUM index;
CELL value;
maybe_garbage_collection();
vector = untag_vector(dpop());
index = to_fixnum(dpop());
value = dpop();
if(index < 0)
range_error(tag_object(vector),index,vector->top);

8
native/word.c
View File

@ -25,9 +25,13 @@ void update_xt(WORD* word)
/* <word> ( primitive parameter plist -- word ) */
void primitive_word(void)
{
CELL plist = dpop();
CELL plist, parameter;
FIXNUM primitive;
CELL parameter = dpop();
maybe_garbage_collection();
plist = dpop();
parameter = dpop();
primitive = to_fixnum(dpop());
dpush(tag_word(word(primitive,parameter,plist)));
}

30
native/write.c
View File

@ -38,16 +38,25 @@ bool can_write(PORT* port, FIXNUM len)
void primitive_can_write(void)
{
PORT* port = untag_port(dpop());
FIXNUM len = to_fixnum(dpop());
PORT* port;
FIXNUM len;
maybe_garbage_collection();
port = untag_port(dpop());
len = to_fixnum(dpop());
pending_io_error(port);
dpush(tag_boolean(can_write(port,len)));
}
void primitive_add_write_io_task(void)
{
CELL callback = dpop();
CELL port = dpop();
CELL callback, port;
maybe_garbage_collection();
callback = dpop();
port = dpop();
add_io_task(IO_TASK_WRITE,port,F,callback,
write_io_tasks,&write_fd_count);
}
@ -107,12 +116,17 @@ void write_string_8(PORT* port, STRING* str)
void primitive_write_8(void)
{
PORT* port = untag_port(dpop());
CELL text = dpop();
CELL type = type_of(text);
PORT* port;
CELL text, type;
STRING* str;
maybe_garbage_collection();
port = untag_port(dpop());
text = dpop();
type = type_of(text);
pending_io_error(port);
switch(type)