gcl.git - GNU Common Lisp

diff --git a/gcl/h/object.h b/gcl/h/object.h
index cb8f06615..5eeb3dc1d 100755
--- a/gcl/h/object.h
+++ b/gcl/h/object.h

@@ -77,7 +77,7 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

Definition of the type of LISP objects.

*/

typedef union int_object iobject;

-union int_object {object o; fixnum i;};

+union int_object {object *o; fixnum i;};

#define SMALL_FIXNUM_LIMIT 1024

@@ -337,9 +337,6 @@ EXTER long holepage; /* hole pages */

EXTER long new_holepage,starting_hole_div,starting_relb_heap_mult;

-#ifdef SGC

-EXTER char *old_rb_start; /* read-only relblock start */

-#endif

EXTER char *rb_start; /* relblock start */

EXTER char *rb_end; /* relblock end */

EXTER char *rb_limit; /* relblock limit */

diff --git a/gcl/h/page.h b/gcl/h/page.h
index 83aa6c783..6222ef840 100755
--- a/gcl/h/page.h
+++ b/gcl/h/page.h

@@ -21,9 +21,6 @@

#define PTR_ALIGN SIZEOF_LONG

#endif

-#define ROUND_UP_PTR(n) (((long)(n) + (PTR_ALIGN-1)) & ~(PTR_ALIGN-1))

-#define ROUND_DOWN_PTR(n) (((long)(n) & ~(PTR_ALIGN-1)))

-

/* minimum size required for contiguous pointers */

#if PTR_ALIGN < SIZEOF_CONTBLOCK

#define CPTR_SIZE SIZEOF_CONTBLOCK

@@ -31,9 +28,10 @@

#define CPTR_SIZE PTR_ALIGN

#endif

-#define ROUND_UP_PTR_CONT(n) (((long)(n) + (CPTR_SIZE-1)) & ~(CPTR_SIZE-1))

-#define ROUND_DOWN_PTR_CONT(n) (((long)(n) & ~(CPTR_SIZE-1)))

-

+#define FLR(x,r) (((x))&~(r-1))

+#define CEI(x,r) FLR((x)+(r-1),r)

+#define PFLR(x,r) ((void *)FLR((ufixnum)x,r))

+#define PCEI(x,r) ((void *)CEI((ufixnum)x,r))

#ifdef SGC

@@ -47,13 +45,6 @@

#define SGC_WRITABLE (SGC_PERM_WRITABLE | SGC_PAGE_FLAG)

-#define WRITABLE_PAGE_P(p) IS_WRITABLE(p)

-#define ON_WRITABLE_PAGE(x) WRITABLE_PAGE_P(page(x))

-

-#define IF_WRITABLE(x,if_code) ({if (IS_WRITABLE(page(x))) {if_code;}})/*FIXME maxpage*/

-

-#define sgc_mark_object(x) IF_WRITABLE(x,if(!is_marked(x)) sgc_mark_object1(x))

-

/* When not 0, the free lists in the type manager are freelists

on SGC_PAGE's, for those types supporting sgc.

Marking and sweeping is done specially */

