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

More allot_* cleanups

slava 2006-11-02 23:29:11 +00:00
parent 372872e41d
commit 56f8f84751
26 changed files with 285 additions and 314 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO.FACTOR.txt
View File

@ -1,13 +1,8 @@
+ allot refactoring: + allot refactoring:
- bignum operations
- rethink all string conversions
- os-windows.c error_message &co - os-windows.c error_message &co
- inline float allocation needs a gc check - inline float allocation needs a gc check
- alien invoke, callback need a gc check - alien invoke, callback need a gc check
- relocation should not cons at all
- ffi_dlopen, etc
- throwing an error can fill up the extra_roots stack
- last-index miscompiles - last-index miscompiles
+ ui: + ui:

4
library/compiler/generator/xt.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: compiler IN: compiler
USING: arrays assembler errors generic hashtables kernel USING: alien arrays assembler errors generic hashtables kernel
kernel-internals math namespaces prettyprint queues kernel-internals math namespaces prettyprint queues
sequences strings vectors words ; sequences strings vectors words ;
@ -60,7 +60,7 @@ SYMBOL: label-table
compiled-offset (rel) relocation-table get swap nappend ; compiled-offset (rel) relocation-table get swap nappend ;
: rel-dlsym ( name dll class -- ) : rel-dlsym ( name dll class -- )
>r 2array add-literal r> 1 rel, ; >r >r string>char-alien r> 2array add-literal r> 1 rel, ;
: rel-here ( class -- ) : rel-here ( class -- )
dup rel-relative = [ drop ] [ 0 swap 2 rel, ] if ; dup rel-relative = [ drop ] [ 0 swap 2 rel, ] if ;

4
library/compiler/test/alien.factor
View File

