save a stack of pre-initialized bignums - gcl.git - GNU Common Lisp

diff --git a/gcl/h/mp.h b/gcl/h/mp.h
index c4cfb5fae..9704eef1f 100755
--- a/gcl/h/mp.h
+++ b/gcl/h/mp.h

@@ -179,3 +179,5 @@ GEN addss();

gcopy_to_big(_xgen,where); }while(0)

#endif

+

+EXTER void *big_stack1[1024*1024],**big_stack,**big_stacke;

diff --git a/gcl/o/alloc.c b/gcl/o/alloc.c
index 12bb25062..fe7cf18fe 100644
--- a/gcl/o/alloc.c
+++ b/gcl/o/alloc.c

@@ -1083,7 +1083,7 @@ gcl_init_alloc(void) {

init_tm(t_string, "\"STRING", sizeof(struct string), 5461,1,0 );

init_tm(t_array, "aARRAY", sizeof(struct array), 4681,1,0 );

init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 3640,1,0 );

- init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,1,0 );

+ init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,1,1 );

init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio), 170,1,0 );

init_tm(t_shortfloat, "FSHORT-FLOAT",

sizeof(struct shortfloat_struct), 256 ,1,0);

diff --git a/gcl/o/big.c b/gcl/o/big.c
index d66a0020a..16d3e77a0 100755
--- a/gcl/o/big.c
+++ b/gcl/o/big.c

@@ -56,7 +56,6 @@ static void* alloc_contblock_static(size_t n) {return alloc_contblock(n);}

void* (*gcl_gmp_allocfun)(size_t)=FFN(alloc_relblock);

int gmp_relocatable=1;

-

DEFUN_NEW("SET-GMP-ALLOCATE-RELOCATABLE",object,fSset_gmp_allocate_relocatable,SI,1,1,NONE,OO,OO,OO,OO,

(object flag),"Set the allocation to be relocatble ")