@@ -69,9 +60,6 @@ enum sgc_type { SGC_NORMAL, /* not allocated since the last sgc */

#define TM_BASE_TYPE_P(i) (tm_table[i].tm_type == i)

-/* check if a relblock address is new relblock */

-#define SGC_RELBLOCK_P(x) ((char *)(x) >= rb_start)

-

/* is this an sgc cell? encompasses all free cells. Used where cell cannot yet be marked */

#define SGC_OR_M(x) (!TYPEWORD_TYPE_P(pageinfo(x)->type) ? pageinfo(x)->sgc_flags&SGC_PAGE_FLAG : ((object)x)->d.s)

@@ -107,22 +95,18 @@ extern fixnum writable_pages;

#define CLEAR_WRITABLE(i) set_writable(i,0)

#define SET_WRITABLE(i) set_writable(i,1)

-#define IS_WRITABLE(i) is_writable(i)

+#define WRITABLE_PAGE_P(i) is_writable(i)

+#define ON_WRITABLE_PAGE(x) WRITABLE_PAGE_P(page(x))

+

EXTER long first_data_page,real_maxpage,phys_pages,available_pages;

-EXTER void *data_start;

+EXTER void *data_start,*initial_sbrk;

#if !defined(IN_MAIN) && defined(SGC)

#include "writable.h"

#endif

-#ifdef SGC

-#define REAL_RB_START (sgc_enabled ? old_rb_start : rb_start)

-#else

-#define REAL_RB_START rb_start

-#endif

-

#define CB_BITS CPTR_SIZE*CHAR_SIZE

#define ceil(a_,b_) (((a_)+(b_)-1)/(b_))

#define npage(m_) ceil(m_,PAGESIZE)

diff --git a/gcl/h/writable.h b/gcl/h/writable.h
index 42c68996b..d2c96e2e3 100644
--- a/gcl/h/writable.h
+++ b/gcl/h/writable.h

@@ -4,8 +4,8 @@ set_writable(fixnum i,fixnum m) {

fixnum j;

object v;

- if (i<first_data_page || i>=page(core_end))

- error("out of core in set_writable");

+ if (i<first_data_page || i>=page(heap_end))

+ error("out of heap in set_writable");

if ((v=sSAwritableA ? sSAwritableA->s.s_dbind : Cnil)==Cnil)

error("no wrimap in set_writable");

@@ -36,6 +36,9 @@ is_writable(fixnum i) {

if (i<first_data_page || i>=page(core_end))

return 0;

+ if (i>=page(heap_end))

+ return 1;

+

if ((v=sSAwritableA ? sSAwritableA->s.s_dbind : Cnil)==Cnil)

return 1;

diff --git a/gcl/o/alloc.c b/gcl/o/alloc.c
index 8f8be4305..2c6ff9821 100644
--- a/gcl/o/alloc.c
+++ b/gcl/o/alloc.c

@@ -191,9 +191,7 @@ alloc_page(long n) {

void *e=heap_end;

fixnum d,m;

-#ifdef SGC

- int in_sgc=sgc_enabled;

-#endif

+

if (n>=0) {

if (n>(holepage - (in_signal_handler? 0 :

@@ -217,23 +215,9 @@ eg to add 20 more do (si::set-hole-size %ld %d)\n...start over ",

holepage = d + n;

-#ifdef SGC

- if (in_sgc) sgc_quit();

-#endif

-

GBC(t_relocatable);

tm_table[t_relocatable].tm_adjgbccnt--;/* hole overrun is not a call for more relocatable */

-

-#ifdef SGC

- /* starting sgc can use up some pages

- and may move heap end, so start over

- */

- if (in_sgc) {

- sgc_start();

- return alloc_page(n);

- }

-#endif

}

holepage -= n;

@@ -277,7 +261,7 @@ set_tm_maxpage(struct typemanager *tm,fixnum n) {

fixnum r=tm->tm_type==t_relocatable,j=tm->tm_maxpage,z=(n-j)*(r ? 2 : 1);

if (z>available_pages) return 0;

- if (r && 2*n+page(REAL_RB_START)>real_maxpage) return 0;

+ if (r && 2*n+page(rb_start)>real_maxpage) return 0;

available_pages-=z;

tm->tm_adjgbccnt*=((double)j)/n;

tm->tm_maxpage=n;

@@ -718,7 +702,7 @@ alloc_after_reclaiming_pages(struct typemanager *tm,fixnum n) {

if (tm->tm_type>=t_end) return NULL;

- reloc_min=npage(rb_pointer-REAL_RB_START);

+ reloc_min=npage(rb_pointer-rb_start);

if (m<2*(nrbpage-reloc_min)) {

@@ -790,13 +774,15 @@ alloc_object(enum type t) {

inline void *

alloc_contblock(size_t n) {

- return alloc_mem(tm_of(t_contiguous),ROUND_UP_PTR_CONT(n));

+ return alloc_mem(tm_of(t_contiguous),CEI(n,CPTR_SIZE));

}

inline void *

alloc_relblock(size_t n) {

- return alloc_mem(tm_of(t_relocatable),ROUND_UP_PTR(n));

+ void *p=alloc_mem(tm_of(t_relocatable),CEI(n,PTR_ALIGN));

+ /* allocate_static_promotion_area(); */

+ return p;

}

@@ -930,7 +916,7 @@ insert_contblock(char *p, ufixnum s) {

/* SGC cont pages: allocated sizes may not be zero mod CPTR_SIZE,

e.g. string fillp, but alloc_contblock rounded up the allocation

like this, which we follow here. CM 20030827 */

- cbp->cb_size = ROUND_UP_PTR_CONT(s);

+ cbp->cb_size = CEI(s,CPTR_SIZE);

for (cbpp=&cb_pointer;*cbpp;) {

if ((void *)(*cbpp)+(*cbpp)->cb_size==(void *)cbp) {

@@ -1009,7 +995,7 @@ init_tm(enum type t, char *name, int elsize, int nelts, int sgc,int distinct) {

return;

}

tm_table[(int)t].tm_type = t;

- tm_table[(int)t].tm_size = elsize ? ROUND_UP_PTR(elsize) : 1;

+ tm_table[(int)t].tm_size = elsize ? CEI(elsize,PTR_ALIGN) : 1;

tm_table[(int)t].tm_nppage = (PAGESIZE-sizeof(struct pageinfo))/tm_table[(int)t].tm_size;

tm_table[(int)t].tm_free = OBJNULL;

tm_table[(int)t].tm_nfree = 0;

@@ -1142,6 +1128,7 @@ gcl_init_alloc(void *cs_start) {

#endif

+ initial_sbrk=NULL;

update_real_maxpage();

if (gcl_alloc_initialized) return;

@@ -1602,7 +1589,7 @@ static char *baby_malloc(n)

{

char *res= last_baby;

int m;

- n = ROUND_UP_PTR(n);

+ n = CEI(n,PTR_ALIGN);

m = n+ sizeof(int);

if ((res +m-baby_malloc_data) > sizeof(baby_malloc_data))

{

@@ -1690,11 +1677,11 @@ free(void *ptr) {

for (p = &malloc_list,pp=*p; pp && !endp(pp); p = &((pp)->c.c_cdr),pp=pp->c.c_cdr)

if ((pp)->c.c_car->st.st_self == ptr) {

/* SGC contblock pages: Its possible this is on an old page CM 20030827 */

-#ifdef SGC

- insert_maybe_sgc_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim);

-#else

- insert_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim);

-#endif

+/* #ifdef SGC */

+/* insert_maybe_sgc_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim); */

+/* #else */

+/* insert_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim); */

+/* #endif */

(pp)->c.c_car->st.st_self = NULL;

*p = pp->c.c_cdr;

#ifdef GCL_GPROF

@@ -1755,11 +1742,11 @@ realloc(void *ptr, size_t size) {

for (i = 0; i < size; i++)

x->st.st_self[i] = ((char *)ptr)[i];

/* SGC contblock pages: Its possible this is on an old page CM 20030827 */

-#ifdef SGC

- insert_maybe_sgc_contblock(ptr, j);

-#else

- insert_contblock(ptr, j);

-#endif

+/* #ifdef SGC */

+/* insert_maybe_sgc_contblock(ptr, j); */

+/* #else */

+/* insert_contblock(ptr, j); */

+/* #endif */

return(x->st.st_self);

}

}

diff --git a/gcl/o/bind.c b/gcl/o/bind.c
index 50c0fa8b1..fd5f2b030 100755
--- a/gcl/o/bind.c
+++ b/gcl/o/bind.c

@@ -918,8 +918,8 @@ parse_key_new_new(int n, object *base, struct key *keys, object first, va_list a

/* from here down identical to parse_key_rest */

new = new + n ;

{int j=keys->n;

- object *p= (object *)(keys->defaults);

- while (--j >=0) base[j]=p[j];

+ object **p= (object **)(keys->defaults);

+ while (--j >=0) base[j]=*(p[j]);

}

{if (n==0){ return 0;}

{int allow = keys->allow_other_keys;

@@ -939,7 +939,7 @@ parse_key_new_new(int n, object *base, struct key *keys, object first, va_list a

new = new -2;

k = *new;

while(--i >= 0)

- {if ((*(ke++)).o == k)

+ {if (*(*(ke++)).o == k)

{base[i]= new[1];

n=n-2;

goto top;

@@ -1026,8 +1026,7 @@ parse_key_rest_new(object rest, int n, object *base, struct key *keys, object fi

new = new + n ;

{int j=keys->n;

- object *p= (object *)(keys->defaults);

- while (--j >=0) base[j]=p[j];

+ while (--j >=0) base[j]=*keys->defaults[j].o;

}

{if (n==0){ return 0;}

{int allow = keys->allow_other_keys;

@@ -1047,7 +1046,7 @@ parse_key_rest_new(object rest, int n, object *base, struct key *keys, object fi

new = new -2;

k = *new;

while(--i >= 0)

- {if ((*(ke++)).o == k)

+ {if (*(*(ke++)).o == k)

{base[i]= new[1];

n=n-2;

goto top;

@@ -1066,18 +1065,19 @@ parse_key_rest_new(object rest, int n, object *base, struct key *keys, object fi

return -1;

}}}

+static object foo[2]={Cnil,OBJNULL};

void

set_key_struct(struct key *ks, object data)

{int i=ks->n;

while (--i >=0)

- {ks->keys[i].o = data->cfd.cfd_self[ ks->keys[i].i ];

+ {ks->keys[i].o = data->cfd.cfd_self+ks->keys[i].i;

if (ks->defaults != (void *)Cstd_key_defaults)

{fixnum m=ks->defaults[i].i;

ks->defaults[i].o=

- (m==-2 ? Cnil :

- m==-1 ? OBJNULL :

- data->cfd.cfd_self[m]);}

+ (m==-2 ? foo :

+ m==-1 ? foo+1 :

+ data->cfd.cfd_self+m);}

}}

#undef AUX

diff --git a/gcl/o/funlink.c b/gcl/o/funlink.c
index 5a09d4763..bbb5462ee 100755
--- a/gcl/o/funlink.c
+++ b/gcl/o/funlink.c

@@ -129,7 +129,7 @@ vpush_extend(void *item, object ar)

return(ar->v.v_fillp = ind);}

else

{

- int newdim= ROUND_UP_PTR((2 + (int) (1.3 * ind)));

+ int newdim= CEI((2 + (int) (1.3 * ind)),PTR_ALIGN);

unsigned char *newself;

newself = (void *)alloc_relblock(newdim);

bcopy(ar->ust.ust_self,newself,ind);

diff --git a/gcl/o/gbc.c b/gcl/o/gbc.c
index 06e734baf..369811975 100755
--- a/gcl/o/gbc.c
+++ b/gcl/o/gbc.c

@@ -55,10 +55,6 @@ mark_c_stack(jmp_buf, int, void (*)(void *,void *,int));

static void

mark_contblock(void *, int);

-static void

-mark_object(object);

-

-

/* the following in line definitions seem to be twice as fast (at

least on mc68020) as going to the assembly function calls in bitop.c so

since this is more portable and faster lets use them --W. Schelter

@@ -75,6 +71,31 @@ mark_object(object);

#error Do not recognize CPTR_SIZE

#endif

+void *

+cb_in(void *p) {

+ struct contblock **cbpp;

+ int i;

+

+ for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++) {

+ if ((void *)*cbpp<=p && ((void *)(*cbpp)+(*cbpp)->cb_size) >p)

+ return *cbpp;

+ }

+ return NULL;

+}

+

+int

+cb_print(void) {

+ struct contblock **cbpp;

+ int i;

+

+ for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++) {

+ fprintf(stderr,"%u at %p\n",(*cbpp)->cb_size,*cbpp);

+ fflush(stderr);

+ }

+ fprintf(stderr,"%u blocks\n",i);

+ return 0;

+}

+

#ifdef CONTBLOCK_MARK_DEBUG

int

cb_check(void) {

@@ -300,21 +321,6 @@ enter_mark_origin(object *p) {

}

-inline void

-mark_cons(object x) {

-

- do {

- object d=x->c.c_cdr;

- mark(x);

- mark_object(x->c.c_car);

- x=d;

- if (NULL_OR_ON_C_STACK(x) || is_marked_or_free(x))/*catches Cnil*/

- return;

- } while (cdr_listp(x));

- mark_object(x);

-

-}

-

/* Whenever two arrays are linked together by displacement,

if one is live, the other will be made live */

#define mark_displaced_field(ar) mark_object(ar->a.a_displaced)

@@ -342,11 +348,7 @@ mark_link_array(void *v,void *ve) {

p=(void *)sLAlink_arrayA->s.s_dbind->v.v_self;

pe=(void *)p+sLAlink_arrayA->s.s_dbind->v.v_fillp;

- if (is_marked(sLAlink_arrayA->s.s_dbind) && COLLECT_RELBLOCK_P

-#ifdef SGC

- && (!sgc_enabled || SGC_RELBLOCK_P(sLAlink_arrayA->s.s_dbind->v.v_self))

-#endif

- ) {

+ if (is_marked(sLAlink_arrayA->s.s_dbind) && COLLECT_RELBLOCK_P && (void *)p>=(void *)heap_end) {

fixnum j=rb_pointer1-rb_pointer;

p=(void *)p+j;

pe=(void *)pe+j;

@@ -356,7 +358,7 @@ mark_link_array(void *v,void *ve) {

if (*p>=v && *p<ve) {

massert(!LINK_ARRAY_MARKED(p));

#ifdef SGC

- if(!sgc_enabled || IS_WRITABLE(page(p)))

+ if(!sgc_enabled || WRITABLE_PAGE_P(page(p)))

#endif

MARK_LINK_ARRAY(p);

}

@@ -411,42 +413,89 @@ sweep_link_array(void) {

}

-static void

-mark_object(object x) {

-

- fixnum i,j;

- object *p;

- char *cp;

- enum type tp;

-

- BEGIN:

- /* if the body of x is in the c stack, its elements

- are marked anyway by the c stack mark carefully, and

- if this x is somehow hanging around in a cons that

- should be dead, we dont want to mark it. -wfs

- */

+static inline fixnum

+leaf_bytes(fixnum def_type,object x) {

+

+ switch(def_type ? def_type : x->v.v_elttype){

+ case aet_lf:

+ return sizeof(longfloat)*x->v.v_dim;

+ case aet_bit:

+#define W_SIZE (8*sizeof(fixnum))

+ return sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE);

+ case aet_char:

+ case aet_uchar:

+ return sizeof(char)*x->v.v_dim;

+ case aet_short:

+ case aet_ushort:

+ return sizeof(short)*x->v.v_dim;

+ default:

+ return sizeof(fixnum)*x->v.v_dim;

+ }

+}

+

+ufixnum ncbm,nrbm,ngc_thresh;

+DEFVAR("*LEAF-COLLECTION*",sSAleaf_collectionA,SI,Cnil,"");

+

+#define MARK_LEAF_DATA(a_,b_,c_) mark_leaf_data(a_,(void **)&b_,c_,1)

+#define MARK_LEAF_DATA_ALIGNED(a_,b_,c_,d_) mark_leaf_data(a_,(void **)&b_,c_,d_)

+

+static inline void

+mark_leaf_data(object x,void **pp,ufixnum s,ufixnum r) {

+ void *p=*pp,*e=heap_end;

+ ufixnum rs=(s+(r-1))&(~(r-1));

+ object st=sSAleaf_collectionA->s.s_dbind;

- if (NULL_OR_ON_C_STACK(x) || is_marked_or_free(x))

+ if (p<data_start || p<e ? what_to_collect!=t_contiguous : !COLLECT_RELBLOCK_P)

return;

- tp=type_of(x);

-

- if (tp==t_cons) {

- mark_cons(x);

+ if (st!=Cnil && rs<=st->st.st_dim-st->st.st_fillp && x && x->d.st>=ngc_thresh) {

+ void *dp=PCEI(st->st.st_self+st->st.st_fillp,r);

+ *pp=memcpy(dp,p,s);

+ st->st.st_fillp=dp+s-(void *)st->st.st_self;

+ x->d.st=0;

return;

+ }

+

+ if (x) x->d.st++;

+

+ if (p>=e) {

+ *pp=(void *)copy_relblock(p,s);

+ nrbm+=s+(CEI(nrbm,r)-nrbm);

+ } else {

+ mark_contblock(p,s);

+ ncbm+=s+(CEI(ncbm,r)-ncbm);

}

+}

+

+#define mark_object(x) if (sgc_enabled ? ON_WRITABLE_PAGE(x) : !NULL_OR_ON_C_STACK(x)) mark_object1(x)

+

+static void

+mark_object1(object x) {

+

+ fixnum i,j=0;/*FIXME*/

+

+ if (is_marked_or_free(x))

+ return;

mark(x);

- switch (tp) {

+ switch (type_of(x)) {

+

+ case t_cons:

+ mark_object(x->c.c_car);

+ mark_object(Scdr(x));/*FIXME*/

+ break;

case t_fixnum:

break;

+ case t_bignum:

+ MARK_LEAF_DATA(x,MP_SELF(x),MP_ALLOCATED(x)*MP_LIMB_SIZE);

+ break;

+

case t_ratio:

mark_object(x->rat.rat_num);

- x = x->rat.rat_den;

- goto BEGIN;

+ mark_object(x->rat.rat_den);

case t_shortfloat:

break;

@@ -456,8 +505,7 @@ mark_object(object x) {

case t_complex:

mark_object(x->cmp.cmp_imag);

- x = x->cmp.cmp_real;

- goto BEGIN;

+ mark_object(x->cmp.cmp_real);

case t_character:

break;

@@ -466,13 +514,7 @@ mark_object(object x) {

mark_object(x->s.s_plist);

mark_object(x->s.s_gfdef);

mark_object(x->s.s_dbind);

- if (x->s.s_self == NULL)

- break;

- if (inheap(x->s.s_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(x->s.s_self,x->s.s_fillp);

- } else if (COLLECT_RELBLOCK_P)

- x->s.s_self = copy_relblock(x->s.s_self, x->s.s_fillp);

+ MARK_LEAF_DATA(x,x->s.s_self,x->s.s_fillp);

break;

case t_package:

@@ -481,197 +523,90 @@ mark_object(object x) {

mark_object(x->p.p_shadowings);

mark_object(x->p.p_uselist);

mark_object(x->p.p_usedbylist);

- if (what_to_collect != t_contiguous)

- break;

- if (x->p.p_internal != NULL)

- mark_contblock((char *)(x->p.p_internal),

- x->p.p_internal_size*sizeof(object));

- if (x->p.p_external != NULL)

- mark_contblock((char *)(x->p.p_external),

- x->p.p_external_size*sizeof(object));

+ if (x->p.p_internal)

+ for (i=0;i<x->p.p_internal_size;i++)

+ mark_object(x->p.p_internal[i]);

+ if (x->p.p_external)

+ for (i=0;i<x->p.p_external_size;i++)

+ mark_object(x->p.p_external[i]);

+ MARK_LEAF_DATA(x,x->p.p_internal,x->p.p_internal_size*sizeof(object));

+ MARK_LEAF_DATA(x,x->p.p_external,x->p.p_external_size*sizeof(object));

break;

case t_hashtable:

mark_object(x->ht.ht_rhsize);

mark_object(x->ht.ht_rhthresh);

- if (x->ht.ht_self == NULL)

- break;

- for (i = 0, j = x->ht.ht_size; i < j; i++) {

- mark_object(x->ht.ht_self[i].hte_key);

- mark_object(x->ht.ht_self[i].hte_value);

- }

- if (inheap(x->ht.ht_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)x->ht.ht_self,j*sizeof(struct htent));

- } else if (COLLECT_RELBLOCK_P)

- x->ht.ht_self=(void *)copy_relblock((char *)x->ht.ht_self,j*sizeof(struct htent));;

+ if (x->ht.ht_self)

+ for (i=0;i<x->ht.ht_size;i++) {

+ mark_object(x->ht.ht_self[i].hte_key);

+ mark_object(x->ht.ht_self[i].hte_value);

+ }

+ MARK_LEAF_DATA(x,x->ht.ht_self,x->ht.ht_size*sizeof(*x->ht.ht_self));

break;

case t_array:

- if ((x->a.a_displaced) != Cnil)

- mark_displaced_field(x);

- if (x->a.a_dims != NULL) {

- if (inheap(x->a.a_dims)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank);

- } else if (COLLECT_RELBLOCK_P)

- x->a.a_dims = (int *) copy_relblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank);

- }

- if ((enum aelttype)x->a.a_elttype == aet_ch)

- goto CASE_STRING;

- if ((enum aelttype)x->a.a_elttype == aet_bit)

- goto CASE_BITVECTOR;

- if ((enum aelttype)x->a.a_elttype == aet_object)

- goto CASE_GENERAL;

-

- CASE_SPECIAL:

- cp = (char *)(x->fixa.fixa_self);

- if (cp == NULL)

- break;

- /* set j to the size in char of the body of the array */

-

- switch((enum aelttype)x->a.a_elttype){

-#define ROUND_RB_POINTERS_DOUBLE \

-{int tem = ((long)rb_pointer1) & (sizeof(double)-1); \

- if (tem) \

- { rb_pointer += (sizeof(double) - tem); \

- rb_pointer1 += (sizeof(double) - tem); \

- }}

+ MARK_LEAF_DATA(x,x->a.a_dims,sizeof(int)*x->a.a_rank);

+

+ case t_vector:

+ case t_bitvector:

+

+ switch(j ? j : (enum aelttype)x->v.v_elttype) {

+#define ROUND_RB_POINTERS_DOUBLE \

+ { \

+ rb_pointer=PCEI(rb_pointer,sizeof(double)); \

+ rb_pointer1=PCEI(rb_pointer1,sizeof(double)); \

+ }

case aet_lf:

- j= sizeof(longfloat)*x->lfa.lfa_dim;

- if ((COLLECT_RELBLOCK_P) && !(inheap(cp)))

+ j= sizeof(longfloat)*x->v.v_dim;

+ if ((COLLECT_RELBLOCK_P) && (void *)x->v.v_self>=(void *)heap_end)

ROUND_RB_POINTERS_DOUBLE;/*FIXME gc space violation*/

break;

+ case aet_bit:

+#define W_SIZE (8*sizeof(fixnum))

+ j= sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE);

+ break;

case aet_char:

case aet_uchar:

- j=sizeof(char)*x->a.a_dim;

+ j=sizeof(char)*x->v.v_dim;

break;

case aet_short:

case aet_ushort:

- j=sizeof(short)*x->a.a_dim;

+ j=sizeof(short)*x->v.v_dim;

break;

+ case aet_object:

+ if (x->v.v_displaced->c.c_car==Cnil && x->v.v_self)

+ for (i=0;i<x->v.v_dim;i++)

+ mark_object(x->v.v_self[i]);

default:

- j=sizeof(fixnum)*x->fixa.fixa_dim;}

-

- goto COPY;

-

- CASE_GENERAL:

- p = x->a.a_self;

- if (p == NULL

-#ifdef HAVE_ALLOCA

- || (char *)p >= core_end

-#endif

- )

- break;

- j=0;

- if (x->a.a_displaced->c.c_car == Cnil)

- for (i = 0, j = x->a.a_dim; i < j; i++)

- mark_object(p[i]);

- cp = (char *)p;

- j *= sizeof(object);

- COPY:

- if (inheap(cp)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(cp, j);

- } else if (COLLECT_RELBLOCK_P) {

- if (x->a.a_displaced == Cnil) {

-#ifdef HAVE_ALLOCA

- if (!NULL_OR_ON_C_STACK(cp)) /* only if body of array not on C stack */

-#endif

- x->a.a_self = (object *)copy_relblock(cp, j);

- } else if (x->a.a_displaced->c.c_car == Cnil) {

- i = (long)(object *)copy_relblock(cp, j) - (long)(x->a.a_self);

- adjust_displaced(x, i);

- }

+ j=sizeof(fixnum)*x->v.v_dim;

}

- break;

-

- case t_vector:

- if ((x->v.v_displaced) != Cnil)

- mark_displaced_field(x);

- if ((enum aelttype)x->v.v_elttype == aet_object)

- goto CASE_GENERAL;

- else

- 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 */

- break;

-

- CASE_STRING:

- case t_string:

- if ((x->st.st_displaced) != Cnil)

- mark_displaced_field(x);

- j = x->st.st_dim;

- cp = x->st.st_self;

- if (cp == NULL)

- break;

- COPY_STRING:

- if (inheap(cp)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(cp, j);

- } else if (COLLECT_RELBLOCK_P) {

- if (x->st.st_displaced == Cnil)

- x->st.st_self = copy_relblock(cp, j);

- else if (x->st.st_displaced->c.c_car == Cnil) {

- i = copy_relblock(cp, j) - cp;

- adjust_displaced(x, i);

+

+ case t_string:/*FIXME*/

+ j=j ? j : x->st.st_dim;

+

+ if (x->v.v_displaced->c.c_car==Cnil) {

+ void *p=x->v.v_self;

+ MARK_LEAF_DATA(x,x->v.v_self,j);

+ if (x->v.v_displaced!=Cnil) {

+ j=(void *)x->v.v_self-p;

+ x->v.v_self=p;

+ adjust_displaced(x,j);

}

- }

+ }

+ mark_object(x->v.v_displaced);

break;

- CASE_BITVECTOR:

- case t_bitvector:

- if ((x->bv.bv_displaced) != Cnil)

- mark_displaced_field(x);

- /* We make bitvectors multiple of sizeof(int) in size allocated

- Assume 8 = number of bits in char */

-

-#define W_SIZE (8*sizeof(fixnum))

- j= sizeof(fixnum) *

- ((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE);

- cp = x->bv.bv_self;

- if (cp == NULL)

- break;

- goto COPY_STRING;

-

case t_structure:

- mark_object(x->str.str_def);

- p = x->str.str_self;

- if (p == NULL)

- break;

{

object def=x->str.str_def;

- unsigned char * s_type = &SLOT_TYPE(def,0);

- unsigned short *s_pos= & SLOT_POS(def,0);

- for (i = 0, j = S_DATA(def)->length; i < j; i++)

- if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));

- if (inheap(x->str.str_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)p,S_DATA(def)->size);

- } else if (COLLECT_RELBLOCK_P)

- x->str.str_self = (object *)copy_relblock((char *)p, S_DATA(def)->size);

+ unsigned char *s_type= &SLOT_TYPE(def,0);

+ unsigned short *s_pos= &SLOT_POS(def,0);

+ mark_object(x->str.str_def);

+ if (x->str.str_self)

+ for (i=0,j=S_DATA(def)->length;i<j;i++)

+ if (s_type[i]==0)

+ mark_object(STREF(object,x,s_pos[i]));

+ MARK_LEAF_DATA(x,x->str.str_self,S_DATA(def)->size);

}

break;

@@ -684,12 +619,11 @@ mark_object(object x) {

case smm_probe:

mark_object(x->sm.sm_object0);

mark_object(x->sm.sm_object1);

- if (what_to_collect == t_contiguous &&

- x->sm.sm_fp &&

- x->sm.sm_buffer)

- mark_contblock(x->sm.sm_buffer, BUFSIZ);

+ if (x->sm.sm_fp) {

+ MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ);

+ }

break;

-

+

case smm_synonym:

mark_object(x->sm.sm_object0);

break;

@@ -720,44 +654,21 @@ mark_object(object x) {

}

break;

-#define MARK_CP(a_,b_) {fixnum _t=(b_);if (inheap(a_)) {\

- if (what_to_collect == t_contiguous) mark_contblock((void *)(a_),_t); \

- } else if (COLLECT_RELBLOCK_P) (a_)=(void *)copy_relblock((void *)(a_),_t);}

-

-#define MARK_MP(a_) {if ((a_)->_mp_d) \

- MARK_CP((a_)->_mp_d,(a_)->_mp_alloc*MP_LIMB_SIZE);}

-

case t_random:

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

- MARK_MP(x->rnd.rnd_state._mp_seed);

-#if __GNU_MP_VERSION < 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)

- if (x->rnd.rnd_state._mp_algdata._mp_lc) {

- MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_a);

- if (!x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m2exp) MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m);

- MARK_CP(x->rnd.rnd_state._mp_algdata._mp_lc,sizeof(*x->rnd.rnd_state._mp_algdata._mp_lc));

- }

-#endif

- }

+ MARK_LEAF_DATA_ALIGNED(x,x->rnd.rnd_state._mp_seed->_mp_d,x->rnd.rnd_state._mp_seed->_mp_alloc*MP_LIMB_SIZE,MP_LIMB_SIZE);

break;

case t_readtable:

- if (x->rt.rt_self == NULL)

- break;

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->rt.rt_self),

- RTABSIZE*sizeof(struct rtent));

- for (i = 0; i < RTABSIZE; i++) {

- mark_object(x->rt.rt_self[i].rte_macro);

- if (x->rt.rt_self[i].rte_dtab != NULL) {

- /**/

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->rt.rt_self[i].rte_dtab),

- RTABSIZE*sizeof(object));

- for (j = 0; j < RTABSIZE; j++)

- mark_object(x->rt.rt_self[i].rte_dtab[j]);

- /**/

+ if (x->rt.rt_self)

+ for (i=0;i<RTABSIZE;i++) {

+ mark_object(x->rt.rt_self[i].rte_macro);

+ if (x->rt.rt_self[i].rte_dtab) {

+ for (j=0;j<RTABSIZE;j++)

+ mark_object(x->rt.rt_self[i].rte_dtab[j]);

+ MARK_LEAF_DATA(x,x->rt.rt_self[i].rte_dtab,RTABSIZE*sizeof(object));

+ }

}

- }

+ MARK_LEAF_DATA(x,x->rt.rt_self,RTABSIZE*sizeof(struct rtent));

break;

case t_pathname:

@@ -770,13 +681,9 @@ mark_object(object x) {

break;

case t_closure:

- {

- int i ;

- for (i= 0 ; i < x->cl.cl_envdim ; i++)

- mark_object(x->cl.cl_env[i]);

- if (COLLECT_RELBLOCK_P)

- x->cl.cl_env=(void *)copy_relblock((void *)x->cl.cl_env,x->cl.cl_envdim*sizeof(object));

- }

+ for (i= 0;i<x->cl.cl_envdim;i++)

+ mark_object(x->cl.cl_env[i]);

+ MARK_LEAF_DATA(x,x->cl.cl_env,x->cl.cl_envdim*sizeof(object));

case t_cfun:

case t_sfun:

@@ -789,35 +696,39 @@ mark_object(object x) {

case t_cfdata:

- if (x->cfd.cfd_self != NULL)

- {int i=x->cfd.cfd_fillp;

- while(i-- > 0)

- mark_object(x->cfd.cfd_self[i]);}

- if (what_to_collect == t_contiguous) {

- mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size);

+ if (x->cfd.cfd_self)

+ for (i=0;i<x->cfd.cfd_fillp;i++)

+ mark_object(x->cfd.cfd_self[i]);

+ if (what_to_collect == t_contiguous)

mark_link_array(x->cfd.cfd_start,x->cfd.cfd_start+x->cfd.cfd_size);

- }

+ MARK_LEAF_DATA(NULL,x->cfd.cfd_start,x->cfd.cfd_size);/*Code cannot move*/

break;

- case t_cclosure:

+

+ case t_cclosure:

mark_object(x->cc.cc_name);

mark_object(x->cc.cc_env);

mark_object(x->cc.cc_data);

- if (x->cc.cc_turbo!=NULL) {

- mark_object(*(x->cc.cc_turbo-1));

- if (COLLECT_RELBLOCK_P)

- x->cc.cc_turbo=(void *)copy_relblock((char *)(x->cc.cc_turbo-1),(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object))+sizeof(object);

+ if (x->cc.cc_turbo) {

+ x->cc.cc_turbo--;

+ for (i=0;i<=fix(x->cc.cc_turbo[0]);i++)

+ mark_object(x->cc.cc_turbo[i]);

+ MARK_LEAF_DATA(x,x->cc.cc_turbo,(1+fix(x->cc.cc_turbo[0]))*sizeof(*x->cc.cc_turbo));

+ x->cc.cc_turbo++;

}

break;

case t_spice:

break;

- default:

+

+ default:

#ifdef DEBUG

if (debug)

printf("\ttype = %d\n", type_of(x));

#endif

error("mark botch");

+

}

+

}

static long *c_stack_where;

@@ -826,11 +737,6 @@ void **contblock_stack_list=NULL;

#define PAGEINFO_P(pi) (pi->magic==PAGE_MAGIC && pi->type<=t_contiguous)

-#ifdef SGC

-static void

-sgc_mark_object1(object);

-#endif

-

static void

mark_stack_carefully(void *topv, void *bottomv, int offset) {

@@ -879,13 +785,10 @@ mark_stack_carefully(void *topv, void *bottomv, int offset) {

if (is_marked_or_free(x)) continue;

-#ifdef SGC

- if (sgc_enabled)

- sgc_mark_object(x);

- else

-#endif

- mark_object(x);

+ mark_object(x);

+

}

+

}

@@ -930,10 +833,6 @@ mark_phase(void) {

for (pp = pack_pointer; pp != NULL; pp = pp->p_link)

mark_object((object)pp);

-#ifdef KCLOVM

- if (ovm_process_created)

- mark_all_stacks();

-#endif

#ifdef DEBUG

if (debug) {

@@ -947,18 +846,18 @@ mark_phase(void) {

(int)what_to_collect < (int)t_contiguous) {

*/

- {int size;

+ /* {int size; */

- for (pp = pack_pointer; pp != NULL; pp = pp->p_link) {

- size = pp->p_internal_size;

- if (pp->p_internal != NULL)

- for (i = 0; i < size; i++)

- mark_object(pp->p_internal[i]);

- size = pp->p_external_size;

- if (pp->p_external != NULL)

- for (i = 0; i < size; i++)

- mark_object(pp->p_external[i]);

- }}

+ /* for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { */

+ /* size = pp->p_internal_size; */

+ /* if (pp->p_internal != NULL) */

+ /* for (i = 0; i < size; i++) */

+ /* mark_object(pp->p_internal[i]); */

+ /* size = pp->p_external_size; */

+ /* if (pp->p_external != NULL) */

+ /* for (i = 0; i < size; i++) */

+ /* mark_object(pp->p_external[i]); */

+ /* }} */

/* mark the c stack */

#ifndef N_RECURSION_REQD

@@ -1175,7 +1074,6 @@ contblock_sweep_phase(void) {

int (*GBC_enter_hook)() = NULL;

int (*GBC_exit_hook)() = NULL;

-char *old_rb_start;

/* void */

/* ttss(void) { */

@@ -1202,9 +1100,6 @@ void

GBC(enum type t) {

long i,j;

-#ifdef SGC

- int in_sgc = sgc_enabled;

-#endif

#ifdef DEBUG

int tm=0;

#endif

@@ -1215,6 +1110,10 @@ GBC(enum type t) {

collect_both=1;

t=t_contiguous;

}

+ if (t==t_contiguous)

+ ncbm=0;

+ if (COLLECT_RELBLOCK_P)

+ nrbm=0;

if (in_signal_handler && t == t_relocatable)

error("cant gc relocatable in signal handler");

@@ -1242,9 +1141,6 @@ GBC(enum type t) {

}

t = t_relocatable; gc_time = -1;

-#ifdef SGC

- if(sgc_enabled) sgc_quit();

-#endif

}

@@ -1275,7 +1171,7 @@ GBC(enum type t) {

#ifdef SGC

if(sgc_enabled)

printf("(%ld faulted pages, %ld writable, %ld read only)..",fault_pages,sgc_count_writable(),

- (page(core_end)-first_data_page)-(page(old_rb_start)-page(heap_end))-sgc_count_writable());

+ (page(core_end)-first_data_page)-(page(rb_start)-page(heap_end))-sgc_count_writable());

#endif

fflush(stdout);

}

@@ -1286,14 +1182,10 @@ GBC(enum type t) {

if (COLLECT_RELBLOCK_P) {

- i=rb_pointer-REAL_RB_START+PAGESIZE;/*FIXME*/

+ i=rb_pointer-rb_start+PAGESIZE;/*FIXME*/

-#ifdef SGC

- if (sgc_enabled==0)

-#endif

- rb_start = heap_end + PAGESIZE*holepage;

-

- rb_end = heap_end + (holepage + nrbpage) *PAGESIZE;

+ rb_start = heap_end + PAGESIZE*holepage;

+ rb_end = heap_end + (holepage + nrbpage) *PAGESIZE;

if (rb_start < rb_pointer)

rb_start1 = (char *)

@@ -1326,14 +1218,7 @@ GBC(enum type t) {

#endif

#ifdef SGC

if(sgc_enabled)

- { if (t < t_end && tm_of(t)->tm_sgc == 0)

- {sgc_quit();

- if (sSAnotify_gbcA->s.s_dbind != Cnil)

- {fprintf(stdout, " (doing full gc)");

- fflush(stdout);}

- mark_phase();}

- else

- sgc_mark_phase();}

+ sgc_mark_phase();

else

#endif

mark_phase();

@@ -1366,6 +1251,8 @@ GBC(enum type t) {

if (COLLECT_RELBLOCK_P) {

+ /* sSAstatic_promotion_areaA->s.s_dbind=Cnil; */

+

if (rb_start < rb_start1) {

j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE;

memmove(rb_start,rb_start1,j*PAGESIZE);

@@ -1376,14 +1263,6 @@ GBC(enum type t) {

wrimap=(void *)sSAwritableA->s.s_dbind->v.v_self;

#endif

-#ifdef SGC

- /* we don't know which pages have relblock on them */

- if(sgc_enabled) {

- fixnum i;

- for (i=page(rb_start);i<page(rb_pointer+PAGESIZE-1);i++)

- massert(IS_WRITABLE(i));

- }

-#endif

rb_limit = rb_end - 2*RB_GETA;

}

@@ -1410,6 +1289,54 @@ GBC(enum type t) {

#endif

}

+

+/* { */

+/* static int promoting; */

+/* if (!promoting && promotion_pointer>promotion_pointer1) { */

+/* object *p,st; */

+/* promoting=1; */

+/* st=alloc_simple_string(""); */

+/* for (p=promotion_pointer1;p<promotion_pointer;p++) { */

+/* fixnum j; */

+/* object x=*p; */

+

+/* if (type_of(x)==t_string) */

+

+/* j=x->st.st_dim; */

+

+/* else switch (x->v.v_elttype) { */

+

+/* case aet_lf: */

+/* j=sizeof(longfloat)*x->v.v_dim; */

+/* break; */

+/* case aet_bit: */

+/* #define W_SIZE (8*sizeof(fixnum)) */

+/* j=sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); */

+/* break; */

+/* case aet_char: */

+/* case aet_uchar: */

+/* j=sizeof(char)*x->v.v_dim; */

+/* break; */

+/* case aet_short: */

+/* case aet_ushort: */

+/* j=sizeof(short)*x->v.v_dim; */

+/* break; */

+/* default: */

+/* j=sizeof(fixnum)*x->v.v_dim; */

+/* } */

+

+/* st->st.st_dim=j; */

+/* st->st.st_self=alloc_contblock(st->st.st_dim); */

+/* fprintf(stderr,"Promoting vector leaf bytes %lu at %p, %p -> %p\n",j,x,x->v.v_self,st->st.st_self); */

+/* fflush(stderr); */

+/* memcpy(st->st.st_self,x->v.v_self,st->st.st_dim); */

+/* x->v.v_self=(void *)st->st.st_self; */

+/* } */

+/* promoting=0; */

+/* } */

+/* } */

+

+

#ifdef DEBUG

if (debug) {

for (i = 0, j = 0; i < (int)t_end; i++) {

@@ -1437,11 +1364,6 @@ GBC(enum type t) {

interrupt_enable = TRUE;

-#ifdef SGC

- if (in_sgc && sgc_enabled==0)

- sgc_start();

-#endif

-

if (GBC_exit_hook != NULL)

(*GBC_exit_hook)();

@@ -1468,6 +1390,23 @@ GBC(enum type t) {

}

+ /* {static int mv; */

+ /* if (!mv && COLLECT_RELBLOCK_P) { */

+ /* mv=1; */

+ /* if (relb_copied) { */

+ /* sSAstatic_promotion_areaA->s.s_dbind=(VFUN_NARGS=4,fSmake_vector1(make_fixnum(relb_copied),make_fixnum(aet_char),Ct,make_fixnum(0))); */

+ /* fprintf(stderr,"Making static promotion area %lu bytes\n",relb_copied); */

+ /* fflush(stderr); */

+ /* relb_copied=0; */

+ /* } else { */

+ /* fprintf(stderr,"Releasing static promotion area\n"); */

+ /* fflush(stderr); */

+ /* sSAstatic_promotion_areaA->s.s_dbind=Cnil; */

+ /* } */

+ /* mv=0; */

+ /* } */

+ /* } */

+

collect_both=0;

END_NO_INTERRUPT;

@@ -1570,7 +1509,7 @@ static char *

copy_relblock(char *p, int s)

{ char *res = rb_pointer;

char *q = rb_pointer1;

- s = ROUND_UP_PTR(s);

+ s = CEI(s,PTR_ALIGN);

rb_pointer += s;

rb_pointer1 += s;

@@ -1595,8 +1534,8 @@ mark_contblock(void *p, int s) {

q = p + s;

/* SGC cont pages: contblock pages must be no smaller than

sizeof(struct contblock). CM 20030827 */

- x = (char *)ROUND_DOWN_PTR_CONT(p);

- y = (char *)ROUND_UP_PTR_CONT(q);

+ x = (char *)PFLR(p,CPTR_SIZE);

+ y = (char *)PCEI(q,CPTR_SIZE);

v=get_pageinfo(x);

#ifdef SGC

if (!sgc_enabled || (v->sgc_flags&SGC_PAGE_FLAG))

diff --git a/gcl/o/gmp.c b/gcl/o/gmp.c
index df84d71f0..b86db55f1 100644
--- a/gcl/o/gmp.c
+++ b/gcl/o/gmp.c

@@ -18,12 +18,12 @@ static void *gcl_gmp_realloc(void *oldmem, size_t oldsize, size_t newsize)

MP_SELF(big_gcprotect)=0;

bcopy(old,new,oldsize);

/* SGC contblock pages: Its possible this is on an old page CM 20030827 */

- if (inheap(oldmem))

-#ifdef SGC

- insert_maybe_sgc_contblock(oldmem,oldsize);

-#else

- insert_contblock(oldmem,oldsize);

-#endif

+/* if (inheap(oldmem)) */

+/* #ifdef SGC */

+/* insert_maybe_sgc_contblock(oldmem,oldsize); */

+/* #else */

+/* insert_contblock(oldmem,oldsize); */

+/* #endif */

return new;

}

diff --git a/gcl/o/main.c b/gcl/o/main.c
index 5a6b229ee..0464810ac 100755
--- a/gcl/o/main.c
+++ b/gcl/o/main.c

@@ -209,6 +209,8 @@ get_phys_pages_no_malloc(char freep) {

#endif

+void *initial_sbrk=NULL;

+

int

update_real_maxpage(void) {

@@ -224,6 +226,7 @@ update_real_maxpage(void) {

#endif

massert(cur=sbrk(0));

+ if (!initial_sbrk) initial_sbrk=cur;

beg=data_start ? data_start : cur;

for (i=0,j=(1L<<log_maxpage_bound);j>PAGESIZE;j>>=1)

if ((end=beg+i+j-PAGESIZE)>cur)

@@ -295,23 +298,18 @@ update_real_maxpage(void) {

static int

minimize_image(void) {

-#ifdef SGC

- int in_sgc=sgc_enabled;

-#else

- int in_sgc=0;

-#endif

extern long new_holepage;

fixnum old_holepage=new_holepage,i;

void *new;

- if (in_sgc) sgc_quit();

holepage=new_holepage=1;

GBC(t_relocatable);

- if (in_sgc) sgc_start();

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

+ if (new<initial_sbrk)

+ new=initial_sbrk;

core_end = new;

rb_end=rb_limit=new;

- set_tm_maxpage(tm_table+t_relocatable,(nrbpage=((char *)new-REAL_RB_START)/PAGESIZE));

+ set_tm_maxpage(tm_table+t_relocatable,(nrbpage=((char *)new-rb_start)/PAGESIZE));

new_holepage=old_holepage;

#ifdef GCL_GPROF

@@ -339,7 +337,7 @@ DEFUN_NEW("SET-LOG-MAXPAGE-BOUND",object,fSset_log_maxpage_bound,SI,1,1,NONE,II,

l=l<def ? l : def;

end=data_start+(1L<<l)-PAGESIZE;

GBC(t_relocatable);

- dend=heap_end+PAGESIZE+(((rb_pointer-REAL_RB_START)+PAGESIZE-1)&(-PAGESIZE));

+ dend=heap_end+PAGESIZE+(((rb_pointer-rb_start)+PAGESIZE-1)&(-PAGESIZE));

if (end >= dend) {

minimize_image();

log_maxpage_bound=l;

diff --git a/gcl/o/read.d b/gcl/o/read.d
index f00a77af9..b9bf2b685 100755
--- a/gcl/o/read.d
+++ b/gcl/o/read.d

@@ -2152,7 +2152,8 @@ LFD(Lreadtablep)()

rdtbl->rt.rt_self[c].rte_chattrib

= cat_terminating;

rdtbl->rt.rt_self[c].rte_macro = fnc;

- @(return Ct)

+ SGC_TOUCH(rdtbl);

+ @(return Ct)

@)

@(defun get_macro_character (chr &optional (rdtbl `current_readtable()`))

diff --git a/gcl/o/sgbc.c b/gcl/o/sgbc.c
index 9e0f53a53..9aea46c98 100755
--- a/gcl/o/sgbc.c
+++ b/gcl/o/sgbc.c

@@ -7,9 +7,6 @@

*/

-static void

-sgc_mark_object1(object);

-

#ifdef BSD

/* ulong may have been defined in mp.h but the define is no longer needed */

#undef ulong

@@ -51,81 +48,12 @@ int gclmprotect ( void *addr, size_t len, int prot ) {

#include <signal.h>

-/* void segmentation_catcher(void); */

-

-

-#define sgc_mark_pack_list(u) \

-do {register object xtmp = u; \

- while (xtmp != Cnil) \

- {if (ON_WRITABLE_PAGE(xtmp)) {mark(xtmp);} \

- sgc_mark_object(xtmp->c.c_car); \

- xtmp=Scdr(xtmp);}}while(0)

-

-

#ifdef SDEBUG

object sdebug;

joe1(){;}

joe() {;}

#endif

-/* static void */

-/* sgc_mark_cons(object x) { */

-

-/* cs_check(x); */

-

-/* /\* x is already marked. *\/ */

-

-/* BEGIN: */

-/* #ifdef SDEBUG */

-/* if(x==sdebug) joe1(); */

-/* #endif */

-/* sgc_mark_object(x->c.c_car); */

-/* #ifdef OLD */

-/* IF_WRITABLE(x->c.c_car, goto MARK_CAR;); */

-/* goto MARK_CDR; */

-

-/* MARK_CAR: */

-/* if (!is_marked_or_free(x->c.c_car)) { */

-/* if (consp(x->c.c_car)) { */

-/* mark(x->c.c_car); */

-/* sgc_mark_cons(x->c.c_car); */

-/* } else */

-/* sgc_mark_object1(x->c.c_car);} */

-/* MARK_CDR: */

-/* #endif */

-/* /\* if (is_imm_fixnum(x->c.c_cdr)) return; *\/ */

-/* x = Scdr(x); */

-/* IF_WRITABLE(x, goto WRITABLE_CDR;); */

-/* return; */

-/* WRITABLE_CDR: */

-/* if (is_marked_or_free(x)) return; */

-/* if (consp(x)) { */

-/* mark(x); */

-/* goto BEGIN; */

-/* } */

-/* sgc_mark_object1(x); */

-/* } */

-

-inline void

-sgc_mark_cons(object x) {

-

- do {

- object d=x->c.c_cdr;

- mark(x);

- sgc_mark_object(x->c.c_car);

- x=d;

- if (!IS_WRITABLE(page(x)) || is_marked_or_free(x))/*catches Cnil*/

- return;

- } while (cdr_listp(x));

- sgc_mark_object(x);

-

-}

-

-/* Whenever two arrays are linked together by displacement,

- if one is live, the other will be made live */

-#define sgc_mark_displaced_field(ar) sgc_mark_object(ar->a.a_displaced)

-

-

/* structures and arrays of type t, need to be marked if their

bodies are not write protected even if the headers are.

So we should keep these on pages particular to them.

@@ -134,415 +62,6 @@ sgc_mark_cons(object x) {

This takes only 1.47 as opposed to 1.33 microseconds per set.

*/

static void

-sgc_mark_object1(object x) {

-

- fixnum i,j;

- object *p;

- char *cp;

- enum type tp;

-

- cs_check(x);

- BEGIN:

-#ifdef SDEBUG

- if (x == OBJNULL || !ON_WRITABLE_PAGE(x))

- return;

- IF_WRITABLE(x,goto OK);

- joe();

- OK:

-#endif

- if (is_marked_or_free(x))

- return;

-#ifdef SDEBUG

- if(x==sdebug) joe1();

-#endif

-

- tp=type_of(x);

-

- if (tp==t_cons) {

- sgc_mark_cons(x);

- return;

- }

-

- mark(x);

-

- switch (tp) {

-

- case t_fixnum:

- break;

-

- case t_ratio:

- sgc_mark_object(x->rat.rat_num);

- x = x->rat.rat_den;

- IF_WRITABLE(x,if(!is_marked_or_free(x)) goto BEGIN);

-

- case t_shortfloat:

- break;

-

- case t_longfloat:

- break;

-

- case t_complex:

- sgc_mark_object(x->cmp.cmp_imag);

- x = x->cmp.cmp_real;

- IF_WRITABLE(x,if(!is_marked_or_free(x)) goto BEGIN);

-

- case t_character:

- break;

-

- case t_symbol:

- IF_WRITABLE(x->s.s_plist,if(!is_marked_or_free(x->s.s_plist))

- {/* mark(x->s.s_plist); */

- sgc_mark_cons(x->s.s_plist);});

- sgc_mark_object(x->s.s_gfdef);

- sgc_mark_object(x->s.s_dbind);

- if (x->s.s_self == NULL)

- break;

- /* to do */

- if (inheap(x->s.s_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(x->s.s_self,x->s.s_fillp);

- } else if (SGC_RELBLOCK_P(x->s.s_self) && COLLECT_RELBLOCK_P)

- x->s.s_self = copy_relblock(x->s.s_self, x->s.s_fillp);

- break;

-

- case t_package:

- sgc_mark_object(x->p.p_name);

- sgc_mark_object(x->p.p_nicknames);

- sgc_mark_object(x->p.p_shadowings);

- sgc_mark_object(x->p.p_uselist);

- sgc_mark_object(x->p.p_usedbylist);

- if (what_to_collect == t_contiguous) {

- if (x->p.p_internal != NULL)

- mark_contblock((char *)(x->p.p_internal),

- x->p.p_internal_size*sizeof(object));

- if (x->p.p_external != NULL)

- mark_contblock((char *)(x->p.p_external),

- x->p.p_external_size*sizeof(object));

- }

- break;

-

- case t_hashtable:

- sgc_mark_object(x->ht.ht_rhsize);

- sgc_mark_object(x->ht.ht_rhthresh);

- if (x->ht.ht_self == NULL)

- break;

- for (i = 0, j = x->ht.ht_size; i < j; i++) {

- if (ON_WRITABLE_PAGE(&x->ht.ht_self[i])) {

- sgc_mark_object(x->ht.ht_self[i].hte_key);

- sgc_mark_object(x->ht.ht_self[i].hte_value);

- }

- }

- if (inheap(x->ht.ht_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->ht.ht_self),j * sizeof(struct htent));

- } else if (SGC_RELBLOCK_P(x->ht.ht_self) && COLLECT_RELBLOCK_P)

- x->ht.ht_self=(void *)copy_relblock((char *)x->ht.ht_self,j*sizeof(struct htent));;

- break;

-

- case t_array:

- if ((x->a.a_displaced) != Cnil)

- sgc_mark_displaced_field(x);

- if (x->a.a_dims != NULL) {

- if (inheap(x->a.a_dims)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank);

- } else if (SGC_RELBLOCK_P(x->a.a_dims) && COLLECT_RELBLOCK_P)

- x->a.a_dims = (int *) copy_relblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank);

- }

- if ((enum aelttype)x->a.a_elttype == aet_ch)

- goto CASE_STRING;

- if ((enum aelttype)x->a.a_elttype == aet_bit)

- goto CASE_BITVECTOR;

- if ((enum aelttype)x->a.a_elttype == aet_object)

- goto CASE_GENERAL;

-

- CASE_SPECIAL:

- cp = (char *)(x->fixa.fixa_self);

- if (cp == NULL)

- break;

- /* set j to the size in char of the body of the array */

-

- switch((enum aelttype)x->a.a_elttype){

- case aet_lf:

- j= sizeof(longfloat)*x->lfa.lfa_dim;

- if ((COLLECT_RELBLOCK_P) && !(inheap(cp)) && SGC_RELBLOCK_P(x->a.a_self))

- ROUND_RB_POINTERS_DOUBLE;/*FIXME gc space violation*/

- break;

- case aet_char:

- case aet_uchar:

- j=sizeof(char)*x->a.a_dim;

- break;

- case aet_short:

- case aet_ushort:

- j=sizeof(short)*x->a.a_dim;

- break;

- default:

- j=sizeof(fixnum)*x->fixa.fixa_dim;}

-

- goto COPY;

-

- CASE_GENERAL:

- p = x->a.a_self;

- if (p == NULL

-#ifdef HAVE_ALLOCA

- || (char *)p >= core_end

-#endif

-

- )

- break;

- j=0;

- if (x->a.a_displaced->c.c_car == Cnil)

- for (i = 0, j = x->a.a_dim; i < j; i++)

- if (ON_WRITABLE_PAGE(&p[i]))

- sgc_mark_object(p[i]);

- cp = (char *)p;

- j *= sizeof(object);

- COPY:

- if (inheap(cp)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(cp, j);

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

- if (x->a.a_displaced == Cnil) {

-#ifdef HAVE_ALLOCA

- if (!NULL_OR_ON_C_STACK(cp)) /* only if body of array not on C stack */

-#endif

- x->a.a_self = (object *)copy_relblock(cp, j);

- } else if (x->a.a_displaced->c.c_car == Cnil) {

- i = (long)(object *)copy_relblock(cp, j) - (long)(x->a.a_self);

- adjust_displaced(x, i);

- }

- }

- break;

-

- case t_vector:

- if ((x->v.v_displaced) != Cnil)

- sgc_mark_displaced_field(x);

- if ((enum aelttype)x->v.v_elttype == aet_object)

- goto CASE_GENERAL;

- else

- goto CASE_SPECIAL;

-

- case t_bignum:

-#ifdef SDEBUG

- if (TYPE_MAP(page(x->big.big_self)) < t_contiguous)

- printf("bad body for %x (%x)\n",x,cp);

-#endif

-#ifndef GMP_USE_MALLOC

- j = MP_ALLOCATED(x);

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

- if (cp == 0)

- break;

- j = j * 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);

-#endif /* not GMP_USE_MALLOC */

- break;

-

-

- CASE_STRING:

- case t_string:

- if ((x->st.st_displaced) != Cnil)

- sgc_mark_displaced_field(x);

- j = x->st.st_dim;

- cp = x->st.st_self;

- if (cp == NULL)

- break;

-

- COPY_STRING:

- if (inheap(cp)) {

- if (what_to_collect == t_contiguous)

- mark_contblock(cp, j);

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

- if (x->st.st_displaced == Cnil)

- x->st.st_self = copy_relblock(cp, j);

- else if (x->st.st_displaced->c.c_car == Cnil) {

- i = copy_relblock(cp, j) - cp;

- adjust_displaced(x, i);

- }

- }

- break;

-

- CASE_BITVECTOR:

- case t_bitvector:

- if ((x->bv.bv_displaced) != Cnil)

- sgc_mark_displaced_field(x);

- /* We make bitvectors multiple of sizeof(int) in size allocated

- Assume 8 = number of bits in char */

-

-#define W_SIZE (8*sizeof(fixnum))

- j= sizeof(fixnum) *

- ((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE);

- cp = x->bv.bv_self;

- if (cp == NULL)

- break;

- goto COPY_STRING;

-

- case t_structure:

- sgc_mark_object(x->str.str_def);

- p = x->str.str_self;

- if (p == NULL)

- break;

- {

- object def=x->str.str_def;

- unsigned char *s_type = &SLOT_TYPE(def,0);

- unsigned short *s_pos = &SLOT_POS (def,0);

- for (i = 0, j = S_DATA(def)->length; i < j; i++)

- if (s_type[i]==0 && ON_WRITABLE_PAGE(&STREF(object,x,s_pos[i])))

- sgc_mark_object(STREF(object,x,s_pos[i]));

- if (inheap(x->str.str_self)) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)p,S_DATA(def)->size);

- } else if (SGC_RELBLOCK_P(p) && (COLLECT_RELBLOCK_P))

- x->str.str_self = (object *) copy_relblock((char *)p, S_DATA(def)->size);

- }

- break;

-

- case t_stream:

- switch (x->sm.sm_mode) {

- case smm_input:

- case smm_output:

- case smm_io:

- case smm_socket:

- case smm_probe:

- sgc_mark_object(x->sm.sm_object0);

- sgc_mark_object(x->sm.sm_object1);

- if (what_to_collect == t_contiguous &&

- x->sm.sm_fp &&

- x->sm.sm_buffer)

- mark_contblock(x->sm.sm_buffer, BUFSIZ);

- break;

-

- case smm_synonym:

- sgc_mark_object(x->sm.sm_object0);

- break;

-

- case smm_broadcast:

- case smm_concatenated:

- sgc_mark_object(x->sm.sm_object0);

- break;

-

- case smm_two_way:

- case smm_echo:

- sgc_mark_object(x->sm.sm_object0);

- sgc_mark_object(x->sm.sm_object1);

- break;

-

- case smm_string_input:

- case smm_string_output:

- sgc_mark_object(x->sm.sm_object0);

- break;

-#ifdef USER_DEFINED_STREAMS

- case smm_user_defined:

- sgc_mark_object(x->sm.sm_object0);

- sgc_mark_object(x->sm.sm_object1);

- break;

-#endif

- default:

- error("mark stream botch");

- }

- break;

-

-#define SGC_MARK_CP(a_,b_) {fixnum _t=(b_);if (inheap((a_))) {\

- if (what_to_collect == t_contiguous) mark_contblock((void *)(a_),_t); \

- } else if (SGC_RELBLOCK_P((a_)) && COLLECT_RELBLOCK_P) (a_)=(void *)copy_relblock((void *)(a_),_t);}

-

-#define SGC_MARK_MP(a_) {if ((a_)->_mp_d) SGC_MARK_CP((a_)->_mp_d,(a_)->_mp_alloc*MP_LIMB_SIZE);}

-

- case t_random:

- SGC_MARK_MP(x->rnd.rnd_state._mp_seed);

-#if __GNU_MP_VERSION < 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)

- if (x->rnd.rnd_state._mp_algdata._mp_lc) {

- SGC_MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_a);

- if (!x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m2exp) SGC_MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m);

- SGC_MARK_CP(x->rnd.rnd_state._mp_algdata._mp_lc,sizeof(*x->rnd.rnd_state._mp_algdata._mp_lc));

- }

-#endif

- break;

-

- case t_readtable:

- if (x->rt.rt_self == NULL)

- break;

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->rt.rt_self),RTABSIZE*sizeof(struct rtent));

- for (i = 0; i < RTABSIZE; i++) {

- sgc_mark_object(x->rt.rt_self[i].rte_macro);

- if (x->rt.rt_self[i].rte_dtab != NULL) {

- if (what_to_collect == t_contiguous)

- mark_contblock((char *)(x->rt.rt_self[i].rte_dtab),RTABSIZE*sizeof(object));

- for (j = 0; j < RTABSIZE; j++)

- sgc_mark_object(x->rt.rt_self[i].rte_dtab[j]);

- }

- }

- break;

-

- case t_pathname:

- sgc_mark_object(x->pn.pn_host);

- sgc_mark_object(x->pn.pn_device);

- sgc_mark_object(x->pn.pn_directory);

- sgc_mark_object(x->pn.pn_name);

- sgc_mark_object(x->pn.pn_type);

- sgc_mark_object(x->pn.pn_version);

- break;

-

- case t_closure:

- {

- int i ;

- for (i= 0 ; i < x->cl.cl_envdim ; i++)

- sgc_mark_object(x->cl.cl_env[i]);

- if (SGC_RELBLOCK_P(x->cl.cl_env) && COLLECT_RELBLOCK_P)

- x->cl.cl_env=(void *)copy_relblock((void *)x->cl.cl_env,x->cl.cl_envdim*sizeof(object));

-

- }

-

- case t_cfun:

- case t_sfun:

- case t_vfun:

- case t_afun:

- case t_gfun:

- sgc_mark_object(x->cf.cf_name);

- sgc_mark_object(x->cf.cf_data);

- break;

-

- case t_cfdata:

-

- if (x->cfd.cfd_self != NULL) {

- int i=x->cfd.cfd_fillp;

- while(i-- > 0)

- sgc_mark_object(x->cfd.cfd_self[i]);

- }

- if (what_to_collect == t_contiguous) {

- mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size);

- mark_link_array(x->cfd.cfd_start,x->cfd.cfd_start+x->cfd.cfd_size);

- }

- break;

- case t_cclosure:

- sgc_mark_object(x->cc.cc_name);

- sgc_mark_object(x->cc.cc_env);

- sgc_mark_object(x->cc.cc_data);

- if (x->cc.cc_turbo!=NULL) {

- sgc_mark_object(*(x->cc.cc_turbo-1));

- if (SGC_RELBLOCK_P(x->cc.cc_turbo) && COLLECT_RELBLOCK_P)

- x->cc.cc_turbo=(void *)copy_relblock((char *)(x->cc.cc_turbo-1),(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object))+sizeof(object);

- }

- break;

-

- case t_spice:

- break;

-

- default:

-#ifdef DEBUG

- if (debug)

- printf("\ttype = %d\n", type_of(x));

-#endif

- error("mark botch");

- }

-

-}

-

-static void

sgc_mark_phase(void) {

STATIC fixnum i, j;

@@ -552,8 +71,8 @@ sgc_mark_phase(void) {

STATIC ihs_ptr ihsp;

STATIC struct pageinfo *v;

- sgc_mark_object(Cnil->s.s_plist);

- sgc_mark_object(Ct->s.s_plist);

+ mark_object(Cnil->s.s_plist);

+ mark_object(Ct->s.s_plist);

/* mark all non recent data on writable pages */

{

@@ -571,7 +90,7 @@ sgc_mark_phase(void) {

for (j = tm->tm_nppage; --j >= 0; p += tm->tm_size) {

object x = (object) p;

if (SGC_OR_M(x)) continue;

- sgc_mark_object1(x);

+ mark_object(x);

}

}

}

@@ -595,24 +114,24 @@ sgc_mark_phase(void) {

mark_stack_carefully(MVloc+(sizeof(MVloc)/sizeof(object)),MVloc,0);

for (bdp = bds_org; bdp<=bds_top; bdp++) {

- sgc_mark_object(bdp->bds_sym);

- sgc_mark_object(bdp->bds_val);

+ mark_object(bdp->bds_sym);

+ mark_object(bdp->bds_val);

}

for (frp = frs_org; frp <= frs_top; frp++)

- sgc_mark_object(frp->frs_val);

+ mark_object(frp->frs_val);

for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++)

- sgc_mark_object(ihsp->ihs_function);

+ mark_object(ihsp->ihs_function);

for (i = 0; i < mark_origin_max; i++)

- sgc_mark_object(*mark_origin[i]);

+ mark_object(*mark_origin[i]);

for (i = 0; i < mark_origin_block_max; i++)

for (j = 0; j < mark_origin_block[i].mob_size; j++)

- sgc_mark_object(mark_origin_block[i].mob_addr[j]);

+ mark_object(mark_origin_block[i].mob_addr[j]);

for (pp = pack_pointer; pp != NULL; pp = pp->p_link)

- sgc_mark_object((object)pp);

+ mark_object((object)pp);

#ifdef KCLOVM

if (ovm_process_created)

sgc_mark_all_stacks();

@@ -624,20 +143,6 @@ sgc_mark_phase(void) {

fflush(stdout);

}

#endif

- {

- int size;

-

- for (pp = pack_pointer; pp != NULL; pp = pp->p_link) {

- size = pp->p_internal_size;

- if (pp->p_internal != NULL)

- for (i = 0; i < size; i++)

- sgc_mark_pack_list(pp->p_internal[i]);

- size = pp->p_external_size;

- if (pp->p_external != NULL)

- for (i = 0; i < size; i++)

- sgc_mark_pack_list(pp->p_external[i]);

- }

- }

mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully);

@@ -739,13 +244,6 @@ sgc_contblock_sweep_phase(void) {

}

-

-

-#define PAGE_ROUND_UP(adr) \

- ((char *)(PAGESIZE*(((long)(adr)+PAGESIZE -1) >> PAGEWIDTH)))

-

-/* char *old_rb_start; */

-

#undef tm

#ifdef SDEBUG

@@ -767,7 +265,7 @@ fixnum writable_pages=0;

static fixnum

sgc_count_writable(void) {

- return page(core_end)-page(rb_start)+writable_pages-(page(old_rb_start)-page(heap_end));

+ return page(core_end)-page(rb_start)+writable_pages;

}

@@ -1047,13 +545,24 @@ sgc_start(void) {

object omp=sSAoptimize_maximum_pagesA->s.s_dbind;

double tmp,scale;

+ if (sgc_enabled)

+ return 1;

+

sSAoptimize_maximum_pagesA->s.s_dbind=Cnil;

if (memprotect_result!=memprotect_success && do_memprotect_test())

return 0;

- if (sgc_enabled)

- return 1;

+ {

+ extern ufixnum ngc_thresh,nrbm;

+

+ GBC(t_relocatable);

+ sSAleaf_collectionA->s.s_dbind=(VFUN_NARGS=4,fSmake_vector1(make_fixnum(nrbm),make_fixnum(aet_char),Ct,make_fixnum(0)));/*FIXME*/

+ ngc_thresh=0;

+ GBC(t_relocatable);

+ sSAleaf_collectionA->s.s_dbind=Cnil;

+ massert(rb_pointer==rb_start);

+ }

/* Reset maxpage statistics if not invoked automatically on a hole

overrun. 20040804 CM*/

@@ -1193,26 +702,7 @@ sgc_start(void) {

}

- /* Now allocate the sgc relblock. We do this as the tail

- end of the ordinary rb. */

- {

- char *new;

- tm=tm_of(t_relocatable);

-

- {

- old_rb_start=rb_start;

- if(((unsigned long)WSGC(tm)) && allocate_more_pages) {

- new=alloc_relblock(((unsigned long)WSGC(tm))*PAGESIZE);

- /* the above may cause a gc, shifting the relblock */

- old_rb_start=rb_start;

- new= PAGE_ROUND_UP(new);

- } else new=PAGE_ROUND_UP(rb_pointer);

- rb_start=rb_pointer=new;

- }

- }

- /* the relblock has been allocated */

-

- sSAwritableA->s.s_dbind=fSmake_vector1_1((page(rb_start)-first_data_page),aet_bit,Cnil);

+ sSAwritableA->s.s_dbind=fSmake_vector1_1((page(heap_end)-first_data_page),aet_bit,Ct);

wrimap=(void *)sSAwritableA->s.s_dbind->v.v_self;

/* now move the sgc free lists into place. alt_free should

@@ -1315,11 +805,13 @@ sgc_start(void) {

SET_WRITABLE(i);

}

- for (i=page(heap_end);i<page(old_rb_start);i++)

- SET_WRITABLE(i);

- tm_of(t_relocatable)->tm_alt_npage=page(rb_start)-page(old_rb_start);

- for (i=page(rb_start);i<page(core_end);i++)

+ {

+ object v=sSAwritableA->s.s_dbind;

+ for (i=page(v->v.v_self);i<=page(v->v.v_self+v->v.v_dim-1);i++)

SET_WRITABLE(i);

+ }

+

+ tm_of(t_relocatable)->tm_alt_npage=0;

fault_pages=0;

@@ -1379,7 +871,6 @@ sgc_quit(void) {

wrimap=NULL;

sgc_enabled=0;

- rb_start = old_rb_start;

/* SGC cont pages: restore contblocks, each tmp_cb_pointer coming

from the new list is guaranteed not to be on the old. Need to

@@ -1488,7 +979,6 @@ memprotect_handler(int sig, long code, void *scp, char *addr) {

faddr = addr;

#endif

p = page(faddr);

- /* p = ROUND_DOWN_PAGE_NO(p); */

if (p >= first_protectable_page

&& faddr < (void *)core_end

&& !(WRITABLE_PAGE_P(p))) {

@@ -1560,10 +1050,10 @@ memory_protect(int on) {

INSTALL_MPROTECT_HANDLER;

beg=first_protectable_page;

- writable = IS_WRITABLE(beg);

+ writable = WRITABLE_PAGE_P(beg);

for (i=beg ; ++i<= end; ) {

- if (writable==IS_WRITABLE(i) && i<=end) continue;

+ if (writable==WRITABLE_PAGE_P(i) && i<end) continue;

if (sgc_mprotect(beg,i-beg,writable))

return -1;

diff --git a/gcl/o/unexelf.c b/gcl/o/unexelf.c
index 8df244a65..8a1ced7f8 100755
--- a/gcl/o/unexelf.c
+++ b/gcl/o/unexelf.c

@@ -634,7 +634,7 @@ find_section (char *name, char *section_names, char *file_name, ElfW(Ehdr) *old_

static void

unexec (char *new_name, char *old_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address)

{

- int new_file, old_file, new_file_size;

+ int new_file, old_file;

/* Pointers to the base of the image of the two files. */

caddr_t old_base, new_base;

@@ -654,17 +654,14 @@ unexec (char *new_name, char *old_name, unsigned int data_start, unsigned int bs

/* Point to the section name table in the old file */

char *old_section_names;

- ElfW(Addr) old_bss_addr, new_bss_addr;

- ElfW(Word) old_bss_size, new_data2_size,old_bss_offset;

- ElfW(Off) new_data2_offset;

- ElfW(Addr) new_data2_addr;

+ ElfW(Addr) old_bss_addr, new_bss_addr,new_data2_addr;

+ ElfW(Off) old_bss_size, new_data2_size,old_bss_offset,new_data2_offset,old_file_size,new_file_size;

int n, nn;

int old_bss_index, old_sbss_index;

int old_data_index, new_data2_index;

int old_mdebug_index;

struct stat stat_buf;

- int old_file_size;

/* Open the old file, allocate a buffer of the right size, and read

in the file contents. */