gcl.git - GNU Common Lisp

diff --git a/gcl/cmpnew/gcl_cmpenv.lsp b/gcl/cmpnew/gcl_cmpenv.lsp
index 509d55634..b2191eb58 100755
--- a/gcl/cmpnew/gcl_cmpenv.lsp
+++ b/gcl/cmpnew/gcl_cmpenv.lsp

@@ -366,6 +366,12 @@

(t

(warn "The variable name ~s is not a symbol." var)))))

+(defun mexpand-deftype (tp &aux (l (listp tp))(i (when l (cdr tp)))(tp (if l (car tp) tp)))

+ (when (symbolp tp)

+ (let ((fn (get tp 'si::deftype-definition)))

+ (when fn

+ (apply fn i)))))

+

(defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)

doc form)

(loop

@@ -383,10 +389,8 @@

;;; 20040320 CM

(cmpck (not (consp decl))

"The declaration ~s is illegal." decl)

- (let* ((dtype (car decl)))

-;; Can process user deftypes here in the future -- 20040318 CM

-;; (dft (and (symbolp dtype) (get dtype 'si::deftype-definition)))

-;; (dtype (or (and dft (funcall dft)) dtype)))

+ (let* ((dtype (car decl))

+ (dtype (or (mexpand-deftype dtype) dtype)))

(if (consp dtype)

(let ((stype (car dtype)))

(cmpck (or (not (symbolp stype)) (cdddr dtype)) "The declaration ~s is illegal." decl)

diff --git a/gcl/cmpnew/gcl_cmpeval.lsp b/gcl/cmpnew/gcl_cmpeval.lsp
index bfefe9247..bbc75c006 100755
--- a/gcl/cmpnew/gcl_cmpeval.lsp
+++ b/gcl/cmpnew/gcl_cmpeval.lsp

@@ -180,9 +180,8 @@

(defun result-type-from-args(f args &aux tem)

- (when (and (setq tem (get f 'return-type))

- (not (eq tem '*))

- (not (consp tem)))

+ (when (if (setq tem (get f 'return-type))

+ (and (not (eq tem '*)) (not (consp tem))) t)

(dolist (v '(inline-always inline-unsafe))

(dolist (w (get f v))

(fix-opt w)

@@ -486,19 +485,22 @@

(defun c1structure-ref1 (form name index &aux (info (make-info)))

;;; Explicitly called from c1expr and c1structure-ref.

- (declare (special *aet-types*))

(cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index)))

- (t

- (let* ((sd (get name 'si::s-data))

- (aet-type (aref (si::s-data-raw sd) index))

- )

- (setf (info-type info) (type-filter (aref *aet-types* aet-type)))

- (list 'structure-ref info

- (c1expr* form info)

- (add-symbol name)

- index sd)

-

- ))))

+ ((let* ((sd (get name 'si::s-data))

+ (aet-type (aref (si::s-data-raw sd) index))

+ (sym (find-symbol (si::string-concatenate

+ (or (si::s-data-conc-name sd) "")

+ (car (nth index (si::s-data-slot-descriptions sd))))))

+ (tp (if sym (get-return-type sym) '*))

+ (tp (type-filter (type-and tp (aref *aet-types* aet-type)))))

+

+ (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106

+ '(vector unsigned-char)

+ tp))

+ (list 'structure-ref info

+ (c1expr* form info)

+ (add-symbol name)

+ index sd)))))

(defun coerce-loc-structure-ref (arg type-wanted &aux (form (cdr arg)))

(let* ((sd (fourth form))

diff --git a/gcl/cmpnew/gcl_cmpopt.lsp b/gcl/cmpnew/gcl_cmpopt.lsp
index b6d064953..b4c2c6922 100755
--- a/gcl/cmpnew/gcl_cmpopt.lsp
+++ b/gcl/cmpnew/gcl_cmpopt.lsp

@@ -138,6 +138,9 @@

(get 'system:aset 'inline-unsafe))

(push '(((array string-char) fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)")

(get 'system:aset 'inline-unsafe))

+(push '(((array bit) fixnum fixnum) fixnum #.(flags rfa)

+ "({object _o=(#0);fixnum _i=(#1)+_o->bv.bv_offset;char _c=1<<BIT_ENDIAN(_i&0x7),*_d=_o->bv.bv_self+(_i>>3);bool _b=(#2);if (_b) *_d|=_c; else *_d&=~_c;_b;})")

+ (get 'si::aset 'inline-unsafe))

(push '(((array fixnum) fixnum fixnum) fixnum #.(flags set rfa)"(#0)->fixa.fixa_self[#1]= (#2)")

(get 'system:aset 'inline-unsafe))

(push '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short *)(#0)->ust.ust_self)[#1]=(#2)")

@@ -435,6 +438,8 @@

(get 'aref 'inline-unsafe))

(push '(((array string-char) fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")

(get 'aref 'inline-unsafe))

+(push '(((array bit) fixnum) fixnum #.(flags rfa)"({object _o=(#0);fixnum _i=(#1)+(_o)->bv.bv_offset;(_o->bv.bv_self[_i>>3]>>BIT_ENDIAN(_i&0x7))&0x1;})")

+ (get 'aref 'inline-unsafe))

(push '(((array fixnum) fixnum) fixnum #.(flags rfa)"(#0)->fixa.fixa_self[#1]")

(get 'aref 'inline-unsafe))

(push '(((array unsigned-char) fixnum) fixnum #.(flags rfa)"(#0)->ust.ust_self[#1]")

diff --git a/gcl/cmpnew/gcl_cmptop.lsp b/gcl/cmpnew/gcl_cmptop.lsp
index 6341117fd..c0b490099 100755
--- a/gcl/cmpnew/gcl_cmptop.lsp
+++ b/gcl/cmpnew/gcl_cmptop.lsp

@@ -1457,7 +1457,7 @@

(setf (get 'si::define-structure 't1) 't1define-structure)

(defun t1define-structure (args)

- (maybe-eval t `(si::define-structure ,@args ,(not (maybe-eval nil nil))))

+ (maybe-eval t `(si::define-structure ,@(copy-tree args) ,(not (maybe-eval nil nil))));FIXME

(t1ordinary (cons 'si::define-structure args)))

diff --git a/gcl/cmpnew/gcl_cmptype.lsp b/gcl/cmpnew/gcl_cmptype.lsp
index ef4216147..2f01fca87 100755
--- a/gcl/cmpnew/gcl_cmptype.lsp
+++ b/gcl/cmpnew/gcl_cmptype.lsp

@@ -142,7 +142,9 @@

((eq type1 t) type2)

((eq type2 'object) type1)

((eq type2 t) type1)

- ((consp type1)

+ ((subtypep type2 type1) type2)

+ ((subtypep type1 type2) type1)

+ ((consp type1)

(case (car type1)

(array

(case (cadr type1)

diff --git a/gcl/h/compdefs.h b/gcl/h/compdefs.h
index 79318aa30..d8bcd61ad 100644
--- a/gcl/h/compdefs.h
+++ b/gcl/h/compdefs.h

@@ -114,3 +114,4 @@ stp_ordinary

SIGNED_CHAR(x)

FEerror(x,y...)

FEwrong_type_argument(x,y)

+BIT_ENDIAN(x)

diff --git a/gcl/h/elf64_i386_reloc.h b/gcl/h/elf64_i386_reloc.h
index da0eb478b..d1c03f65c 100644
--- a/gcl/h/elf64_i386_reloc.h
+++ b/gcl/h/elf64_i386_reloc.h

@@ -8,5 +8,6 @@

add_val(where,~0L,s+a);

break;

case R_X86_64_PC32:

+ massert(ovchks(s+a-p,~MASK(32)));

add_val(where,MASK(32),s+a-p);

break;

diff --git a/gcl/h/lu.h b/gcl/h/lu.h
index 054057914..cff9f3ef5 100644
--- a/gcl/h/lu.h
+++ b/gcl/h/lu.h

@@ -94,12 +94,12 @@ struct symbol {

object s_dbind;

void (*s_sfdef) ();

char *s_self;

+ short s_stype;

+ short s_mflag;

int s_fillp;

object s_gfdef;

object s_plist;

object s_hpack;

- short s_stype;

- short s_mflag;

SPAD;

};

@@ -153,10 +153,10 @@ struct array {

short a_rank;

short a_elttype;

object *a_self;

- short a_adjustable;

- short a_offset;

int a_dim;

int *a_dims;

+ short a_adjustable;

+ short a_offset;

SPAD;

};

@@ -169,8 +169,8 @@ struct vector {

short v_hasfillp;

short v_elttype;

object *v_self;

- int v_fillp;

int v_dim;

+ int v_fillp;

short v_adjustable;

short v_offset;

SPAD;

@@ -182,8 +182,8 @@ struct string {

short st_hasfillp;

short st_adjustable;

char *st_self;

- int st_fillp;

int st_dim;

+ int st_fillp;

};

struct ustring {

@@ -192,8 +192,8 @@ struct ustring {

short ust_hasfillp;

short ust_adjustable;

unsigned char *ust_self;

- int ust_fillp;

int ust_dim;

+ int ust_fillp;

};

struct bitvector {

@@ -202,8 +202,8 @@ struct bitvector {

short bv_hasfillp;

short bv_elttype;

char *bv_self;

- int bv_fillp;

int bv_dim;

+ int bv_fillp;

short bv_adjustable;

short bv_offset;

SPAD;

@@ -215,10 +215,10 @@ struct fixarray {

short fixa_rank;

short fixa_elttype;

fixnum *fixa_self;

- short fixa_adjustable;

- short fixa_offset;

int fixa_dim;

int *fixa_dims;

+ short fixa_adjustable;

+ short fixa_offset;

SPAD;

};

@@ -228,10 +228,10 @@ struct sfarray {

short sfa_rank;

short sfa_elttype;

shortfloat *sfa_self;

- short sfa_adjustable;

- short sfa_offset;

int sfa_dim;

int *sfa_dims;

+ short sfa_adjustable;

+ short sfa_offset;

SPAD;

};

@@ -241,10 +241,10 @@ struct lfarray {

short lfa_rank;

short lfa_elttype;

longfloat *lfa_self;

- short lfa_adjustable;

- short lfa_offset;

int lfa_dim;

int *lfa_dims;

+ short lfa_adjustable;

+ short lfa_offset;

SPAD;

};

diff --git a/gcl/h/object.h b/gcl/h/object.h
index f3c37ee2b..6aafa6798 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

@@ -150,6 +150,12 @@ enum aelttype { /* array element type */

#define SET_BV_OFFSET(x,val) ((type_of(x)==t_bitvector ? x->bv.bv_offset = val : \

type_of(x)== t_array ? x->a.a_offset=val : (abort(),0)))

+#if !defined(DOUBLE_BIGENDIAN)

+#define BIT_ENDIAN(a_) (7-(a_))

+#else

+#define BIT_ENDIAN(a_) (a_)

+#endif

+

#define S_DATA(x) ((struct s_data *)((x)->str.str_self))

#define SLOT_TYPE(def,i) (((S_DATA(def))->raw->ust.ust_self[i]))

@@ -306,7 +312,7 @@ EXTER struct typemanager tm_table[ 32 /* (int) t_relocatable */];

*/

EXTER bool prefer_low_mem_contblock;

struct contblock { /* contiguous block header */

- int cb_size; /* size in bytes */

+ ufixnum cb_size; /* size in bytes */

struct contblock

*cb_link; /* contiguous block link */

};

@@ -337,9 +343,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..6e6339257 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,33 +45,25 @@

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

int sgc_on;

+#define SGC_WHOLE_PAGE /* disallow old data on sgc pages*/

+#ifndef SGC_WHOLE_PAGE

/* for the S field of the FIRSTWORD */

enum sgc_type { SGC_NORMAL, /* not allocated since the last sgc */

SGC_RECENT /* allocated since last sgc */

};

-

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

+#endif

#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)

#ifndef SIGPROTV

#define SIGPROTV SIGSEGV

@@ -107,22 +97,20 @@ 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 CACHED_WRITABLE_PAGE_P(i) is_writable_cached(i)

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

+#define ON_WRITABLE_PAGE_CACHED(x) CACHED_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/protoize.h b/gcl/h/protoize.h
index 7b45710d0..7c94fbee4 100644
--- a/gcl/h/protoize.h
+++ b/gcl/h/protoize.h

@@ -7,7 +7,7 @@

/* alloc.c:364:OF */ extern object on_stack_cons (object x, object y); /* (x, y) object x; object y; */

/* alloc.c:376:OF */ extern object fSallocated (object typ); /* (typ) object typ; */

/* alloc.c:401:OF */ extern object fSreset_number_used (object typ); /* (typ) object typ; */

-/* alloc.c:480:OF */ extern void insert_contblock (char *p, int s); /* (p, s) char *p; int s; */

+/* alloc.c:480:OF */ extern void insert_contblock (char *p, ufixnum s); /* (p, s) char *p; int s; */

/* alloc.c:480:OF */ extern void insert_maybe_sgc_contblock (char *p, int s); /* (p, s) char *p; int s; */

/* alloc.c:611:OF */ extern void set_maxpage (void); /* () */

/* alloc.c:635:OF */ extern void gcl_init_alloc (void *); /* () */

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

@@ -1,11 +1,16 @@

+EXTER fixnum last_page;

+EXTER int last_result;

+

EXTER inline int

-set_writable(fixnum i,fixnum m) {

+set_writable(fixnum i,bool m) {

fixnum j;

object v;

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

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

+ last_page=last_result=0;

+

+ 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");

@@ -16,13 +21,13 @@ set_writable(fixnum i,fixnum m) {

if ((void *)wrimap!=(void *)v->v.v_self)

error("set_writable called in gc");

+ writable_pages+=m-((wrimap[j/8]>>(j%8))&0x1);

+

if (m)

wrimap[j/8]|=(1<<(j%8));

else

wrimap[j/8]&=~(1<<(j%8));

- writable_pages+=m ? 1 : -1;

-

return 0;

}

@@ -35,13 +40,24 @@ is_writable(fixnum i) {

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

return 0;

-

+

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

return 1;

-

+

if ((j=i-first_data_page)<0 || j>=v->v.v_dim)

return 1;

-

+

return (wrimap[j/8]>>(j%8))&0x1;

+

+}

+

+EXTER inline int

+is_writable_cached(fixnum i) {

+

+ if (last_page==i)

+ return last_result;

+

+ last_page=i;

+ return last_result=is_writable(i);

}

diff --git a/gcl/lsp/gcl_defstruct.lsp b/gcl/lsp/gcl_defstruct.lsp
index 011b29349..88331f62f 100755
--- a/gcl/lsp/gcl_defstruct.lsp
+++ b/gcl/lsp/gcl_defstruct.lsp

@@ -99,7 +99,10 @@

(setq dont-overwrite t)

)

(t (setf (get access-function 'structure-access)

- (cons (if type type name) offset)))))))

+ (cons (if type type name) offset))

+ (when slot-type

+ (proclaim `(ftype (function (,name) ,slot-type) ,access-function)))

+ )))))

nil))

@@ -569,9 +572,7 @@

(setf (symbol-function predicate)

#'(lambda (x)

(si::structure-subtype-p x name))))

- (setf (get predicate 'compiler::co1)

- 'compiler::co1structure-predicate)

- (setf (get predicate 'struct-predicate) name)

+ (proclaim `(ftype (function (,name) t) ,predicate));FIXME boolean is unboxed

)

) nil)

diff --git a/gcl/o/alloc.c b/gcl/o/alloc.c
index 996718f8a..5cee48b6f 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;

@@ -317,8 +301,11 @@ add_page_to_freelist(char *p, struct typemanager *tm) {

if (sgc_enabled && tm->tm_sgc)

pp->sgc_flags=SGC_PAGE_FLAG;

+

+#ifndef SGC_WHOLE_PAGE

if (TYPEWORD_TYPE_P(pp->type))

x->d.s=(sgc_enabled && tm->tm_sgc) ? SGC_RECENT : SGC_NORMAL;

+#endif

/* array headers must be always writable, since a write to the

body does not touch the header. It may be desirable if there

@@ -410,7 +397,55 @@ grow_linear(fixnum old, fixnum fract, fixnum grow_min, fixnum grow_max,fixnum ma

DEFVAR("*OPTIMIZE-MAXIMUM-PAGES*",sSAoptimize_maximum_pagesA,SI,sLnil,"");

#define OPTIMIZE_MAX_PAGES (sSAoptimize_maximum_pagesA ==0 || sSAoptimize_maximum_pagesA->s.s_dbind !=sLnil)

DEFVAR("*NOTIFY-OPTIMIZE-MAXIMUM-PAGES*",sSAnotify_optimize_maximum_pagesA,SI,sLnil,"");

-#define MMAX_PG(a_) (a_)->tm_maxpage

+#define MMAX_PG(a_) (a_)->tm_maxpage-(a_)->tm_alt_npage

+static int

+rebalance_maxpages(struct typemanager *my_tm,fixnum z) {

+

+ fixnum d;

+ ufixnum i,j;

+

+

+ d=(z-my_tm->tm_maxpage)*(my_tm->tm_type==t_relocatable ? 2 : 1);

+ for (i=t_start,j=0;i<t_other;i++)

+ j+=tm_table[i].tm_maxpage;

+ j+=tm_table[t_relocatable].tm_maxpage;

+

+ if (j+d>phys_pages) {

+

+ ufixnum k=0;

+

+ for (i=t_start;i<t_other;i++)

+ if (tm_table+i!=my_tm)

+ k+=(tm_table[i].tm_maxpage-tm_table[i].tm_npage)*(i==t_relocatable ? 2 : 1);

+

+ if (k<(j+d-phys_pages))

+ return 0;

+

+ for (i=t_start;i<t_other;i++)

+ if (tm_table[i].tm_npage) {

+ if (tm_table+i==my_tm) {

+ massert(set_tm_maxpage(tm_table+i,z));

+ } else {

+ massert(set_tm_maxpage(tm_table+i,tm_table[i].tm_npage+(1.0-(double)(j+d-phys_pages)/k)*(tm_table[i].tm_maxpage-tm_table[i].tm_npage)));

+ }

+ }

+

+ /* for (i=t_start;i<t_other;i++) */

+ /* if (tm_table[i].tm_npage && tm_table[i].tm_npage>((double)phys_pages/(j+d))*(tm_table+i==my_tm ? z : tm_table[i].tm_maxpage)) */

+ /* return 0; */

+ /* for (i=t_start;i<t_other;i++) */

+ /* if (tm_table[i].tm_npage) */

+ /* massert(set_tm_maxpage(tm_table+i,((double)phys_pages/(j+d))*(tm_table+i==my_tm ? z : tm_table[i].tm_maxpage))); */

+

+ return 1;

+

+ } else

+

+ return set_tm_maxpage(my_tm,z);

+

+}

+

+

inline long

opt_maxpage(struct typemanager *my_tm) {

@@ -419,9 +454,6 @@ opt_maxpage(struct typemanager *my_tm) {

struct typemanager *tm,*tme;

long mro=0,tro=0;

- if (phys_pages>0 && page(heap_end)-first_data_page+nrbpage>=phys_pages)

- return 0;

-

if (page(core_end)>0.8*real_maxpage)

return 0;

@@ -442,7 +474,7 @@ opt_maxpage(struct typemanager *my_tm) {

z*=(y-mmax_page)*mmax_page;

z=sqrt(z);

z=z-mmax_page>available_pages ? mmax_page+available_pages : z;

- my_tm->tm_opt_maxpage=(long)z>my_tm->tm_opt_maxpage ? (long)z : my_tm->tm_opt_maxpage;

+ my_tm->tm_opt_maxpage=(long)(z+my_tm->tm_alt_npage)>my_tm->tm_opt_maxpage ? (long)(z+my_tm->tm_alt_npage) : my_tm->tm_opt_maxpage;

if (z<=mmax_page)

return 0;

@@ -452,7 +484,7 @@ opt_maxpage(struct typemanager *my_tm) {

if (sSAnotify_optimize_maximum_pagesA->s.s_dbind!=sLnil)

printf("[type %u max %lu(%lu) opt %lu y %lu(%lu) gbcrat %f sav %f]\n",

my_tm->tm_type,mmax_page,mro,(long)z,(long)y,tro,(my_tm->tm_adjgbccnt-1)/(1+x-0.9*my_tm->tm_adjgbccnt),r);

- return r<=0.95 && set_tm_maxpage(my_tm,z+mro) ? 1 : 0;

+ return r<=0.95 && rebalance_maxpages(my_tm,z+mro+my_tm->tm_alt_npage) ? 1 : 0;

}

@@ -620,7 +652,7 @@ add_pages(struct typemanager *tm,fixnum m) {

nrbpage+=m;

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

- rb_limit=rb_end-2*RB_GETA;

+ rb_limit=rb_end;/* rb_end-2*RB_GETA>rb_pointer+m*PAGESIZE ? rb_end-2*RB_GETA : rb_end; */

alloc_page(-(nrbpage+holepage));

@@ -670,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)) {

@@ -742,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;

}

@@ -856,11 +890,11 @@ DEFUN_NEW("PRINT-FREE-CONTBLOCK-LIST",object,fSprint_free_contblock_list,SI,0,0,

struct contblock *cbp,*cbp1;

for (cbp=cb_pointer;cbp;cbp=cbp->cb_link) {

- printf("%p %d\n",cbp,cbp->cb_size);

+ printf("%p %lu\n",cbp,cbp->cb_size);

for (cbp1=cbp;cbp1;cbp1=cbp1->cb_link)

if ((void *)cbp+cbp->cb_size==(void *)cbp1 ||

(void *)cbp1+cbp1->cb_size==(void *)cbp)

- printf(" adjacent to %p %d\n",cbp1,cbp1->cb_size);

+ printf(" adjacent to %p %lu\n",cbp1,cbp1->cb_size);

}

return Cnil;

@@ -868,7 +902,7 @@ DEFUN_NEW("PRINT-FREE-CONTBLOCK-LIST",object,fSprint_free_contblock_list,SI,0,0,

}

void

-insert_contblock(char *p, int s) {

+insert_contblock(char *p, ufixnum s) {

struct contblock **cbpp, *cbp;

@@ -882,7 +916,7 @@ insert_contblock(char *p, int 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) {

@@ -961,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;

@@ -1102,7 +1136,7 @@ gcl_init_alloc(void *cs_start) {

INIT_ALLOC;

#endif

- data_start=heap_end;

+ initial_sbrk=data_start=heap_end;

first_data_page=page(data_start);

holepage=new_holepage;

@@ -1554,7 +1588,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))

{

@@ -1642,11 +1676,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

@@ -1707,11 +1741,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 6be9f5fef..c75397107 100755
--- a/gcl/o/gbc.c
+++ b/gcl/o/gbc.c

@@ -45,7 +45,7 @@ static void

sgc_mark_phase(void);

static fixnum

-sgc_count_writable(void);

+sgc_count_read_only(void);

#endif

@@ -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,"%lu 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,119 @@ 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);

}

+}

+

+static void mark_object1(object);

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

+

+static inline void

+mark_object_address(object *o,int f) {

+

+ static ufixnum lp;

+ static ufixnum lr;

+

+ ufixnum p=page(o);

+

+ if (lp!=p || !f) {

+ lp=p;

+ lr=sgc_enabled ? WRITABLE_PAGE_P(lp) : 1;

+ }

+

+ if (lr)

+ mark_object(*o);

+

+}

+

+static inline void

+mark_object_array(object *o,object *oe) {

+ int f=0;

+

+ if (o)

+ for (;o<oe;o++,f=1)

+ mark_object_address(o,f);

+

+}

+

+

+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 +535,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 +544,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 +553,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));

+ mark_object_array(x->p.p_internal,x->p.p_internal+x->p.p_internal_size);

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

+ mark_object_array(x->p.p_external,x->p.p_external+x->p.p_external_size);

+ 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++)

+ if (x->ht.ht_self[i].hte_key!=OBJNULL) {

+ mark_object_address(&x->ht.ht_self[i].hte_key,i);

+ mark_object_address(&x->ht.ht_self[i].hte_value,i+1);

+ }

+ 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) {

+

case aet_lf:

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

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

- ROUND_RB_POINTERS_DOUBLE;/*FIXME gc space violation*/

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

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

+ rb_pointer=PCEI(rb_pointer,sizeof(double)); /*FIXME GC space violation*/

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

+ }

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)

+ mark_object_array(x->v.v_self,x->v.v_self+x->v.v_dim);

+

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_address(&STREF(object,x,s_pos[i]),i);

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

}

break;

@@ -684,12 +649,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 +684,20 @@ 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_address(&x->rt.rt_self[i].rte_macro,i);

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

+ mark_object_array(x->rt.rt_self[i].rte_dtab,x->rt.rt_self[i].rte_dtab+RTABSIZE);

+ 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 +710,8 @@ 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));

- }

+ mark_object_array(x->cl.cl_env,x->cl.cl_env+x->cl.cl_envdim);

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

case t_cfun:

case t_sfun:

@@ -789,35 +724,36 @@ 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);

+ mark_object_array(x->cfd.cfd_self,x->cfd.cfd_self+x->cfd.cfd_fillp);

+ 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--;

+ mark_object_array(x->cc.cc_turbo,x->cc.cc_turbo+fix(x->cc.cc_turbo[0]));

+ 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 +762,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 +810,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 +858,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 +871,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

@@ -1163,7 +1087,7 @@ contblock_sweep_phase(void) {

#ifdef DEBUG

if (debug) {

for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link)

- printf("%d-byte contblock\n", cbp->cb_size);

+ printf("%lud-byte contblock\n", cbp->cb_size);

fflush(stdout);

}

#endif

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

int (*GBC_enter_hook)() = NULL;

int (*GBC_exit_hook)() = NULL;

-char *old_rb_start;

/* void */

/* ttss(void) { */

@@ -1202,9 +1125,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 +1135,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 +1166,6 @@ GBC(enum type t) {

}

t = t_relocatable; gc_time = -1;

-#ifdef SGC

- if(sgc_enabled) sgc_quit();

-#endif

}

@@ -1274,8 +1195,9 @@ GBC(enum type t) {

#endif

#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());

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

+ fault_pages,(page(core_end)-first_data_page)-(page(rb_start)-page(heap_end))-sgc_count_read_only(),

+ sgc_count_read_only());

#endif

fflush(stdout);

}

@@ -1286,14 +1208,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 +1244,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 +1277,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 +1289,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 +1315,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 +1390,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 +1416,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 +1535,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,18 +1560,148 @@ 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))

#endif

- set_mark_bits(v,x,y);

+ set_mark_bits(v,x,y);

+ }

+

+DEFUN_NEW("CONTIGUOUS-REPORT",object,fScontiguous_report,SI,1,1,NONE,OO,OO,OO,OO,(void),"") {

+

+ struct contblock **cbpp;

+ struct pageinfo *v;

+ ufixnum i,j;

+ struct typemanager *tm=tm_of(t_cfdata);

+

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

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

+ fprintf(stderr,"\nTotal free %lu in %lu pieces\n\n",i,j);

+

+ for (i=j=0,v=contblock_list_head;v;i+=v->in_use,j++,v=v->next)

+ fprintf(stderr,"%lu pages at %p\n",(unsigned long)v->in_use,v);

+ fprintf(stderr,"\nTotal pages %lu in %lu pieces\n\n",i,j);

+

+ for (i=j=0,v=cell_list_head;v;v=v->next)

+ if (tm->tm_type==v->type) {

+ void *p;

+ ufixnum k;

+ for (p=pagetochar(page(v)),k=0;k<tm->tm_nppage;k++,p+=tm->tm_size) {

+ object o=p;

+ if (!is_free(o) && type_of(o)==t_cfdata && (void *)o->cfd.cfd_start>=data_start) {

+ fprintf(stderr,"%lu code bytes at %p\n",(unsigned long)o->cfd.cfd_size,o->cfd.cfd_start);

+ i+=o->cfd.cfd_size;

+ j++;

+ }

+ }

+ }

+ fprintf(stderr,"\nTotal code bytes %lu in %lu pieces\n",i,j);

+

+ for (i=j=0,v=cell_list_head;v;v=v->next) {

+ struct typemanager *tm=tm_of(v->type);

+ void *p;

+ ufixnum k;

+ for (p=pagetochar(page(v)),k=0;k<tm->tm_nppage;k++,p+=tm->tm_size) {

+ object o=p;

+ void *d=NULL;

+ ufixnum s=0;

+ if (!is_free(o)) {

+ switch (type_of(o)) {

+ case t_array:

+ case t_vector:

+ d=o->a.a_self;

+ s=o->a.a_dim*sizeof(object);

+ break;

+ case t_hashtable:

+ d=o->ht.ht_self;

+ s=o->ht.ht_size*sizeof(object)*2;

+ break;

+ case t_string:

+ case t_symbol:

+ case t_bitvector:

+ d=o->a.a_self;

+ s=o->a.a_dim;

+ break;

+ case t_package:

+ d=o->p.p_external;

+ s=(o->p.p_external_size+o->p.p_internal_size)*sizeof(object);

+ break;

+ case t_bignum:

+ d=o->big.big_mpz_t._mp_d;

+ s=o->big.big_mpz_t._mp_alloc*MP_LIMB_SIZE;

+ break;

+ case t_structure:

+ d=o->str.str_self;

+ s=S_DATA(o->str.str_def)->length*sizeof(object);

+ break;

+ case t_random:

+ d=o->rnd.rnd_state._mp_seed->_mp_d;

+ s=o->rnd.rnd_state._mp_seed->_mp_alloc*MP_LIMB_SIZE;

+ break;

+ case t_cclosure:

+ d=o->cc.cc_turbo;

+ s=fix(o->cc.cc_turbo[-1]);

+ break;

+ case t_cfdata:

+ d=o->cfd.cfd_start;

+ s=o->cfd.cfd_size;

+ break;

+ case t_readtable:

+ d=o->rt.rt_self;

+ s=RTABSIZE*(sizeof(struct rtent));/*FIXME*/

+ break;

+ default:

+ break;

+ }

+ if (d>=data_start && d<(void *)heap_end && s) {

+ fprintf(stderr,"%lu %s bytes at %p\n",s,tm_table[type_of(o)].tm_name,d);

+ i+=s;

+ j++;

+ }

+ }

+ }

+ }

+ fprintf(stderr,"\nTotal leaf bytes %lu in %lu pieces\n",i,j);

+

+ return Cnil;

+

}

-DEFUN_NEW("GBC",object,fLgbc,LISP,1,1,NONE,OO,OO,OO,OO,(object x0),"") {

+DEFUN_NEW("SCALE-HEAP-TO",object,fSscale_heap_to,SI,1,1,NONE,II,OO,OO,OO,(fixnum mem),"") {

+

+ fixnum i;

+ enum type t;

+ double scale;

+

+ for (t=i=0;t<t_other;t++)

+ if (tm_table+t==tm_of(t))

+ i+=tm_table[t].tm_maxpage;

+

+ scale=(double)(mem>>PAGEWIDTH)/i;

+

+ for (t=i=0;t<t_other;t++)

+ if (tm_table+t==tm_of(t)) {

+ if (!set_tm_maxpage(tm_table+t,tm_table[t].tm_maxpage*scale))

+ FEerror("Cannot scale heap",0);

+ if (t<t_relocatable)

+ i+=tm_table[t].tm_maxpage;

+ }

+

+ if ((t=sgc_enabled))

+ sgc_quit();

+ holepage=new_holepage=i;

+ GBC(t_relocatable);

+ if (t)

+ sgc_start();

+ add_pages(tm_table+t_contiguous,tm_table[t_contiguous].tm_maxpage-ncbpage);

+ return (object)mem;

+}

- /* 1 args */

+DEFUN_NEW("GBC",object,fLgbc,LISP,1,1,NONE,OO,OO,OO,OO,(object x0),"") {

+

+ /* 1 args */

if (x0 == Ct)

GBC(t_other);

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 41b4ad972..988b6ee9f 100755
--- a/gcl/o/main.c
+++ b/gcl/o/main.c

@@ -182,25 +182,35 @@ get_phys_pages_no_malloc(void) {

#else

ufixnum

-get_phys_pages_no_malloc(void) {

- int l;

+get_proc_meminfo_value_in_pages(const char *k) {

+ int l,m;

char b[PAGESIZE],*c;

- const char *k="MemTotal:",*f="/proc/meminfo";

- ufixnum res=0,n;

+ ufixnum n;

- if ((l=open(f,O_RDONLY))!=-1) {

- if ((n=read(l,b,sizeof(b)))<sizeof(b) &&

- !(b[n]=0) &&

- (c=strstr(b,k)) &&

- sscanf(c+strlen(k),"%lu",&n)==1)

- res=n;

- close(l);

- }

- return res>>(PAGEWIDTH-10);

+ massert((l=open("/proc/meminfo",O_RDONLY))!=-1);

+ massert((n=read(l,b,sizeof(b)))<sizeof(b));

+ b[n]=0;

+ massert(!close(l));

+ massert((c=strstr(b,k)));

+ c+=strlen(k);

+ massert(sscanf(c,"%lu%n",&n,&m)==1);

+ massert(!strncmp(c+m," kB\n",4));

+ return n>>(PAGEWIDTH-10);

+}

+

+ufixnum

+get_phys_pages_no_malloc(char freep) {

+ return freep ?

+ get_proc_meminfo_value_in_pages("MemFree:")+

+ get_proc_meminfo_value_in_pages("Buffers:")+

+ get_proc_meminfo_value_in_pages("Cached:") :

+ get_proc_meminfo_value_in_pages("MemTotal:");

}

#endif

+void *initial_sbrk=NULL;

+

int

update_real_maxpage(void) {

@@ -225,13 +235,14 @@ update_real_maxpage(void) {

}

massert(!mbrk(cur));

- phys_pages=get_phys_pages_no_malloc();

+ phys_pages=get_phys_pages_no_malloc(0);

#ifdef BRK_DOES_NOT_GUARANTEE_ALLOCATION

if (phys_pages>0 && real_maxpage>phys_pages+page(beg)) real_maxpage=phys_pages+page(beg);

#endif

available_pages=real_maxpage-page(beg);

+

for (i=t_start,j=0;i<t_other;i++) {

k=tm_table[i].tm_maxpage;

if (tm_table[i].tm_type==t_relocatable)

@@ -244,11 +255,40 @@ update_real_maxpage(void) {

available_pages-=resv_pages;

new_holepage=available_pages/starting_hole_div;

- k=available_pages/20;

- j*=starting_relb_heap_mult;

- j=j<k ? j : k;

- if (maxrbpage<j)

- set_tm_maxpage(tm_table+t_relocatable,j);

+

+ if (getenv("GCL_LARGE") && strlen(getenv("GCL_LARGE"))) {

+

+ ufixnum free_phys_pages=get_phys_pages_no_malloc(1);

+

+ fprintf(stderr,"Running large\n");

+ fflush(stderr);

+

+ for (i=t_start,j=0;i<t_relocatable;i++)

+ j+=tm_table[i].tm_npage;

+ j+=tm_table[t_relocatable].tm_npage*2;

+ /* j*=3; */

+

+ if (j<free_phys_pages) {

+ for (i=t_start;i<t_other;i++)/*t_relocatable*/

+ if (tm_table[i].tm_npage)

+ massert(set_tm_maxpage(tm_table+i,((double)free_phys_pages/j)*tm_table[i].tm_npage));

+ /* massert(set_tm_maxpage(tm_table+t_relocatable,((double)free_phys_pages/j)*(j/3))); */

+ }

+

+ new_holepage=0;

+ for (i=t_start;i<t_relocatable;i++)

+ new_holepage+=tm_table[i].tm_maxpage-tm_table[i].tm_npage;

+

+ /* add_pages(tm_table+t_contiguous,4000); */

+

+ }

+

+ /* new_holepage=available_pages/starting_hole_div; */

+ /* k=available_pages/20; */

+ /* j*=starting_relb_heap_mult; */

+ /* j=j<k ? j : k; */

+ /* if (maxrbpage<j) */

+ /* set_tm_maxpage(tm_table+t_relocatable,j); */

return 0;

@@ -257,23 +297,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

@@ -301,7 +336,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/save.c b/gcl/o/save.c
index 08e605eb5..59259f5b0 100755
--- a/gcl/o/save.c
+++ b/gcl/o/save.c

@@ -20,7 +20,8 @@ LFD(Lsave)(void) {

char filename[256];

extern char *kcl_self;

-

+ extern void *initial_sbrk;

+

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

coerce_to_filename(vs_base[0], filename);

@@ -33,7 +34,8 @@ LFD(Lsave)(void) {

raw_image=FALSE;

cs_org=0;

-

+ initial_sbrk=core_end;

+

#ifdef MEMORY_SAVE

MEMORY_SAVE(kcl_self,filename);

#else

diff --git a/gcl/o/sgbc.c b/gcl/o/sgbc.c
index 9e0f53a53..bb82a5726 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 */

{

@@ -563,15 +82,17 @@ sgc_mark_phase(void) {

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

i=page(v);

- if (!WRITABLE_PAGE_P(i)) continue;

+ if (v->sgc_flags&SGC_PAGE_FLAG || !WRITABLE_PAGE_P(i)) continue;

t=v->type;

tm=tm_of(t);

p=pagetochar(i);

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);

+#ifndef SGC_WHOLE_PAGE

+ if (TYPEWORD_TYPE_P(v->type) && x->d.s) continue;

+#endif

+ mark_object1(x);

}

}

}

@@ -595,24 +116,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 +145,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);

@@ -657,9 +164,6 @@ sgc_sweep_phase(void) {

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

- if (!WRITABLE_PAGE_P(page(v)))

- continue;

-

p = pagetochar(page(v));

f = tm->tm_free;

k = 0;

@@ -678,14 +182,18 @@ sgc_sweep_phase(void) {

continue;

}

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

+#ifndef SGC_WHOLE_PAGE

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

continue;

+#endif

/* it is ok to free x */

SET_LINK(x,f);

make_free(x);

+#ifndef SGC_WHOLE_PAGE

if (TYPEWORD_TYPE_P(v->type)) x->d.s = SGC_RECENT;

+#endif

f = x;

k++;

@@ -694,7 +202,7 @@ sgc_sweep_phase(void) {

tm->tm_nfree += k;

v->in_use-=k;

- } else /*non sgc_page */

+ } else if (WRITABLE_PAGE_P(page(v))) /*non sgc_page */

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

x = (object)p;

if (is_marked(x) && !is_free(x)) {

@@ -739,13 +247,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

@@ -763,11 +264,11 @@ sgc_count(object yy) {

fixnum writable_pages=0;

-/* count writable pages excluding the hole */

+/* count read-only pages */

static fixnum

-sgc_count_writable(void) {

+sgc_count_read_only(void) {

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

+ return sgc_enabled ? sSAwritableA->s.s_dbind->v.v_dim-writable_pages : 0;

}

@@ -1031,7 +532,11 @@ memprotect_test_reset(void) {

/* If opt_maxpage is set, add full pages to the sgc set if needed

too. 20040804 CM*/

/* #define FSGC(tm) (tm->tm_type==t_cons ? tm->tm_nppage : (tm->tm_opt_maxpage ? 0 : tm->tm_sgc_minfree)) */

+#ifdef SGC_WHOLE_PAGE

+#define FSGC(tm) tm->tm_nppage

+#else

#define FSGC(tm) (!TYPEWORD_TYPE_P(tm->tm_type) ? tm->tm_nppage : tm->tm_sgc_minfree)

+#endif

DEFVAR("*WRITABLE*",sSAwritableA,SI,Cnil,"");

@@ -1047,13 +552,25 @@ sgc_start(void) {

object omp=sSAoptimize_maximum_pagesA->s.s_dbind;

double tmp,scale;

+ allocate_more_pages=0;

+ 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 +710,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

@@ -1231,12 +729,16 @@ sgc_start(void) {

#endif

if (pageinfo(f)->sgc_flags&SGC_PAGE_FLAG) {

SET_LINK(f,x);

+#ifndef SGC_WHOLE_PAGE

if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_RECENT;

+#endif

x=f;

count++;

} else {

SET_LINK(f,y);

+#ifndef SGC_WHOLE_PAGE

if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_NORMAL;

+#endif

y=f;

}

f=next;

@@ -1315,11 +817,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+CEI(v->bv.bv_offset+v->v.v_dim-1,8*sizeof(fixnum))/(8*sizeof(fixnum)));i++)

SET_WRITABLE(i);

+ }

+

+ tm_of(t_relocatable)->tm_alt_npage=0;

fault_pages=0;

@@ -1363,8 +867,7 @@ sgc_quit(void) {

struct typemanager *tm;

struct contblock *tmp_cb_pointer,*next;

- unsigned long i,j,np;

- char *p;

+ unsigned long i,np;

struct pageinfo *v;

memory_protect(0);

@@ -1379,7 +882,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

@@ -1440,11 +942,13 @@ sgc_quit(void) {

/*FIXME*/

/* remove the recent flag from any objects on sgc pages */

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

+#ifndef SGC_WHOLE_PAGE

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

if (v->type==(tm=tm_of(v->type))->tm_type && TYPEWORD_TYPE_P(v->type) && v->sgc_flags & SGC_PAGE_FLAG)

for (p=pagetochar(page(v)),j=tm->tm_nppage;j>0;--j,p+=tm->tm_size)

- ((object) p)->d.s=SGC_NORMAL;

-

+ ((object) p)->d.s=SGC_NORMAL;

+#endif

+

for (v=contblock_list_head;v;v=v->next)

if (v->sgc_flags&SGC_PAGE_FLAG)

bzero(CB_SGCF_START(v),CB_DATA_START(v)-CB_SGCF_START(v));

@@ -1488,7 +992,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 +1063,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. */