{

diff --git a/gcl/o/gbc.c b/gcl/o/gbc.c
index cd7ba40da..3584b00c0 100755
--- a/gcl/o/gbc.c
+++ b/gcl/o/gbc.c

@@ -412,6 +412,23 @@ sweep_link_array(void) {

}

+static inline void

+mark_gmp_big(object x) {

+

+ void *cp;

+ fixnum j;

+

+ if (what_to_collect >= t_contiguous) {

+ if (!(cp = (char *)MP_SELF(x)))

+ return;

+ j = MP_ALLOCATED(x)*MP_LIMB_SIZE;

+ if (inheap(cp)) {

+ if (what_to_collect == t_contiguous)

+ mark_contblock(cp, j);

+ } else if (SGC_RELBLOCK_P(cp) && COLLECT_RELBLOCK_P) {

+ MP_SELF(x) = (void *) copy_relblock(cp, j);}}

+}

+

static void

mark_object(object x) {

@@ -596,28 +613,7 @@ mark_object(object x) {

goto CASE_SPECIAL;

case t_bignum:

-#ifndef GMP_USE_MALLOC

- if ((int)what_to_collect >= (int)t_contiguous) {

- j = MP_ALLOCATED(x);

- cp = (char *)MP_SELF(x);

- if (cp == 0)

- break;

-#ifdef PARI

- if (j != lg(MP(x)) &&

- /* we don't bother to zero this register,

- and its contents may get over written */

- ! (x == big_register_1 &&

- (int)(cp) <= top &&

- (int) cp >= bot))

- printf("bad length 0x%x ",x);

-#endif

- j = j * MP_LIMB_SIZE;

- if (inheap(cp)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(cp, j);

- } else if (COLLECT_RELBLOCK_P) {

- MP_SELF(x) = (void *) copy_relblock(cp, j);}}

-#endif /* not GMP_USE_MALLOC */

+ mark_gmp_big(x);

break;

CASE_STRING:

@@ -1107,10 +1103,11 @@ sweep_phase(void) {

STATIC long j, k;

STATIC object x;

STATIC char *p;

- STATIC struct typemanager *tm;

+ STATIC struct typemanager *tm,*btm=tm_of(t_bignum);

STATIC object f;

STATIC struct pageinfo *v;

-

+

+ big_stack=big_stack1;

for (v=cell_list_head;v;v=v->next) {

tm = tm_of((enum type)v->type);

@@ -1127,6 +1124,12 @@ sweep_phase(void) {

continue;

}

+ if (tm==btm && big_stack<big_stacke/* && type_of(x)==t_bignum*/) {

+ mark_gmp_big(x);

+ *big_stack++=x;

+ continue;

+ }

+

SET_LINK(x,f);

make_free(x);

f = x;

diff --git a/gcl/o/gmp_big.c b/gcl/o/gmp_big.c
index c5507c767..529db288c 100755
--- a/gcl/o/gmp_big.c
+++ b/gcl/o/gmp_big.c

@@ -100,19 +100,56 @@ gcl_init_big1()

{

}

#endif

+void *big_stack1[1024*1024],**big_stack=big_stack1,**big_stacke=big_stack1+sizeof(big_stack1)/sizeof(*big_stack1);

-object

-new_bignum(void)

-{ object ans;

- {BEGIN_NO_INTERRUPT;

- ans = alloc_object(t_bignum);

- MP_SELF(ans) = 0;

- mpz_init(MP(ans));

- END_NO_INTERRUPT;

- }

- return ans;

+

+DEFUN_NEW("ENABLE-BIGSTACK",object,fSenable_bigstack,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {

+ if (x==Cnil) {

+ big_stacke=big_stack=big_stack1;

+ RETURN1(x);

+ }

+ big_stacke=big_stack1+sizeof(big_stack1)/sizeof(*big_stack1);

+ RETURN1(Ct);

+}

+

+

+static inline object

+get_bignum(__mpz_struct *u) {

+

+ object x;

+

+ if (big_stack>big_stack1) {

+ x=*--big_stack;

+ if (u) mpz_set(MP(x),u);

+ } else {

+ x=alloc_object(t_bignum);

+ if (u)

+ mpz_init_set(MP(x),u);

+ else

+ mpz_init(MP(x));

+ }

+ return x;

+

+}

+

+

+inline object

+new_bignum(void) {

+ return get_bignum(NULL);

}

+/* object */

+/* new_bignum(void) */

+/* { object ans; */

+/* {BEGIN_NO_INTERRUPT; */

+/* ans = alloc_object(t_bignum); */

+/* MP_SELF(ans) = 0; */

+/* mpz_init(MP(ans)); */

+/* END_NO_INTERRUPT; */

+/* } */

+/* return ans; */

+/* } */

+

/* we have to store the body of a u in a bignum object

so that the garbage collecter will move it and save

it, and then we can copy it back

@@ -124,13 +161,17 @@ new_bignum(void)

#define GC_PROTECTED_SELF (__u)->_mp_d

#define END_GCPROTECT (__u)->_mp_d = 0

-static object

+

+static inline object

make_bignum(__mpz_struct *u) {

- object ans=alloc_object(t_bignum);

- mpz_init_set(MP(ans),u);

- return ans;

+ return get_bignum(u);

}

+ /* object ans=alloc_object(t_bignum); */

+ /* mpz_init_set(MP(ans),u); */

+ /* return ans; */

+

+

/* static object */

/* make_bignum(__mpz_struct *u) */

/* { object ans ; */

diff --git a/gcl/o/main.c b/gcl/o/main.c
index c64fc39dd..eb2c644f9 100755
--- a/gcl/o/main.c
+++ b/gcl/o/main.c

@@ -211,7 +211,9 @@ minimize_image(void) {

if (in_sgc) sgc_quit();

holepage=new_holepage=1;

+ big_stacke=big_stack1;/*FIXME*/

GBC(t_relocatable);

+ big_stacke=big_stack1+sizeof(big_stack1)/sizeof(*big_stack1);

if (in_sgc) sgc_start();

new = (void *)(((((ufixnum)rb_pointer)+ PAGESIZE-1)/PAGESIZE)*PAGESIZE);

core_end = new;

diff --git a/gcl/o/sgbc.c b/gcl/o/sgbc.c
index 525fff939..c35d39d9a 100755
--- a/gcl/o/sgbc.c
+++ b/gcl/o/sgbc.c

@@ -659,7 +659,7 @@ sgc_sweep_phase(void) {

STATIC long j, k;

STATIC object x;

STATIC char *p;

- STATIC struct typemanager *tm;

+ STATIC struct typemanager *tm,*btm=tm_of(t_bignum);

STATIC object f;

int size;

STATIC struct pageinfo *v;

@@ -692,6 +692,12 @@ sgc_sweep_phase(void) {

if (TYPEWORD_TYPE_P(pageinfo(x)->type) && x->d.s == SGC_NORMAL)

continue;

+ if (tm==btm && big_stack<big_stacke/* && type_of(x)==t_bignum*/) {

+ mark_gmp_big(x);

+ *big_stack++=x;

+ continue;

+ }

+

/* it is ok to free x */

SET_LINK(x,f);