@ -78,11 +78,11 @@ cpu "x86" = macosx? and [
: indirect-test-1 : indirect-test-1
"int" { } "cdecl" alien-indirect ; "int" { } "cdecl" alien-indirect ;
[ 3 ] [ "ffi_test_1" f dlsym <alien> indirect-test-1 ] unit-test [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
: indirect-test-2 : indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect ; "int" { "int" "int" } "cdecl" alien-indirect ;
[ 5 ] [ 5 ]
[ 2 3 "ffi_test_2" f dlsym <alien> indirect-test-2 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test unit-test

8
library/test/kernel.factor
View File

@ -1,6 +1,6 @@
IN: scratchpad IN: scratchpad
USING: kernel kernel-internals math memory namespaces sequences USING: arrays kernel kernel-internals math memory namespaces
test errors math-internals ; sequences test errors math-internals ;
[ 0 ] [ f size ] unit-test [ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test
@ -8,8 +8,8 @@ test errors math-internals ;
! some primitives are missing GC checks ! some primitives are missing GC checks
[ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test [ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test
! [ ] [ 1.0 10000000 [ drop 1.0 * ] each ] unit-test ! [ ] [ 1.0 10000000 [ drop 1.0 * ] each ] unit-test
! [ ] [ 268435455 >fixnum 10000000 [ dup dup + drop ] each drop ] unit-test [ ] [ 268435455 >fixnum 10000000 [ dup dup + drop ] times drop ] unit-test
[ ] [ 268435455 >fixnum 10000000 [ dup dup fixnum+ drop ] each drop ] unit-test [ ] [ 268435455 >fixnum 10000000 [ dup dup fixnum+ drop ] times drop ] unit-test
[ ] [ 10000000 [ drop 1/3 >fixnum drop ] each ] unit-test [ ] [ 10000000 [ drop 1/3 >fixnum drop ] each ] unit-test
[ ] [ 10000000 [ drop 1/3 >bignum drop ] each ] unit-test [ ] [ 10000000 [ drop 1/3 >bignum drop ] each ] unit-test
[ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test [ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test

4
library/test/math/integer.factor
View File

@ -54,8 +54,8 @@ USING: kernel math namespaces prettyprint test ;
gcd nip gcd nip
] unit-test ] unit-test
: verify-gcd ( x y ) : verify-gcd
2dup swap gcd ( a d ) 2dup swap gcd
>r rot * swap rem r> = ; >r rot * swap rem r> = ;
[ t ] [ 123 124 verify-gcd ] unit-test [ t ] [ 123 124 verify-gcd ] unit-test

6
library/test/random.factor
View File

@ -1,10 +1,10 @@
IN: temporary IN: temporary
USING: errors kernel math namespaces sequences test ; USING: errors kernel math namespaces sequences test ;
: check-random-int ( max -- ) : check-random-int ( max -- ? )
>r random-int 0 r> between? ; dup >r random-int 0 r> between? ;
[ t ] [ 100 [ 674 check-random-int ] all? ] unit-test [ t ] [ 100 [ drop 674 check-random-int ] all? ] unit-test
: make-100-random-ints : make-100-random-ints
[ 100 [ 100 random-int , ] times ] { } make ; [ 100 [ 100 random-int , ] times ] { } make ;

18
vm/alien.c
View File

@ -25,7 +25,7 @@ void *alien_offset(CELL object)
switch(type_of(object)) switch(type_of(object))
{ {
case BYTE_ARRAY_TYPE: case BYTE_ARRAY_TYPE:
array = untag_byte_array_fast(object); array = untag_array_fast(object);
return array + 1; return array + 1;
case ALIEN_TYPE: case ALIEN_TYPE:
alien = untag_alien_fast(object); alien = untag_alien_fast(object);
@ -59,12 +59,12 @@ CELL allot_alien(CELL delegate, CELL displacement)
} }
/* make an alien and push */ /* make an alien and push */
void box_alien(CELL ptr) void box_alien(void* ptr)
{ {
if(ptr == 0) if(ptr == NULL)
dpush(F); dpush(F);
else else
dpush(allot_alien(F,ptr)); dpush(allot_alien(F,(CELL)ptr));
} }
/* make an alien pointing at an offset of another alien */ /* make an alien pointing at an offset of another alien */
@ -155,6 +155,7 @@ void box_value_pair(CELL x, CELL y)
/* open a native library and push a handle */ /* open a native library and push a handle */
void primitive_dlopen(void) void primitive_dlopen(void)
{ {
primitive_string_to_char_alien();
F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL)); F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
dll->path = dpop(); dll->path = dpop();
ffi_dlopen(dll,true); ffi_dlopen(dll,true);
@ -165,9 +166,12 @@ void primitive_dlopen(void)
void primitive_dlsym(void) void primitive_dlsym(void)
{ {
CELL dll = dpop(); CELL dll = dpop();
F_STRING *sym = untag_string(dpop()); REGISTER_ROOT(dll);
char *sym = unbox_char_string();
UNREGISTER_ROOT(dll);
F_DLL *d; F_DLL *d;
if(dll == F) if(dll == F)
d = NULL; d = NULL;
else else
@ -177,7 +181,7 @@ void primitive_dlsym(void)
general_error(ERROR_EXPIRED,dll,F,true); general_error(ERROR_EXPIRED,dll,F,true);
} }
box_signed_cell((CELL)ffi_dlsym(d,sym,true)); box_alien(ffi_dlsym(d,sym,true));
} }
/* close a native library handle */ /* close a native library handle */

2
vm/alien.h
View File

@ -16,7 +16,7 @@ void* alien_offset(CELL object);
void fixup_alien(F_ALIEN* d); void fixup_alien(F_ALIEN* d);
DLLEXPORT void *unbox_alien(void); DLLEXPORT void *unbox_alien(void);
DLLEXPORT void box_alien(CELL ptr); DLLEXPORT void box_alien(void *ptr);
void primitive_alien_signed_cell(void); void primitive_alien_signed_cell(void);
void primitive_set_alien_signed_cell(void); void primitive_set_alien_signed_cell(void);

284
vm/bignum.c
View File

@ -91,6 +91,7 @@ s48_bignum_compare(bignum_type x, bignum_type y)
: (bignum_compare_unsigned (x, y)))); : (bignum_compare_unsigned (x, y))));
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_add(bignum_type x, bignum_type y) s48_bignum_add(bignum_type x, bignum_type y)
{ {
@ -108,6 +109,7 @@ s48_bignum_add(bignum_type x, bignum_type y)
: (bignum_add_unsigned (x, y, 0))))); : (bignum_add_unsigned (x, y, 0)))));
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_subtract(bignum_type x, bignum_type y) s48_bignum_subtract(bignum_type x, bignum_type y)
{ {
@ -127,6 +129,7 @@ s48_bignum_subtract(bignum_type x, bignum_type y)
: (bignum_subtract_unsigned (x, y)))))); : (bignum_subtract_unsigned (x, y))))));
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_multiply(bignum_type x, bignum_type y) s48_bignum_multiply(bignum_type x, bignum_type y)
{ {
@ -159,6 +162,7 @@ s48_bignum_multiply(bignum_type x, bignum_type y)
return (bignum_multiply_unsigned (x, y, negative_p)); return (bignum_multiply_unsigned (x, y, negative_p));
} }
/* allocates memory */
void void
s48_bignum_divide(bignum_type numerator, bignum_type denominator, s48_bignum_divide(bignum_type numerator, bignum_type denominator,
bignum_type * quotient, bignum_type * remainder) bignum_type * quotient, bignum_type * remainder)
@ -231,6 +235,7 @@ s48_bignum_divide(bignum_type numerator, bignum_type denominator,
} }
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_quotient(bignum_type numerator, bignum_type denominator) s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
{ {
@ -283,6 +288,7 @@ s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
} }
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_remainder(bignum_type numerator, bignum_type denominator) s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
{ {
@ -348,7 +354,7 @@ s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
} \ } \
{ \ { \
bignum_type result = \ bignum_type result = \
(bignum_allocate ((end_digits - result_digits), negative_p)); \ (allot_bignum ((end_digits - result_digits), negative_p)); \
bignum_digit_type * scan_digits = result_digits; \ bignum_digit_type * scan_digits = result_digits; \
bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
while (scan_digits < end_digits) \ while (scan_digits < end_digits) \
@ -357,6 +363,7 @@ s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
} \ } \
} }
/* all below allocate memory */
FOO_TO_BIGNUM(cell,CELL,CELL) FOO_TO_BIGNUM(cell,CELL,CELL)
FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL) FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
FOO_TO_BIGNUM(long,long,unsigned long) FOO_TO_BIGNUM(long,long,unsigned long)
@ -368,28 +375,30 @@ FOO_TO_BIGNUM(ulong_long,u64,u64)
it probaly does not matter */ it probaly does not matter */
bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y) bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y)
{ {
return s48_bignum_add( bignum_type hiword = s48_bignum_arithmetic_shift(
s48_bignum_arithmetic_shift( s48_fixnum_to_bignum(y),sizeof(unsigned long) * 8);
s48_fixnum_to_bignum(y), REGISTER_BIGNUM(hiword);
sizeof(unsigned long) * 8), bignum_type loword = s48_cell_to_bignum(x);
s48_cell_to_bignum(x)); UNREGISTER_BIGNUM(hiword);
return s48_bignum_add(hiword,loword);
} }
#define BIGNUM_TO_FOO(name,type,utype) \ #define BIGNUM_TO_FOO(name,type,utype) \
type s48_bignum_to_##name(bignum_type bignum) \ type s48_bignum_to_##name(bignum_type bignum) \
{ \ { \
if (BIGNUM_ZERO_P (bignum)) \ if (BIGNUM_ZERO_P (bignum)) \
return (0); \ return (0); \
{ \ { \
utype accumulator = 0; \ utype accumulator = 0; \
bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
while (start < scan) \ while (start < scan) \
accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
} \ } \
} }
/* all of the below allocate memory */
BIGNUM_TO_FOO(cell,CELL,CELL); BIGNUM_TO_FOO(cell,CELL,CELL);
BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL); BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
BIGNUM_TO_FOO(long,long,unsigned long) BIGNUM_TO_FOO(long,long,unsigned long)
@ -412,14 +421,15 @@ s48_bignum_to_double(bignum_type bignum)
} }
} }
#define DTB_WRITE_DIGIT(factor) \ #define DTB_WRITE_DIGIT(factor) \
{ \ { \
significand *= (factor); \ significand *= (factor); \
digit = ((bignum_digit_type) significand); \ digit = ((bignum_digit_type) significand); \
(*--scan) = digit; \ (*--scan) = digit; \
significand -= ((double) digit); \ significand -= ((double) digit); \
} }
/* allocates memory */
bignum_type bignum_type
s48_double_to_bignum(double x) s48_double_to_bignum(double x)
{ {
@ -430,7 +440,7 @@ s48_double_to_bignum(double x)
if (significand < 0) significand = (-significand); if (significand < 0) significand = (-significand);
{ {
bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent)); bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
bignum_type result = (bignum_allocate (length, (x < 0))); bignum_type result = (allot_bignum (length, (x < 0)));
bignum_digit_type * start = (BIGNUM_START_PTR (result)); bignum_digit_type * start = (BIGNUM_START_PTR (result));
bignum_digit_type * scan = (start + length); bignum_digit_type * scan = (start + length);
bignum_digit_type digit; bignum_digit_type digit;
@ -501,6 +511,7 @@ bignum_compare_unsigned(bignum_type x, bignum_type y)
/* Addition */ /* Addition */
/* allocates memory */
bignum_type bignum_type
bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p) bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
{ {
@ -515,7 +526,7 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
REGISTER_BIGNUM(x); REGISTER_BIGNUM(x);
REGISTER_BIGNUM(y); REGISTER_BIGNUM(y);
bignum_type r = (bignum_allocate ((x_length + 1), negative_p)); bignum_type r = (allot_bignum ((x_length + 1), negative_p));
UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(y);
UNREGISTER_BIGNUM(x); UNREGISTER_BIGNUM(x);
@ -570,6 +581,7 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
/* Subtraction */ /* Subtraction */
/* allocates memory */
bignum_type bignum_type
bignum_subtract_unsigned(bignum_type x, bignum_type y) bignum_subtract_unsigned(bignum_type x, bignum_type y)
{ {
@ -595,7 +607,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y)
REGISTER_BIGNUM(x); REGISTER_BIGNUM(x);
REGISTER_BIGNUM(y); REGISTER_BIGNUM(y);
bignum_type r = (bignum_allocate (x_length, negative_p)); bignum_type r = (allot_bignum (x_length, negative_p));
UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(y);
UNREGISTER_BIGNUM(x); UNREGISTER_BIGNUM(x);
@ -650,6 +662,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y)
Maximum value for carry: ((R * (R - 1)) + (R - 1)) Maximum value for carry: ((R * (R - 1)) + (R - 1))
where R == BIGNUM_RADIX_ROOT */ where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
bignum_type bignum_type
bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p) bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
{ {
@ -674,7 +687,7 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
REGISTER_BIGNUM(x); REGISTER_BIGNUM(x);
REGISTER_BIGNUM(y); REGISTER_BIGNUM(y);
bignum_type r = bignum_type r =
(bignum_allocate_zeroed ((x_length + y_length), negative_p)); (allot_bignum_zeroed ((x_length + y_length), negative_p));
UNREGISTER_BIGNUM(y); UNREGISTER_BIGNUM(y);
UNREGISTER_BIGNUM(x); UNREGISTER_BIGNUM(x);
@ -723,6 +736,7 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
} }
} }
/* allocates memory */
bignum_type bignum_type
bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y, bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
int negative_p) int negative_p)
@ -730,7 +744,7 @@ bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
bignum_length_type length_x = (BIGNUM_LENGTH (x)); bignum_length_type length_x = (BIGNUM_LENGTH (x));
REGISTER_BIGNUM(x); REGISTER_BIGNUM(x);
bignum_type p = (bignum_allocate ((length_x + 1), negative_p)); bignum_type p = (allot_bignum ((length_x + 1), negative_p));
UNREGISTER_BIGNUM(x); UNREGISTER_BIGNUM(x);
bignum_destructive_copy (x, p); bignum_destructive_copy (x, p);
@ -776,6 +790,7 @@ bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
volume 2, "Seminumerical Algorithms" volume 2, "Seminumerical Algorithms"
section 4.3.1, "Multiple-Precision Arithmetic". */ section 4.3.1, "Multiple-Precision Arithmetic". */
/* allocates memory */
void void
bignum_divide_unsigned_large_denominator(bignum_type numerator, bignum_divide_unsigned_large_denominator(bignum_type numerator,
bignum_type denominator, bignum_type denominator,
@ -789,13 +804,11 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator,
bignum_type q = bignum_type q =
((quotient != ((bignum_type *) 0)) ((quotient != ((bignum_type *) 0))
? (bignum_allocate ((length_n - length_d), q_negative_p)) ? (allot_bignum ((length_n - length_d), q_negative_p))
: BIGNUM_OUT_OF_BAND); : BIGNUM_OUT_OF_BAND);
REGISTER_BIGNUM(q); REGISTER_BIGNUM(q);
bignum_type u = (allot_bignum (length_n, r_negative_p));
bignum_type u = (bignum_allocate (length_n, r_negative_p));
UNREGISTER_BIGNUM(q); UNREGISTER_BIGNUM(q);
int shift = 0; int shift = 0;
@ -820,7 +833,7 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator,
REGISTER_BIGNUM(denominator); REGISTER_BIGNUM(denominator);
REGISTER_BIGNUM(u); REGISTER_BIGNUM(u);
REGISTER_BIGNUM(q); REGISTER_BIGNUM(q);
bignum_type v = (bignum_allocate (length_d, 0)); bignum_type v = (allot_bignum (length_d, 0));
UNREGISTER_BIGNUM(q); UNREGISTER_BIGNUM(q);
UNREGISTER_BIGNUM(u); UNREGISTER_BIGNUM(u);
UNREGISTER_BIGNUM(denominator); UNREGISTER_BIGNUM(denominator);
@ -1004,6 +1017,7 @@ bignum_divide_subtract(bignum_digit_type * v_start,
return (guess - 1); return (guess - 1);
} }
/* allocates memory */
void void
bignum_divide_unsigned_medium_denominator(bignum_type numerator, bignum_divide_unsigned_medium_denominator(bignum_type numerator,
bignum_digit_type denominator, bignum_digit_type denominator,
@ -1027,7 +1041,7 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator,
length_q = length_n; length_q = length_n;
REGISTER_BIGNUM(numerator); REGISTER_BIGNUM(numerator);
q = (bignum_allocate (length_q, q_negative_p)); q = (allot_bignum (length_q, q_negative_p));
UNREGISTER_BIGNUM(numerator); UNREGISTER_BIGNUM(numerator);
bignum_destructive_copy (numerator, q); bignum_destructive_copy (numerator, q);
@ -1037,7 +1051,7 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator,
length_q = (length_n + 1); length_q = (length_n + 1);
REGISTER_BIGNUM(numerator); REGISTER_BIGNUM(numerator);
q = (bignum_allocate (length_q, q_negative_p)); q = (allot_bignum (length_q, q_negative_p));
UNREGISTER_BIGNUM(numerator); UNREGISTER_BIGNUM(numerator);
bignum_destructive_normalization (numerator, q, shift); bignum_destructive_normalization (numerator, q, shift);
@ -1047,28 +1061,27 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator,
bignum_digit_type * start = (BIGNUM_START_PTR (q)); bignum_digit_type * start = (BIGNUM_START_PTR (q));
bignum_digit_type * scan = (start + length_q); bignum_digit_type * scan = (start + length_q);
bignum_digit_type qj; bignum_digit_type qj;
if (quotient != ((bignum_type *) 0))
{
while (start < scan)
{
r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
(*scan) = qj;
}
(*quotient) = (bignum_trim (q)); while (start < scan)
}
else
{ {
while (start < scan) r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
r = (bignum_digit_divide (r, (*--scan), denominator, (&qj))); (*scan) = qj;
} }
q = bignum_trim (q);
if (remainder != ((bignum_type *) 0)) if (remainder != ((bignum_type *) 0))
{ {
if (shift != 0) if (shift != 0)
r >>= shift; r >>= shift;
REGISTER_BIGNUM(q);
(*remainder) = (bignum_digit_to_bignum (r, r_negative_p)); (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
UNREGISTER_BIGNUM(q);
} }
if (quotient != ((bignum_type *) 0))
(*quotient) = q;
} }
return; return;
} }
@ -1121,28 +1134,28 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
case of dividing two bignum digits by one bignum digit. It is case of dividing two bignum digits by one bignum digit. It is
assumed that the numerator, denominator are normalized. */ assumed that the numerator, denominator are normalized. */
#define BDD_STEP(qn, j) \ #define BDD_STEP(qn, j) \
{ \ { \
uj = (u[j]); \ uj = (u[j]); \
if (uj != v1) \ if (uj != v1) \
{ \ { \
uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
guess = (uj_uj1 / v1); \ guess = (uj_uj1 / v1); \
comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
} \ } \
else \ else \
{ \ { \
guess = (BIGNUM_RADIX_ROOT - 1); \ guess = (BIGNUM_RADIX_ROOT - 1); \
comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
} \ } \
while ((guess * v2) > comparand) \ while ((guess * v2) > comparand) \
{ \ { \
guess -= 1; \ guess -= 1; \
comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
if (comparand >= BIGNUM_RADIX) \ if (comparand >= BIGNUM_RADIX) \
break; \ break; \
} \ } \
qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
} }
bignum_digit_type bignum_digit_type
@ -1186,35 +1199,35 @@ bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
#undef BDD_STEP #undef BDD_STEP
#define BDDS_MULSUB(vn, un, carry_in) \ #define BDDS_MULSUB(vn, un, carry_in) \
{ \ { \
product = ((vn * guess) + carry_in); \ product = ((vn * guess) + carry_in); \
diff = (un - (HD_LOW (product))); \ diff = (un - (HD_LOW (product))); \
if (diff < 0) \ if (diff < 0) \
{ \ { \
un = (diff + BIGNUM_RADIX_ROOT); \ un = (diff + BIGNUM_RADIX_ROOT); \
carry = ((HD_HIGH (product)) + 1); \ carry = ((HD_HIGH (product)) + 1); \
} \ } \
else \ else \
{ \ { \
un = diff; \ un = diff; \
carry = (HD_HIGH (product)); \ carry = (HD_HIGH (product)); \
} \ } \
} }
#define BDDS_ADD(vn, un, carry_in) \ #define BDDS_ADD(vn, un, carry_in) \
{ \ { \
sum = (vn + un + carry_in); \ sum = (vn + un + carry_in); \
if (sum < BIGNUM_RADIX_ROOT) \ if (sum < BIGNUM_RADIX_ROOT) \
{ \ { \
un = sum; \ un = sum; \
carry = 0; \ carry = 0; \
} \ } \
else \ else \
{ \ { \
un = (sum - BIGNUM_RADIX_ROOT); \ un = (sum - BIGNUM_RADIX_ROOT); \
carry = 1; \ carry = 1; \
} \ } \
} }
bignum_digit_type bignum_digit_type
@ -1252,6 +1265,7 @@ bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
#undef BDDS_MULSUB #undef BDDS_MULSUB
#undef BDDS_ADD #undef BDDS_ADD
/* allocates memory */
void void
bignum_divide_unsigned_small_denominator(bignum_type numerator, bignum_divide_unsigned_small_denominator(bignum_type numerator,
bignum_digit_type denominator, bignum_digit_type denominator,
@ -1307,6 +1321,7 @@ bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
#undef quotient_high #undef quotient_high
} }
/* allocates memory */
bignum_type bignum_type
bignum_remainder_unsigned_small_denominator( bignum_remainder_unsigned_small_denominator(
bignum_type n, bignum_digit_type d, int negative_p) bignum_type n, bignum_digit_type d, int negative_p)
@ -1327,6 +1342,7 @@ bignum_remainder_unsigned_small_denominator(
return (bignum_digit_to_bignum (r, negative_p)); return (bignum_digit_to_bignum (r, negative_p));
} }
/* allocates memory */
bignum_type bignum_type
bignum_digit_to_bignum(bignum_digit_type digit, int negative_p) bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{ {
@ -1334,40 +1350,38 @@ bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
return (BIGNUM_ZERO ()); return (BIGNUM_ZERO ());
else else
{ {
bignum_type result = (bignum_allocate (1, negative_p)); bignum_type result = (allot_bignum (1, negative_p));
(BIGNUM_REF (result, 0)) = digit; (BIGNUM_REF (result, 0)) = digit;
return (result); return (result);
} }
} }
/* Allocation */ /* allocates memory */
bignum_type bignum_type
bignum_allocate(bignum_length_type length, int negative_p) allot_bignum(bignum_length_type length, int negative_p)
{ {
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
{ bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1);
bignum_type result = (BIGNUM_ALLOCATE (length)); BIGNUM_SET_NEGATIVE_P (result, negative_p);
BIGNUM_SET_NEGATIVE_P (result, negative_p); return (result);
return (result);
}
} }
/* allocates memory */
bignum_type bignum_type
bignum_allocate_zeroed(bignum_length_type length, int negative_p) allot_bignum_zeroed(bignum_length_type length, int negative_p)
{ {
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); bignum_type result = allot_bignum(length,negative_p);
{ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
bignum_type result = (BIGNUM_ALLOCATE (length)); bignum_digit_type * end = (scan + length);
bignum_digit_type * scan = (BIGNUM_START_PTR (result)); while (scan < end)
bignum_digit_type * end = (scan + length); (*scan++) = 0;
BIGNUM_SET_NEGATIVE_P (result, negative_p); return (result);
while (scan < end)
(*scan++) = 0;
return (result);
}
} }
#define BIGNUM_REDUCE_LENGTH(source, length) \
source = reallot_array(source,length + 1,69)
/* allocates memory */
bignum_type bignum_type
bignum_shorten_length(bignum_type bignum, bignum_length_type length) bignum_shorten_length(bignum_type bignum, bignum_length_type length)
{ {
@ -1381,6 +1395,7 @@ bignum_shorten_length(bignum_type bignum, bignum_length_type length)
return (bignum); return (bignum);
} }
/* allocates memory */
bignum_type bignum_type
bignum_trim(bignum_type bignum) bignum_trim(bignum_type bignum)
{ {
@ -1401,18 +1416,20 @@ bignum_trim(bignum_type bignum)
/* Copying */ /* Copying */
/* allocates memory */
bignum_type bignum_type
bignum_new_sign(bignum_type bignum, int negative_p) bignum_new_sign(bignum_type bignum, int negative_p)
{ {
REGISTER_BIGNUM(bignum); REGISTER_BIGNUM(bignum);
bignum_type result = bignum_type result =
(bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
UNREGISTER_BIGNUM(bignum); UNREGISTER_BIGNUM(bignum);
bignum_destructive_copy (bignum, result); bignum_destructive_copy (bignum, result);
return (result); return (result);
} }
/* allocates memory */
bignum_type bignum_type
bignum_maybe_new_sign(bignum_type bignum, int negative_p) bignum_maybe_new_sign(bignum_type bignum, int negative_p)
{ {
@ -1421,7 +1438,7 @@ bignum_maybe_new_sign(bignum_type bignum, int negative_p)
else else
{ {
bignum_type result = bignum_type result =
(bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
bignum_destructive_copy (bignum, result); bignum_destructive_copy (bignum, result);
return (result); return (result);
} }
@ -1439,28 +1456,18 @@ bignum_destructive_copy(bignum_type source, bignum_type target)
return; return;
} }
/* Unused
void
bignum_destructive_zero(bignum_type bignum)
{
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
while (scan < end)
(*scan++) = 0;
return;
}
*/
/* /*
* Added bitwise operations (and oddp). * Added bitwise operations (and oddp).
*/ */
/* allocates memory */
bignum_type bignum_type
s48_bignum_bitwise_not(bignum_type x) s48_bignum_bitwise_not(bignum_type x)
{ {
return s48_bignum_subtract(BIGNUM_ONE(1), x); return s48_bignum_subtract(BIGNUM_ONE(1), x);
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_arithmetic_shift(bignum_type arg1, long n) s48_bignum_arithmetic_shift(bignum_type arg1, long n)
{ {
@ -1476,6 +1483,7 @@ s48_bignum_arithmetic_shift(bignum_type arg1, long n)
#define IOR_OP 1 #define IOR_OP 1
#define XOR_OP 2 #define XOR_OP 2
/* allocates memory */
bignum_type bignum_type
s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2) s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
{ {
@ -1490,6 +1498,7 @@ s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
); );
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2) s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
{ {
@ -1504,6 +1513,7 @@ s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
); );
} }
/* allocates memory */
bignum_type bignum_type
s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2) s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
{ {
@ -1518,6 +1528,7 @@ s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
); );
} }
/* allocates memory */
/* ash for the magnitude */ /* ash for the magnitude */
/* assume arg1 is a big number, n is a long */ /* assume arg1 is a big number, n is a long */
bignum_type bignum_type
@ -1537,7 +1548,7 @@ bignum_magnitude_ash(bignum_type arg1, long n)
bit_offset = n % BIGNUM_DIGIT_LENGTH; bit_offset = n % BIGNUM_DIGIT_LENGTH;
REGISTER_BIGNUM(arg1); REGISTER_BIGNUM(arg1);
result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1, result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
BIGNUM_NEGATIVE_P(arg1)); BIGNUM_NEGATIVE_P(arg1));
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);
@ -1562,7 +1573,7 @@ bignum_magnitude_ash(bignum_type arg1, long n)
bit_offset = -n % BIGNUM_DIGIT_LENGTH; bit_offset = -n % BIGNUM_DIGIT_LENGTH;
REGISTER_BIGNUM(arg1); REGISTER_BIGNUM(arg1);
result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) - digit_offset, result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
BIGNUM_NEGATIVE_P(arg1)); BIGNUM_NEGATIVE_P(arg1));
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);
@ -1583,6 +1594,7 @@ bignum_magnitude_ash(bignum_type arg1, long n)
return (bignum_trim (result)); return (bignum_trim (result));
} }
/* allocates memory */
bignum_type bignum_type
bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2) bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
{ {
@ -1598,7 +1610,7 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
REGISTER_BIGNUM(arg1); REGISTER_BIGNUM(arg1);
REGISTER_BIGNUM(arg2); REGISTER_BIGNUM(arg2);
result = bignum_allocate(max_length, 0); result = allot_bignum(max_length, 0);
UNREGISTER_BIGNUM(arg2); UNREGISTER_BIGNUM(arg2);
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);
@ -1623,6 +1635,7 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
return bignum_trim(result); return bignum_trim(result);
} }
/* allocates memory */
bignum_type bignum_type
bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
{ {
@ -1640,7 +1653,7 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
REGISTER_BIGNUM(arg1); REGISTER_BIGNUM(arg1);
REGISTER_BIGNUM(arg2); REGISTER_BIGNUM(arg2);
result = bignum_allocate(max_length, neg_p); result = allot_bignum(max_length, neg_p);
UNREGISTER_BIGNUM(arg2); UNREGISTER_BIGNUM(arg2);
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);
@ -1677,6 +1690,7 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
return bignum_trim(result); return bignum_trim(result);
} }
/* allocates memory */
bignum_type bignum_type
bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2) bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
{ {
@ -1694,7 +1708,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);
UNREGISTER_BIGNUM(arg2); UNREGISTER_BIGNUM(arg2);
result = bignum_allocate(max_length, neg_p); result = allot_bignum(max_length, neg_p);
UNREGISTER_BIGNUM(arg2); UNREGISTER_BIGNUM(arg2);
UNREGISTER_BIGNUM(arg1); UNREGISTER_BIGNUM(arg1);

4
vm/bignum.h
View File

@ -118,8 +118,8 @@ bignum_digit_type bignum_destructive_scale_down
bignum_type bignum_remainder_unsigned_small_denominator bignum_type bignum_remainder_unsigned_small_denominator
(bignum_type, bignum_digit_type, int); (bignum_type, bignum_digit_type, int);
bignum_type bignum_digit_to_bignum(bignum_digit_type, int); bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
bignum_type bignum_allocate(bignum_length_type, int); bignum_type allot_bignum(bignum_length_type, int);
bignum_type bignum_allocate_zeroed(bignum_length_type, int); bignum_type allot_bignum_zeroed(bignum_length_type, int);
bignum_type bignum_shorten_length(bignum_type, bignum_length_type); bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
bignum_type bignum_trim(bignum_type); bignum_type bignum_trim(bignum_type);
bignum_type bignum_new_sign(bignum_type, int); bignum_type bignum_new_sign(bignum_type, int);

11
vm/bignumint.h
View File

@ -45,20 +45,9 @@ MIT in each case. */
typedef F_FIXNUM bignum_digit_type; typedef F_FIXNUM bignum_digit_type;
typedef F_FIXNUM bignum_length_type; typedef F_FIXNUM bignum_length_type;
/* BIGNUM_ALLOCATE allocates a (length + 1)-element array of
`bignum_digit_type'; deallocation is the responsibility of the
user (in Factor, the garbage collector handles this). */
#define BIGNUM_ALLOCATE(length_in_digits) \
allot_array_internal(BIGNUM_TYPE,length_in_digits + 1)
/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */ /* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
#define BIGNUM_TO_POINTER(bignum) ((CELL*)AREF(bignum,0)) #define BIGNUM_TO_POINTER(bignum) ((CELL*)AREF(bignum,0))
/* BIGNUM_REDUCE_LENGTH allows the memory system to reclaim some
space when a bignum's length is reduced from its original value. */
#define BIGNUM_REDUCE_LENGTH(source, length) \
source = reallot_array(source,length + 1,69)
/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */ /* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
#define BIGNUM_EXCEPTION abort #define BIGNUM_EXCEPTION abort

2
vm/code_gc.c
View File

@ -5,7 +5,7 @@ will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */ mark/sweep/compact GC. */
void new_heap(F_HEAP *heap, CELL size) void new_heap(F_HEAP *heap, CELL size)
{ {
heap->base = (CELL)(alloc_bounded_block(size)->start); heap->base = (CELL)(alloc_segment(size)->start);
if(heap->base == 0) if(heap->base == 0)
fatal_error("Cannot allocate code heap",size); fatal_error("Cannot allocate code heap",size);
heap->limit = heap->base + size; heap->limit = heap->base + size;

11
vm/compiler.c
View File

@ -19,7 +19,7 @@ CELL get_rel_symbol(F_REL *rel, CELL literal_start)
{ {
CELL arg = REL_ARGUMENT(rel); CELL arg = REL_ARGUMENT(rel);
F_ARRAY *pair = untag_array(get_literal(literal_start,arg)); F_ARRAY *pair = untag_array(get_literal(literal_start,arg));
F_STRING *symbol = untag_string(get(AREF(pair,0))); char *symbol = alien_offset(get(AREF(pair,0)));
CELL library = get(AREF(pair,1)); CELL library = get(AREF(pair,1));
F_DLL *dll = (library == F ? NULL : untag_dll(library)); F_DLL *dll = (library == F ? NULL : untag_dll(library));
@ -150,12 +150,8 @@ void finalize_code_block(F_COMPILED *relocating, CELL code_start,
/* Write a sequence of integers to memory, with 'format' bytes per integer */ /* Write a sequence of integers to memory, with 'format' bytes per integer */
void deposit_integers(CELL here, F_VECTOR *vector, CELL format) void deposit_integers(CELL here, F_VECTOR *vector, CELL format)
{ {
if(vector->header != tag_header(VECTOR_TYPE))
critical_error("FUCKUP 2",0);
CELL count = untag_fixnum_fast(vector->top); CELL count = untag_fixnum_fast(vector->top);
F_ARRAY *array = untag_array_fast(vector->array); F_ARRAY *array = untag_array_fast(vector->array);
if(array->header != tag_header(ARRAY_TYPE))
critical_error("FUCKUP 3",0);
CELL i; CELL i;
for(i = 0; i < count; i++) for(i = 0; i < count; i++)
@ -222,9 +218,6 @@ void primitive_add_compiled_block(void)
GC above in which case the data heap semi-spaces will have switched */ GC above in which case the data heap semi-spaces will have switched */
FROB FROB
if(code->header != tag_header(VECTOR_TYPE))
critical_error("FUCKUP",0);
/* now we can pop the parameters from the stack */ /* now we can pop the parameters from the stack */
ds -= CELLS * 5; ds -= CELLS * 5;
@ -268,6 +261,7 @@ void primitive_add_compiled_block(void)
executable */ executable */
void primitive_finalize_compile(void) void primitive_finalize_compile(void)
{ {
gc_off = true;
F_ARRAY *array = untag_array(dpop()); F_ARRAY *array = untag_array(dpop());
/* set word XT's */ /* set word XT's */
@ -288,4 +282,5 @@ void primitive_finalize_compile(void)
CELL xt = to_cell(get(AREF(pair,1))); CELL xt = to_cell(get(AREF(pair,1)));
iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block); iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
} }
gc_off = false;
} }

12
vm/data_gc.c
View File

@ -243,7 +243,7 @@ void init_data_heap(CELL gens,
gen_count = gens; gen_count = gens;
generations = safe_malloc(sizeof(F_ZONE) * gen_count); generations = safe_malloc(sizeof(F_ZONE) * gen_count);
data_heap_start = (CELL)(alloc_bounded_block(total_size)->start); data_heap_start = (CELL)(alloc_segment(total_size)->start);
data_heap_end = data_heap_start + total_size; data_heap_end = data_heap_start + total_size;
cards = safe_malloc(cards_size); cards = safe_malloc(cards_size);
@ -271,8 +271,8 @@ void init_data_heap(CELL gens,
data_heap_end = data_heap_start + total_size; data_heap_end = data_heap_start + total_size;
extra_roots_region = alloc_bounded_block(getpagesize()); extra_roots_region = alloc_segment(getpagesize());
extra_roots = (CELL *)extra_roots_region->start; extra_roots = extra_roots_region->start - CELLS;
} }
void collect_callframe_triple(CELL *callframe, void collect_callframe_triple(CELL *callframe,
@ -286,7 +286,7 @@ void collect_callframe_triple(CELL *callframe,
} }
/* Copy all tagged pointers in a range of memory */ /* Copy all tagged pointers in a range of memory */
void collect_stack(F_BOUNDED_BLOCK *region, CELL top) void collect_stack(F_SEGMENT *region, CELL top)
{ {
CELL bottom = region->start; CELL bottom = region->start;
CELL ptr; CELL ptr;
@ -296,7 +296,7 @@ void collect_stack(F_BOUNDED_BLOCK *region, CELL top)
} }
/* The callstack has a special format */ /* The callstack has a special format */
void collect_callstack(F_BOUNDED_BLOCK *region, CELL top) void collect_callstack(F_SEGMENT *region, CELL top)
{ {
CELL bottom = region->start; CELL bottom = region->start;
CELL ptr; CELL ptr;
@ -319,7 +319,7 @@ void collect_roots(void)
copy_handle(&bignum_neg_one); copy_handle(&bignum_neg_one);
collect_callframe_triple(&callframe,&callframe_scan,&callframe_end); collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
collect_stack(extra_roots_region,(CELL)(extra_roots - 1)); collect_stack(extra_roots_region,extra_roots);
save_stacks(); save_stacks();
stacks = stack_chain; stacks = stack_chain;

40
vm/data_gc.h
View File

@ -8,12 +8,12 @@ void *safe_malloc(size_t size);
typedef struct { typedef struct {
CELL start; CELL start;
CELL size; CELL size;
} F_BOUNDED_BLOCK; } F_SEGMENT;
/* set up guard pages to check for under/overflow. /* set up guard pages to check for under/overflow.
size must be a multiple of the page size */ size must be a multiple of the page size */
F_BOUNDED_BLOCK *alloc_bounded_block(CELL size); F_SEGMENT *alloc_segment(CELL size);
void dealloc_bounded_block(F_BOUNDED_BLOCK *block); void dealloc_segment(F_SEGMENT *block);
CELL untagged_object_size(CELL pointer); CELL untagged_object_size(CELL pointer);
CELL unaligned_object_size(CELL pointer); CELL unaligned_object_size(CELL pointer);
@ -194,33 +194,25 @@ void garbage_collection(CELL gen, bool code_gc);
/* If a runtime function needs to call another function which potentially /* If a runtime function needs to call another function which potentially
allocates memory, it must store any local variable references to Factor allocates memory, it must store any local variable references to Factor
objects on the root stack */ objects on the root stack */
F_BOUNDED_BLOCK *extra_roots_region; F_SEGMENT *extra_roots_region;
CELL *extra_roots; CELL extra_roots;
INLINE void push_root(CELL tagged) DEFPUSHPOP(root_,extra_roots)
{
*(extra_roots++) = tagged;
}
INLINE CELL pop_root(void) #define REGISTER_ROOT(obj) root_push(obj)
{ #define UNREGISTER_ROOT(obj) obj = root_pop()
return *(--extra_roots);
}
#define REGISTER_ROOT(obj) push_root(obj) #define REGISTER_ARRAY(obj) root_push(tag_object(obj))
#define UNREGISTER_ROOT(obj) obj = pop_root() #define UNREGISTER_ARRAY(obj) obj = untag_array_fast(root_pop())
#define REGISTER_ARRAY(obj) push_root(tag_object(obj)) #define REGISTER_STRING(obj) root_push(tag_object(obj))
#define UNREGISTER_ARRAY(obj) obj = untag_array_fast(pop_root()) #define UNREGISTER_STRING(obj) obj = untag_string_fast(root_pop())
#define REGISTER_STRING(obj) push_root(tag_object(obj)) #define REGISTER_C_STRING(obj) root_push(tag_object(((F_ARRAY *)obj) - 1))
#define UNREGISTER_STRING(obj) obj = untag_string_fast(pop_root()) #define UNREGISTER_C_STRING(obj) obj = ((char*)(untag_array_fast(root_pop()) + 1))
#define REGISTER_C_STRING(obj) push_root(tag_object(((F_ARRAY *)obj) - 1)) #define REGISTER_BIGNUM(obj) root_push(tag_bignum(obj))
#define UNREGISTER_C_STRING(obj) obj = ((char*)(untag_array_fast(pop_root()) + 1)) #define UNREGISTER_BIGNUM(obj) obj = (untag_bignum_fast(root_pop()))
#define REGISTER_BIGNUM(obj) push_root(tag_bignum(obj))
#define UNREGISTER_BIGNUM(obj) obj = (untag_bignum_fast(pop_root()))
INLINE void *allot_zone(F_ZONE *z, CELL a) INLINE void *allot_zone(F_ZONE *z, CELL a)
{ {

10
vm/io.c
View File

@ -33,12 +33,12 @@ void primitive_fopen(void)
FILE *file = fopen(path,mode); FILE *file = fopen(path,mode);
if(file == NULL) if(file == NULL)
io_error(); io_error();
box_alien((CELL)file); box_alien(file);
} }
void primitive_fgetc(void) void primitive_fgetc(void)
{ {
FILE* file = (FILE*)unbox_alien(); FILE* file = unbox_alien();
int c = fgetc(file); int c = fgetc(file);
if(c == EOF) if(c == EOF)
dpush(F); dpush(F);
@ -48,7 +48,7 @@ void primitive_fgetc(void)
void primitive_fwrite(void) void primitive_fwrite(void)
{ {
FILE* file = (FILE*)unbox_alien(); FILE* file = unbox_alien();
F_STRING* text = untag_string(dpop()); F_STRING* text = untag_string(dpop());
F_FIXNUM length = untag_fixnum_fast(text->length); F_FIXNUM length = untag_fixnum_fast(text->length);
@ -61,10 +61,10 @@ void primitive_fwrite(void)
void primitive_fflush(void) void primitive_fflush(void)
{ {
fflush((FILE*)unbox_alien()); fflush(unbox_alien());
} }
void primitive_fclose(void) void primitive_fclose(void)
{ {
fclose((FILE*)unbox_alien()); fclose(unbox_alien());
} }

2
vm/layouts.h
View File

@ -169,7 +169,7 @@ typedef struct {
typedef struct { typedef struct {
CELL header; CELL header;
/* tagged string */ /* tagged byte array holding a C string */
CELL path; CELL path;
/* OS-specific handle */ /* OS-specific handle */
void* dll; void* dll;

12
vm/os-unix.c
View File

@ -16,7 +16,7 @@ void init_ffi(void)
void ffi_dlopen(F_DLL *dll, bool error) void ffi_dlopen(F_DLL *dll, bool error)
{ {
void *dllptr = dlopen(to_char_string(untag_string(dll->path),true), RTLD_LAZY); void *dllptr = dlopen(alien_offset(dll->path), RTLD_LAZY);
if(dllptr == NULL) if(dllptr == NULL)
{ {
@ -34,10 +34,10 @@ void ffi_dlopen(F_DLL *dll, bool error)
dll->dll = dllptr; dll->dll = dllptr;
} }
void *ffi_dlsym(F_DLL *dll, F_STRING *symbol, bool error) void *ffi_dlsym(F_DLL *dll, char *symbol, bool error)
{ {
void *handle = (dll == NULL ? null_dll : dll->dll); void *handle = (dll == NULL ? null_dll : dll->dll);
void *sym = dlsym(handle,to_char_string(symbol,true)); void *sym = dlsym(handle,symbol);
if(sym == NULL) if(sym == NULL)
{ {
if(error) if(error)
@ -128,7 +128,7 @@ void primitive_cd(void)
chdir(unbox_char_string()); chdir(unbox_char_string());
} }
F_BOUNDED_BLOCK *alloc_bounded_block(CELL size) F_SEGMENT *alloc_segment(CELL size)
{ {
int pagesize = getpagesize(); int pagesize = getpagesize();
@ -145,7 +145,7 @@ F_BOUNDED_BLOCK *alloc_bounded_block(CELL size)
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1) if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect high guard page",(CELL)array); fatal_error("Cannot protect high guard page",(CELL)array);
F_BOUNDED_BLOCK *retval = safe_malloc(sizeof(F_BOUNDED_BLOCK)); F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT));
retval->start = (CELL)(array + pagesize); retval->start = (CELL)(array + pagesize);
retval->size = size; retval->size = size;
@ -153,7 +153,7 @@ F_BOUNDED_BLOCK *alloc_bounded_block(CELL size)
return retval; return retval;
} }
void dealloc_bounded_block(F_BOUNDED_BLOCK *block) void dealloc_segment(F_SEGMENT *block)
{ {
int pagesize = getpagesize(); int pagesize = getpagesize();

2
vm/os-unix.h
View File

@ -13,7 +13,7 @@
void init_ffi(void); void init_ffi(void);
void ffi_dlopen(F_DLL *dll, bool error); void ffi_dlopen(F_DLL *dll, bool error);
void *ffi_dlsym(F_DLL *dll, F_STRING *symbol, bool error); void *ffi_dlsym(F_DLL *dll, char *symbol, bool error);
void ffi_dlclose(F_DLL *dll); void ffi_dlclose(F_DLL *dll);
void unix_init_signals(void); void unix_init_signals(void);

20
vm/os-windows.c
View File

@ -49,10 +49,7 @@ s64 current_millis(void)
void ffi_dlopen (DLL *dll, bool error) void ffi_dlopen (DLL *dll, bool error)
{ {
HMODULE module; HMODULE module = LoadLibrary(alien_offset(dll->path));
char *path = to_char_string(untag_string(dll->path),true);
module = LoadLibrary(path);
if (!module) if (!module)
{ {
@ -66,10 +63,11 @@ void ffi_dlopen (DLL *dll, bool error)
dll->dll = module; dll->dll = module;
} }
void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error) void *ffi_dlsym (DLL *dll, char *symbol, bool error)
{ {
void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL), void *sym = GetProcAddress(
to_char_string(symbol,true)); dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
symbol);
if (!sym) if (!sym)
{ {
@ -167,7 +165,7 @@ void primitive_cd(void)
SetCurrentDirectory(unbox_char_string()); SetCurrentDirectory(unbox_char_string());
} }
F_BOUNDED_BLOCK *alloc_bounded_block(CELL size) F_SEGMENT *alloc_segment(CELL size)
{ {
SYSTEM_INFO si; SYSTEM_INFO si;
char *mem; char *mem;
@ -175,7 +173,7 @@ F_BOUNDED_BLOCK *alloc_bounded_block(CELL size)
GetSystemInfo(&si); GetSystemInfo(&si);
if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0) if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
fatal_error("VirtualAlloc() failed in alloc_bounded_block()",0); fatal_error("VirtualAlloc() failed in alloc_segment()",0);
if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore)) if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem); fatal_error("Cannot allocate low guard page", (CELL)mem);
@ -183,7 +181,7 @@ F_BOUNDED_BLOCK *alloc_bounded_block(CELL size)
if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore)) if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (CELL)mem); fatal_error("Cannot allocate high guard page", (CELL)mem);
F_BOUNDED_BLOCK *block = safe_malloc(sizeof(F_BOUNDED_BLOCK)); F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT));
block->start = (int)mem + si.dwPageSize; block->start = (int)mem + si.dwPageSize;
block->size = size; block->size = size;
@ -191,7 +189,7 @@ F_BOUNDED_BLOCK *alloc_bounded_block(CELL size)
return block; return block;
} }
void dealloc_bounded_block(F_BOUNDED_BLOCK *block) void dealloc_segment(F_SEGMENT *block)
{ {
SYSTEM_INFO si; SYSTEM_INFO si;
GetSystemInfo(&si); GetSystemInfo(&si);

2
vm/os-windows.h
View File

@ -17,7 +17,7 @@ DLLEXPORT char *error_message(DWORD id);
INLINE void init_ffi(void) {} INLINE void init_ffi(void) {}
void ffi_dlopen(F_DLL *dll, bool error); void ffi_dlopen(F_DLL *dll, bool error);
void *ffi_dlsym(F_DLL *dll, F_STRING *symbol, bool error); void *ffi_dlsym(F_DLL *dll, char *symbol, bool error);
void ffi_dlclose(F_DLL *dll); void ffi_dlclose(F_DLL *dll);
void primitive_open_file(void); void primitive_open_file(void);

2
vm/run.c
View File

@ -39,6 +39,8 @@ void handle_error(void)
{ {
if(throwing) if(throwing)
{ {
extra_roots = stack_chain->extra_roots;
if(thrown_keep_stacks) if(thrown_keep_stacks)
{ {
ds = thrown_ds; ds = thrown_ds;

25
vm/run.h
View File

@ -95,6 +95,31 @@ INLINE CELL type_of(CELL tagged)
return object_type(tagged); return object_type(tagged);
} }
#define DEFPUSHPOP(prefix,ptr) \
INLINE CELL prefix##pop(void) \
{ \
CELL value = get(ptr); \
ptr -= CELLS; \
return value; \
} \
INLINE void prefix##push(CELL tagged) \
{ \
ptr += CELLS; \
put(ptr,tagged); \
} \
INLINE void prefix##repl(CELL tagged) \
{ \
put(ptr,tagged); \
} \
INLINE CELL prefix##peek() \
{ \
return get(ptr); \
}
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
DEFPUSHPOP(c,cs)
void call(CELL quot); void call(CELL quot);
void handle_error(); void handle_error();

40
vm/stack.c
View File

@ -65,9 +65,11 @@ void nest_stacks(void)
new_stacks->callframe_end = callframe_end; new_stacks->callframe_end = callframe_end;
new_stacks->catch_save = userenv[CATCHSTACK_ENV]; new_stacks->catch_save = userenv[CATCHSTACK_ENV];
new_stacks->data_region = alloc_bounded_block(ds_size); new_stacks->data_region = alloc_segment(ds_size);
new_stacks->retain_region = alloc_bounded_block(rs_size); new_stacks->retain_region = alloc_segment(rs_size);
new_stacks->call_region = alloc_bounded_block(cs_size); new_stacks->call_region = alloc_segment(cs_size);
new_stacks->extra_roots = extra_roots;
new_stacks->next = stack_chain; new_stacks->next = stack_chain;
stack_chain = new_stacks; stack_chain = new_stacks;
@ -83,24 +85,24 @@ void nest_stacks(void)
/* called when leaving a compiled callback */ /* called when leaving a compiled callback */
void unnest_stacks(void) void unnest_stacks(void)
{ {
dealloc_segment(stack_chain->data_region);
dealloc_segment(stack_chain->retain_region);
dealloc_segment(stack_chain->call_region);
ds = stack_chain->data_save;
rs = stack_chain->retain_save;
cs = stack_chain->call_save;
cards_offset = stack_chain->cards_offset;
callframe = stack_chain->callframe;
callframe_scan = stack_chain->callframe_scan;
callframe_end = stack_chain->callframe_end;
userenv[CATCHSTACK_ENV] = stack_chain->catch_save;
extra_roots = stack_chain->extra_roots;
F_STACKS *old_stacks = stack_chain; F_STACKS *old_stacks = stack_chain;
dealloc_bounded_block(stack_chain->data_region);
dealloc_bounded_block(stack_chain->retain_region);
dealloc_bounded_block(stack_chain->call_region);
ds = old_stacks->data_save;
rs = old_stacks->retain_save;
cs = old_stacks->call_save;
cards_offset = old_stacks->cards_offset;
callframe = old_stacks->callframe;
callframe_scan = old_stacks->callframe_scan;
callframe_end = old_stacks->callframe_end;
userenv[CATCHSTACK_ENV] = old_stacks->catch_save;
stack_chain = old_stacks->next; stack_chain = old_stacks->next;
free(old_stacks); free(old_stacks);
} }

64
vm/stack.h
View File

@ -1,79 +1,39 @@
INLINE CELL dpop(void)
{
CELL value = get(ds);
ds -= CELLS;
return value;
}
INLINE void drepl(CELL top)
{
put(ds,top);
}
INLINE void dpush(CELL top)
{
ds += CELLS;
put(ds,top);
}
INLINE CELL dpeek(void)
{
return get(ds);
}
INLINE CELL cpop(void)
{
CELL value = get(cs);
cs -= CELLS;
return value;
}
INLINE void cpush(CELL top)
{
cs += CELLS;
put(cs,top);
}
INLINE CELL rpop(void)
{
CELL value = get(rs);
rs -= CELLS;
return value;
}
INLINE void rpush(CELL top)
{
rs += CELLS;
put(rs,top);
}
typedef struct _F_STACKS { typedef struct _F_STACKS {
/* current datastack top pointer */ /* current datastack top pointer */
CELL data; CELL data;
/* saved contents of ds register on entry to callback */ /* saved contents of ds register on entry to callback */
CELL data_save; CELL data_save;
/* memory region holding current datastack */ /* memory region holding current datastack */
F_BOUNDED_BLOCK *data_region; F_SEGMENT *data_region;
/* current retain stack top pointer */ /* current retain stack top pointer */
CELL retain; CELL retain;
/* saved contents of rs register on entry to callback */ /* saved contents of rs register on entry to callback */
CELL retain_save; CELL retain_save;
/* memory region holding current retain stack */ /* memory region holding current retain stack */
F_BOUNDED_BLOCK *retain_region; F_SEGMENT *retain_region;
/* current callstack top pointer */ /* current callstack top pointer */
CELL call; CELL call;
/* saved contents of cs register on entry to callback */ /* saved contents of cs register on entry to callback */
CELL call_save; CELL call_save;
/* memory region holding current callstack */ /* memory region holding current callstack */
F_BOUNDED_BLOCK *call_region; F_SEGMENT *call_region;
/* saved callframe on entry to callback */ /* saved callframe on entry to callback */
CELL callframe; CELL callframe;
CELL callframe_scan; CELL callframe_scan;
CELL callframe_end; CELL callframe_end;
/* saved catchstack on entry to callback */ /* saved catchstack on entry to callback */
CELL catch_save; CELL catch_save;
/* saved cards_offset register on entry to callback */ /* saved cards_offset register on entry to callback */
CELL cards_offset; CELL cards_offset;
/* saved extra_roots pointer on entry to callback */
CELL extra_roots;
/* error handler longjmp buffer */ /* error handler longjmp buffer */
JMP_BUF toplevel; JMP_BUF toplevel;

5
vm/types.h
View File

@ -17,11 +17,6 @@ INLINE F_ARRAY* untag_array(CELL tagged)
return untag_array_fast(tagged); return untag_array_fast(tagged);
} }
INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE CELL array_size(CELL size) INLINE CELL array_size(CELL size)
{ {
return sizeof(F_ARRAY) + size * CELLS; return sizeof(F_ARRAY) + size * CELLS;