[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Gcl-devel] Two word cons
|
From: |
Camm Maguire |
|
Subject: |
Re: [Gcl-devel] Two word cons |
|
Date: |
19 May 2005 23:46:27 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.2 |
Greetings, and thanks for the feedback!
"Paul F. Dietz" <address@hidden> writes:
> Camm,
>
> Judging by the space allocation numbers from TIME, objects
> are also constrained to be an even number of words in Allegro CL
> and in SBCL. I think this is a common idea.
>
> If you have an extra field in some objects, consider uses for
> it. For example, we might want to precompute a hash key
> for symbols (based on the package and symbol-name) if we're not
> doing this already. This could speed up SXHASH and EQ/EQL hash tables,
> as well as CASE forms on symbols (switch on the hash key).
>
Great ideas! Do I take it that you feel such a change (along the
lines described below) is beneficial on both 32bit and 64bit machines?
Am I missing anything key/important in the design considerations?
Bob, and Warren, I have a preliminary patch which now seems stable as
tested in GCL proper and in acl2 2.9.1. Preliminary patch included
below against 2.6.6. Am building a gcl-2.6.6twc debian package at your
site for usual installation. Please test -- any feedback most
appreciated. Especially on whether this need be rolled into a
production stable GCL soon or can wait for the 2.7 series, i.e. how
helpful is it to you, if at all.
=============================================================================
266twc.p:
=============================================================================
Index: cmpnew/gcl_cmplam.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmplam.lsp,v
retrieving revision 1.1.2.3.4.1
diff -u -r1.1.2.3.4.1 gcl_cmplam.lsp
--- cmpnew/gcl_cmplam.lsp 14 Jul 2004 18:31:31 -0000 1.1.2.3.4.1
+++ cmpnew/gcl_cmplam.lsp 20 May 2005 03:29:31 -0000
@@ -97,7 +97,7 @@
(si:putprop 'make-dclosure 'wt-make-dclosure 'wt-loc)
(defun wt-make-dclosure (cfun clink)clink ;;Dbase=base0
- (wt-nl "(DownClose"cfun".t=t_dclosure,DownClose" cfun ".dc_self=LC" cfun","
+ (wt-nl "(set_type_of(&DownClose"cfun",t_dclosure),DownClose" cfun
".dc_self=LC" cfun","
"DownClose" cfun ".dc_env=base0,(object)&DownClose" cfun ")"))
(defun wfs-error ()
Index: h/object.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/object.h,v
retrieving revision 1.18.4.1.2.1.2.5.6.1
diff -u -r1.18.4.1.2.1.2.5.6.1 object.h
--- h/object.h 5 Aug 2004 22:31:39 -0000 1.18.4.1.2.1.2.5.6.1
+++ h/object.h 20 May 2005 03:29:33 -0000
@@ -30,7 +30,11 @@
#define TRUE 1 /* boolean true value */
#define FALSE 0 /* boolean false value */
-#define FIRSTWORD unsigned char t,flag; char s,m
+#ifdef LITTLE_END
+#define FIRSTWORD char e:1,m:1,f:1,z:5;unsigned char t,flag; char s
+#else
+#define FIRSTWORD char s; unsigned char flag,t;char z:5,f:1,m:1,e:1;
+#endif
#define NBPP 4 /* number of bytes per pointer */
@@ -126,6 +130,7 @@
struct longfloat_struct {
FIRSTWORD;
longfloat LFVAL; /* longfloat value */
+ object pad;
};
#define Mlf(obje) (obje)->LF.LFVAL
#define lf(x) Mlf(x)
@@ -162,6 +167,7 @@
/* must be an integer */
object rat_num; /* numerator */
/* must be an integer */
+ object pad;
};
struct complex {
@@ -170,6 +176,7 @@
/* must be a number */
object cmp_imag; /* imaginary part */
/* must be a number */
+ object pad;
};
struct character {
@@ -195,12 +202,12 @@
stp_special /* special */
};
-#define Cnil ((object)&Cnil_body)
-#define Ct ((object)&Ct_body)
-#define sLnil Cnil
-#define sLt Ct
+/* #define Cnil ((object)&Cnil_body) */
+/* #define Ct ((object)&Ct_body) */
+
+/* #define Cnil ((object)&(CnilCt+1)) */
+/* #define Ct ((object)&(CnilCt+1+sizeof(struct
symbol))) */
-#define NOT_SPECIAL ((void (*)())Cnil)
#define s_fillp st_fillp
#define s_self st_self
@@ -224,9 +231,20 @@
short s_stype; /* symbol type */
/* of enum stype */
short s_mflag; /* macro flag */
+ object pad;
};
EXTER
-struct symbol Cnil_body, Ct_body;
+/* struct symbol Cnil_body, Ct_body; */
+char CnilCt[3*sizeof(struct symbol)+1];
+/*FIXME -- these need to be constant initializers, e.g. in s_my_dot*/
+
+#define Cnil ((object)(CnilCt))
+#define Ct ((object)(CnilCt+sizeof(struct symbol)))
+#define Dotnil ((object)(CnilCt+2*sizeof(struct symbol)))
+#define sLnil Cnil
+#define sLt Ct
+
+#define NOT_SPECIAL ((void (*)())Cnil)
struct package {
FIRSTWORD;
@@ -245,6 +263,7 @@
int p_external_fp; /* [rough] number of symbols */
struct package
*p_link; /* package link */
+ object pad;
};
/*
@@ -261,7 +280,7 @@
EXTER struct package *pack_pointer; /* package pointer */
struct cons {
- FIRSTWORD;
+/* FIRSTWORD; */
object c_cdr; /* cdr */
object c_car; /* car */
};
@@ -287,6 +306,8 @@
int ht_size; /* hash table size */
short ht_test; /* key test function */
/* of enum httest */
+ short pad1;
+ object pad;
};
enum aelttype { /* array element type */
@@ -313,6 +334,7 @@
short a_offset; /* bitvector offset */
int a_dim; /* dimension */
int *a_dims; /* table of dimensions */
+ object pad;
};
@@ -331,6 +353,7 @@
int v_dim; /* dimension */
short v_adjustable; /* adjustable flag */
short v_offset; /* not used */
+ object pad;
};
struct string { /* string header */
@@ -387,6 +410,7 @@
short bv_offset; /* bitvector offset */
/* the position of the first bit */
/* in the first byte */
+ object pad;
};
struct fixarray { /* fixnum array header */
@@ -399,6 +423,7 @@
short fixa_offset; /* not used */
int fixa_dim; /* dimension */
int *fixa_dims; /* table of dimensions */
+ object pad;
};
@@ -414,6 +439,7 @@
int sfa_dim; /* dimension */
int *sfa_dims; /* table of dimensions */
+ object pad;
@@ -430,6 +456,7 @@
short lfa_offset; /* not used */
int lfa_dim; /* dimension */
int *lfa_dims; /* table of dimensions */
+ object pad;
};
@@ -438,6 +465,7 @@
FIRSTWORD;
object str_def; /* structure definition (a structure) */
object *str_self; /* structure self */
+ object pad;
};
struct s_data {object name;
@@ -591,6 +619,7 @@
object pn_name; /* name */
object pn_type; /* type */
object pn_version; /* version */
+ object pad;
};
struct cfun { /* compiled function header */
@@ -610,6 +639,7 @@
/* for GBC */
int cc_envdim;
object *cc_turbo; /* turbo charger */
+ object pad;
};
struct closure {
@@ -628,6 +658,7 @@
object (*sfn_self)(); /* C start address of code */
object sfn_data; /* To object holding VV vector */
int sfn_argd; /* description of args + number */
+ object pad;
};
@@ -638,6 +669,7 @@
object vfn_data; /* To object holding VV data */
unsigned short vfn_minargs; /* Min args and where varargs start */
unsigned short vfn_maxargs; /* Max number of args */
+ object pad;
};
struct cfdata {
FIRSTWORD;
@@ -645,6 +677,7 @@
int cfd_size; /* size of contblock */
int cfd_fillp; /* size of self */
object *cfd_self; /* body */
+ object pad;
};
struct spice {
@@ -657,6 +690,7 @@
*/
struct dummy {
FIRSTWORD;
+/* char s:1,z1:7,z2,z3,z4; */
};
/*
@@ -725,13 +759,13 @@
#define SET_LINK(x,val) F_LINK(x) = (address_int) (val)
#define OBJ_LINK(x) ((object) INT_TO_ADDRESS(F_LINK(x)))
-#define FREE (-1) /* free object */
+/* #define FREE (-1) */ /* free object */
/*
Type_of.
*/
-#define type_of(obje) ((enum type)(((object)(obje))->d.t))
-
+#define type_of(x) ((((object)x)==Cnil || ((object)x)==Ct ||
((object)x)==Dotnil) ? t_symbol : (!((object)x)->d.e ? t_cons :
((object)x)->d.t))/* ((enum type)(((object)(obje))->d.t)) */
+#define set_type_of(x,y) if ((y)!=t_cons)
{((object)x)->d.e=1;((object)x)->d.t=(y);} else ((object)x)->d.e=0
/*
Storage manager for each type.
*/
@@ -1025,11 +1059,11 @@
EXTER unsigned plong signals_allowed, signals_pending ;
-EXTER struct symbol Dotnil_body;
-#define Dotnil ((object)&Dotnil_body)
+/* EXTER struct symbol Dotnil_body; */
+/* #define Dotnil ((object)&Dotnil_body) */
#define endp(x) ({\
- static struct cons s_my_dot={t_cons,0,0,0,Dotnil,Dotnil};\
+ static struct cons s_my_dot={/* t_cons,0,0,0,0,0, */Dotnil,Dotnil};\
object _x=(x);\
bool _b=FALSE;\
\
Index: h/page.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/page.h,v
retrieving revision 1.4.4.2.2.3.4.1
diff -u -r1.4.4.2.2.3.4.1 page.h
--- h/page.h 14 Jul 2004 20:48:23 -0000 1.4.4.2.2.3.4.1
+++ h/page.h 20 May 2005 03:29:33 -0000
@@ -82,9 +82,9 @@
/* for the S field of the FIRSTWORD */
-enum sgc_type { SGC_NORMAL, /* not allocated since the last sgc */
- SGC_RECENT /* allocated since last sgc */
- };
+enum sgc_type { SGC_NORMAL, /* not allocated since the last sgc */
+ SGC_RECENT /* allocated since last sgc */
+ };
#define TM_BASE_TYPE_P(i) (((int) (tm_table[i].tm_type)) == i)
@@ -103,8 +103,9 @@
/* the following assumes that the char s,m fields of first word
have same length as a short
(x->d.m || x->d.s) would be an equivalent for our purposes */
-struct sgc_firstword {short t; short sm;};
-#define SGC_OR_M(x) (((struct sgc_firstword *)(x))->sm)
+/* struct sgc_firstword {short t; short sm;}; */
+/* #define SGC_OR_M(x) (((struct sgc_firstword *)(x))->sm) */
+#define SGC_OR_M(x) (((object)x)->d.m || ((object)x)->d.f ||
(!((object)x)->d.e && ON_SGC_PAGE(x)) || (((object)x)->d.e && ((object)x)->d.s))
#ifndef SIGPROTV
#define SIGPROTV SIGSEGV
Index: o/alloc.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/alloc.c,v
retrieving revision 1.19.4.1.2.17.2.1.4.1.2.2.4.2
diff -u -r1.19.4.1.2.17.2.1.4.1.2.2.4.2 alloc.c
--- o/alloc.c 16 Jan 2005 02:29:09 -0000 1.19.4.1.2.17.2.1.4.1.2.2.4.2
+++ o/alloc.c 20 May 2005 03:29:37 -0000
@@ -179,13 +179,14 @@
size=tm->tm_size;
f=tm->tm_free;
x= (object)p;
- x->d.t=t;
- x->d.m=FREE;
+/* x->d.t=t; */
+ set_type_of(x,t);
+ x->d.f=1;
#ifdef SGC
if (sgc_enabled && tm->tm_sgc)
- {x->d.s=SGC_RECENT;
+ {if (x->d.e) x->d.s=SGC_RECENT;
sgc_type_map[np] = (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);}
- else x->d.s = SGC_NORMAL;
+ else {if (x->d.e) x->d.s = SGC_NORMAL;}
/* array headers must be always writable, since a write to the
body does not touch the header. It may be desirable if there
@@ -359,8 +360,10 @@
tm->tm_free = OBJ_LINK(obj);
--(tm->tm_nfree);
(tm->tm_nused)++;
- obj->d.t = (short)t;
- obj->d.m = FALSE;
+/* obj->d.t = (short)t; */
+ set_type_of(obj,t);
+ obj->d.f = 0;
+ if (((unsigned long)obj)&0x7) error("foo\n");
return(obj);
#ifdef SGC
#define TOTAL_THIS_TYPE(tm) \
@@ -432,10 +435,12 @@
tm->tm_free = OBJ_LINK(obj);
--(tm->tm_nfree);
(tm->tm_nused)++;
- obj->c.t = (short)t_cons;
- obj->c.m = FALSE;
+/* obj->c.t = (short)t_cons; */
+ set_type_of(obj,t_cons);
+ obj->d.f = 0;
obj->c.c_car = a;
obj->c.c_cdr = d;
+ if (((unsigned long)obj)&0x7) error("foo\n");
return(obj);
CALL_GBC:
@@ -474,10 +479,12 @@
object on_stack_cons(object x, object y)
{object p = (object) alloca_val;
- p->c.t= (short)t_cons;
- p->c.m=FALSE;
+/* p->c.t= (short)t_cons; */
+ set_type_of(p,t_cons);
+ p->d.f=0;
p->c.c_car=x;
p->c.c_cdr=y;
+ if (((unsigned long)p)&0x7) error("foo\n");
return p;
}
@@ -947,9 +954,9 @@
Gave each page type at least some sgc pages by default. Of
course changeable by allocate-sgc. CM 20030827 */
+ init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50,0 );
init_tm(t_fixnum, "NFIXNUM",
sizeof(struct fixnum_struct), 8192,20,0);
- init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50,0 );
init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 5461,1,0 );
init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 4096,1,0 );
init_tm(t_sfun, "gSFUN", sizeof(struct sfun),409,1,0 );
@@ -1547,25 +1554,25 @@
#endif
{
- object *p;
+ object *p,pp;
if (ptr == 0)
return;
#ifdef BABY_MALLOC_SIZE
if ((void *)ptr < (void *) &baby_malloc_data[sizeof(baby_malloc_data)])
return;
#endif
- for (p = &malloc_list; *p && !endp(*p); p = &((*p)->c.c_cdr))
- if ((*p)->c.c_car->st.st_self == ptr) {
+ for (p = &malloc_list,pp=*p,((object)&pp)->d.m=0; *p && !endp(pp); p =
&((pp)->c.c_cdr),pp=*p,((object)&pp)->d.m=0)
+ 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((*p)->c.c_car->st.st_self,
- (*p)->c.c_car->st.st_dim);
+ insert_maybe_sgc_contblock((pp)->c.c_car->st.st_self,
+ (pp)->c.c_car->st.st_dim);
#else
- insert_contblock((*p)->c.c_car->st.st_self,
- (*p)->c.c_car->st.st_dim);
+ insert_contblock((pp)->c.c_car->st.st_self,
+ (pp)->c.c_car->st.st_dim);
#endif
- (*p)->c.c_car->st.st_self = NULL;
- *p = (*p)->c.c_cdr;
+ (pp)->c.c_car->st.st_self = NULL;
+ *p = (pp)->c.c_cdr;
#ifdef GCL_GPROF
if (initial_monstartup_pointer==ptr) {
initial_monstartup_pointer=NULL;
Index: o/array.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/array.c,v
retrieving revision 1.20.4.1.4.4.2.2
diff -u -r1.20.4.1.4.4.2.2 array.c
--- o/array.c 8 Jun 2004 19:34:03 -0000 1.20.4.1.4.4.2.2
+++ o/array.c 20 May 2005 03:29:37 -0000
@@ -754,12 +754,14 @@
/* add diff to body of x and arrays diisplaced to it */
void
-adjust_displaced(object x, long diff)
-{
- if (x->ust.ust_self != NULL)
- x->ust.ust_self = (char *)((long)(x->a.a_self) + diff);
- for (x = Mcdr(x->ust.ust_displaced); x != Cnil; x = Mcdr(x))
- adjust_displaced(Mcar(x), diff);
+adjust_displaced(object x, long diff) {
+
+ ((object)&x)->d.m=0;
+ if (x->ust.ust_self != NULL)
+ x->ust.ust_self = (char *)((long)(x->a.a_self) + diff);
+ for (x = Mcdr(x->ust.ust_displaced),((object)&x)->d.m=0; x != Cnil; x =
Mcdr(x),((object)&x)->d.m=0)
+ adjust_displaced(Mcar(x), diff);
+
}
Index: o/cfun.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/cfun.c,v
retrieving revision 1.5.6.2
diff -u -r1.5.6.2 cfun.c
--- o/cfun.c 6 Nov 2003 16:16:50 -0000 1.5.6.2
+++ o/cfun.c 20 May 2005 03:29:37 -0000
@@ -56,7 +56,7 @@
{object sfn;
sfn = alloc_object(t_sfun);
- if(argd >15) sfn->d.t = (int)t_gfun;
+ if(argd >15) {set_type_of(sfn,t_gfun);}/* sfn->d.t = (int)t_gfun; */
sfn->sfn.sfn_self = self;
sfn->sfn.sfn_name = name;
sfn->sfn.sfn_data = data;
Index: o/character.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/character.d,v
retrieving revision 1.5.4.1.4.2
diff -u -r1.5.4.1.4.2 character.d
--- o/character.d 6 Nov 2003 16:16:50 -0000 1.5.4.1.4.2
+++ o/character.d 20 May 2005 03:29:38 -0000
@@ -581,17 +581,24 @@
int i;
for (i = 0; i < CHCODELIM; i++) {
- character_table[i].t = (short)t_character;
- character_table[i].ch_code = i;
- character_table[i].ch_font = 0;
- character_table[i].ch_bits = 0;
+ object x=(object)(character_table+i);
+ set_type_of(x,t_character);
+/* character_table[i].t = (short)t_character; */
+ x->ch.ch_code = i;
+ x->ch.ch_font = 0;
+ x->ch.ch_bits = 0;
}
#ifdef AV
for (i = -128; i < 0; i++) {
- character_table[i].t = (short)t_character;
- character_table[i].ch_code = i+CHCODELIM;
- character_table[i].ch_font = 0;
- character_table[i].ch_bits = 0;
+ object x=(object)(character_table+i);
+ set_type_of(x,t_character);
+ x->ch.ch_code = i+CHCODELIM;
+ x->ch.ch_font = 0;
+ x->ch.ch_bits = 0;
+/* character_table[i].t = (short)t_character; */
+/* character_table[i].ch_code = i+CHCODELIM; */
+/* character_table[i].ch_font = 0; */
+/* character_table[i].ch_bits = 0; */
}
#endif
Index: o/fat_string.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/fat_string.c,v
retrieving revision 1.14.4.2.2.3
diff -u -r1.14.4.2.2.3 fat_string.c
--- o/fat_string.c 4 Mar 2004 19:35:55 -0000 1.14.4.2.2.3
+++ o/fat_string.c 20 May 2005 03:29:38 -0000
@@ -194,7 +194,7 @@
type_of(x)!=t_vfun &&
type_of(x)!=t_gfun
) continue;
- if ((x->d.m == FREE) || x->cf.cf_self == NULL)
+ if ((x->d.f) || x->cf.cf_self == NULL)
continue;
/* the cdefn things are the proclaimed call types. */
cf_addr=(char * ) ((unsigned long)(x->cf.cf_self));
Index: o/gbc.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/gbc.c,v
retrieving revision 1.13.4.2.2.11.4.1.2.1
diff -u -r1.13.4.2.2.11.4.1.2.1 gbc.c
--- o/gbc.c 5 Aug 2004 22:31:39 -0000 1.13.4.2.2.11.4.1.2.1
+++ o/gbc.c 20 May 2005 03:29:38 -0000
@@ -168,7 +168,7 @@
#endif
-#define symbol_marked(x) ((x)->d.m)
+/* #define symbol_marked(x) ((x)->d.m) */
object *mark_origin[MARK_ORIGIN_MAX];
int mark_origin_max;
@@ -219,22 +219,23 @@
BEGIN:
if (NULL_OR_ON_C_STACK(x->c.c_car)) goto MARK_CDR;
if (type_of(x->c.c_car) == t_cons) {
- if (x->c.c_car->c.m)
+ if (x->c.c_car->d.m)
;
else {
- x->c.c_car->c.m = TRUE;
+ x->c.c_car->d.m = 1;
mark_cons(x->c.c_car);
}
} else
mark_object(x->c.c_car);
MARK_CDR:
x = x->c.c_cdr;
+ ((object)&x)->d.m=0;
if (NULL_OR_ON_C_STACK(x))
return;
if (type_of(x) == t_cons) {
- if (x->c.m)
+ if (x->d.m)
return;
- x->c.m = TRUE;
+ x->d.m = 1;
goto BEGIN;
}
if (x == Cnil)
@@ -264,9 +265,9 @@
if (NULL_OR_ON_C_STACK(x))
return;
- if (x->d.m)
+ if (x->d.m || x->d.f)
return;
- x->d.m = TRUE;
+ x->d.m = 1;
switch (type_of(x)) {
case t_fixnum:
break;
@@ -678,7 +679,7 @@
static void
mark_stack_carefully(void *topv, void *bottomv, int offset) {
- long m,pageoffset;
+ long pageoffset;
unsigned long p;
object x;
struct typemanager *tm;
@@ -708,14 +709,15 @@
((pageoffset=((char *)*j - pagetochar(p))) %
tm->tm_size));
if ((pageoffset < (tm->tm_size * tm->tm_nppage))
- && (m=x->d.m) != FREE) {
- if (m==TRUE) continue;
- if (m!=0) {
- fprintf(stdout,
- "**bad value %ld of d.m in gbc page %ld skipping mark**"
- ,m,p);fflush(stdout);
- continue;
- }
+ && !x->d.f && !x->d.m) {
+/* && (m=x->d.f) != FREE) { */
+/* if (m & TRUE) continue; */
+/* if (m!=0) { */
+/* fprintf(stdout, */
+/* "**bad value %ld of d.m in gbc page %ld skipping mark**" */
+/* ,m,p);fflush(stdout); */
+/* continue; */
+/* } */
mark_object(x);
}
}
@@ -964,10 +966,10 @@
k = 0;
for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
x = (object)p;
- if (x->d.m == FREE)
+ if (x->d.f)
continue;
else if (x->d.m) {
- x->d.m = FALSE;
+ x->d.m = 0;
continue;
}
/* Since we now mark forwards and backwards on displaced
@@ -985,12 +987,12 @@
/* ((struct freelist *)x)->f_link = f; */
#ifdef GMP_USE_MALLOC
- if (x->d.t == t_bignum) {
+ if (type_of(x) == t_bignum/* x->d.t == t_bignum */) {
mpz_clear(MP(x));
}
#endif
SET_LINK(x,f);
- x->d.m = FREE;
+ x->d.f = 1;
f = x;
k++;
}
Index: o/gcl_readline.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/gcl_readline.d,v
retrieving revision 1.1.2.6
diff -u -r1.1.2.6 gcl_readline.d
--- o/gcl_readline.d 9 Mar 2004 02:15:42 -0000 1.1.2.6
+++ o/gcl_readline.d 20 May 2005 03:29:38 -0000
@@ -140,7 +140,11 @@
if (temp==temp1)
package=(temp[1]==':') ? sLApackageA->s.s_dbind : keyword_package;
else {
- struct string s={t_string,0,0,0,OBJNULL,1,0,(char *)temp1,temp-temp1};
+ struct string s;/* ={t_string,0,0,0,1,0,OBJNULL,1,0,(char
*)temp1,temp-temp1}; */
+ set_type_of(&s,t_string);
+ s.st_self=(char *)temp1;
+ s.st_fillp=s.st_dim=temp-temp1;
+ s.st_hasfillp=1;
package=find_package((object)&s);
}
}
Index: o/list.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/list.d,v
retrieving revision 1.19.4.1.4.2
diff -u -r1.19.4.1.4.2 list.d
--- o/list.d 6 Nov 2003 16:16:50 -0000 1.19.4.1.4.2
+++ o/list.d 20 May 2005 03:29:38 -0000
@@ -251,8 +251,8 @@
p=(struct cons *) res;
if (n<=0) return Cnil;
TOP:
- p->t = (int)t_cons;
- p->m=FALSE;
+/* p->t = (int)t_cons; */
+/* p->m=FALSE; */
p->c_car= jj ? va_arg(ap,object) : first;
jj=1;
if (--n == 0)
@@ -333,14 +333,14 @@
{if (i < n)
tail->c.c_cdr=OBJ_LINK(tail);
else {tm->tm_free=OBJ_LINK(tail);
- tail->d.t = (int)t_cons;
+ set_type_of(tail,t_cons);/* tail->d.t = (int)t_cons; */
tail->d.m = FALSE;
tail->c.c_car=va_arg(ap,object);
tail->c.c_cdr=Cnil;
goto END_INTER ;
}
/* these could be one instruction*/
- tail->d.t = (int)t_cons;
+ set_type_of(tail,t_cons);/* tail->d.t = (int)t_cons; */
tail->d.m=FALSE;
tail->c.c_car=va_arg(ap,object);
tail=tail->c.c_cdr;
@@ -865,8 +865,8 @@
struct cons *p = (struct cons *)res;
if (n<=0) return Cnil;
TOP:
- p->t = (int)t_cons;
- p->m=FALSE;
+/* p->t = (int)t_cons; */
+/* p->m=FALSE; */
p->c_car=Cnil;
if (--n == 0)
{p->c_cdr = Cnil;
Index: o/main.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/main.c,v
retrieving revision 1.26.4.1.2.21.6.1
diff -u -r1.26.4.1.2.21.6.1 main.c
--- o/main.c 5 Aug 2004 22:26:48 -0000 1.26.4.1.2.21.6.1
+++ o/main.c 20 May 2005 03:29:39 -0000
@@ -459,38 +459,47 @@
}
gcl_init_alloc();
- Dotnil_body.t = (short)t_symbol;
- Dotnil_body.s_dbind = Dotnil;
- Dotnil_body.s_sfdef = NOT_SPECIAL;
- Dotnil_body.s_fillp = 6;
- Dotnil_body.s_self = "DOTNIL";
- Dotnil_body.s_gfdef = OBJNULL;
- Dotnil_body.s_plist = Cnil;
- Dotnil_body.s_hpack = Cnil;
- Dotnil_body.s_stype = (short)stp_constant;
- Dotnil_body.s_mflag = FALSE;
+/* set_type_of(Dotnil,t_symbol); */
+/* Dotnil_body.t = (short)t_symbol; */
+/* Dotnil_body.e = 1; */
+ Dotnil->c.c_cdr=Dotnil;
+ Dotnil->s.s_dbind = Dotnil;
+ Dotnil->s.s_sfdef = NOT_SPECIAL;
+ Dotnil->s.s_fillp = 6;
+ Dotnil->s.s_self = "DOTNIL";
+ Dotnil->s.s_gfdef = OBJNULL;
+ Dotnil->s.s_plist = Cnil;
+ Dotnil->s.s_hpack = Cnil;
+ Dotnil->s.s_stype = (short)stp_constant;
+ Dotnil->s.s_mflag = FALSE;
- Cnil_body.t = (short)t_symbol;
- Cnil_body.s_dbind = Cnil;
- Cnil_body.s_sfdef = NOT_SPECIAL;
- Cnil_body.s_fillp = 3;
- Cnil_body.s_self = "NIL";
- Cnil_body.s_gfdef = OBJNULL;
- Cnil_body.s_plist = Cnil;
- Cnil_body.s_hpack = Cnil;
- Cnil_body.s_stype = (short)stp_constant;
- Cnil_body.s_mflag = FALSE;
+/* set_type_of(Cnil,t_symbol); */
+/* Cnil_body.t = (short)t_symbol; */
+/* Cnil_body.e = 1; */
+ Cnil->c.c_cdr=Cnil;
+ Cnil->s.s_dbind = Cnil;
+ Cnil->s.s_sfdef = NOT_SPECIAL;
+ Cnil->s.s_fillp = 3;
+ Cnil->s.s_self = "NIL";
+ Cnil->s.s_gfdef = OBJNULL;
+ Cnil->s.s_plist = Cnil;
+ Cnil->s.s_hpack = Cnil;
+ Cnil->s.s_stype = (short)stp_constant;
+ Cnil->s.s_mflag = FALSE;
- Ct_body.t = (short)t_symbol;
- Ct_body.s_dbind = Ct;
- Ct_body.s_sfdef = NOT_SPECIAL;
- Ct_body.s_fillp = 1;
- Ct_body.s_self = "T";
- Ct_body.s_gfdef = OBJNULL;
- Ct_body.s_plist = Cnil;
- Ct_body.s_hpack = Cnil;
- Ct_body.s_stype = (short)stp_constant;
- Ct_body.s_mflag = FALSE;
+/* set_type_of(Ct,t_symbol); */
+/* Ct_body.t = (short)t_symbol; */
+/* Ct_body.e = 1; */
+ Ct->c.c_cdr=Ct;
+ Ct->s.s_dbind = Ct;
+ Ct->s.s_sfdef = NOT_SPECIAL;
+ Ct->s.s_fillp = 1;
+ Ct->s.s_self = "T";
+ Ct->s.s_gfdef = OBJNULL;
+ Ct->s.s_plist = Cnil;
+ Ct->s.s_hpack = Cnil;
+ Ct->s.s_stype = (short)stp_constant;
+ Ct->s.s_mflag = FALSE;
gcl_init_symbol();
Index: o/num_log.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/num_log.c,v
retrieving revision 1.9.4.1.4.2
diff -u -r1.9.4.1.4.2 num_log.c
--- o/num_log.c 6 Nov 2003 16:16:52 -0000 1.9.4.1.4.2
+++ o/num_log.c 20 May 2005 03:29:39 -0000
@@ -637,7 +637,7 @@
b=(object)p;
for (b1=b,i=0;i<x->a.a_rank;i++,b1=b1->c.c_cdr) {
- b1->d.t=(int)t_cons;
+ set_type_of(b1,t_cons); /* b1->d.t=(int)t_cons; */
b1->d.m=FALSE;
b1->c.c_car=/* x->a.a_dims[i]<SMALL_FIXNUM_LIMIT ? */
/* small_fixnum(x->a.a_dims[i]) : */
Index: o/number.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/number.c,v
retrieving revision 1.9.4.1.4.1
diff -u -r1.9.4.1.4.1 number.c
--- o/number.c 14 Sep 2003 02:30:45 -0000 1.9.4.1.4.1
+++ o/number.c 20 May 2005 03:29:39 -0000
@@ -289,9 +289,12 @@
int i;
for (i = -SMALL_FIXNUM_LIMIT; i < SMALL_FIXNUM_LIMIT; i++) {
- small_fixnum_table[i + SMALL_FIXNUM_LIMIT].t
- = (short)t_fixnum;
- small_fixnum_table[i + SMALL_FIXNUM_LIMIT].FIXVAL = i;
+ object x=(object)(small_fixnum_table+i+SMALL_FIXNUM_LIMIT);
+ set_type_of(x,t_fixnum);
+ x->FIX.FIXVAL=i;
+/* small_fixnum_table[i + SMALL_FIXNUM_LIMIT].t */
+/* = (short)t_fixnum; */
+/* small_fixnum_table[i + SMALL_FIXNUM_LIMIT].FIXVAL = i; */
}
shortfloat_zero = alloc_object(t_shortfloat);
Index: o/print.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/print.d,v
retrieving revision 1.15.4.1.2.2.12.1
diff -u -r1.15.4.1.2.2.12.1 print.d
--- o/print.d 15 Jan 2005 20:27:49 -0000 1.15.4.1.2.2.12.1
+++ o/print.d 20 May 2005 03:29:40 -0000
@@ -605,7 +605,7 @@
write_str("#<OBJNULL>");
return;
}
- if (x->d.m == FREE) {
+ if (x->d.f) {
write_str("#<FREE OBJECT ");
write_addr(x);
write_str(">");
Index: o/sequence.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sequence.d,v
retrieving revision 1.3.4.1.4.2
diff -u -r1.3.4.1.4.2 sequence.d
--- o/sequence.d 6 Nov 2003 16:16:53 -0000 1.3.4.1.4.2
+++ o/sequence.d 20 May 2005 03:29:40 -0000
@@ -28,7 +28,11 @@
#undef endp
-#define endp(obje) ((enum type)((endp_temp = (obje))->d.t) ==
t_cons ? \
+/* #define endp(obje) ((enum type)((endp_temp = (obje))->d.t) ==
t_cons ? \ */
+/* FALSE : endp_temp == Cnil ? TRUE : \ */
+/* (FEwrong_type_argument(sLlist, endp_temp),FALSE)) */
+
+#define endp(obje) ((enum type)(type_of(endp_temp = (obje))) ==
t_cons ? \
FALSE : endp_temp == Cnil ? TRUE : \
(FEwrong_type_argument(sLlist, endp_temp),FALSE))
Index: o/sfaslbfd.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sfaslbfd.c,v
retrieving revision 1.12.4.1.2.4.12.1
diff -u -r1.12.4.1.2.4.12.1 sfaslbfd.c
--- o/sfaslbfd.c 15 Jan 2005 16:26:43 -0000 1.12.4.1.2.4.12.1
+++ o/sfaslbfd.c 20 May 2005 03:29:40 -0000
@@ -210,7 +210,7 @@
nbfd=1;
- dum.sm.t=t_stream;
+ set_type_of(&dum,t_stream);
dum.sm.sm_mode=smm_input;
dum.sm.sm_object0=sLstring_char;
Index: o/sgbc.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sgbc.c,v
retrieving revision 1.9.4.1.2.12.6.1.2.1
diff -u -r1.9.4.1.2.12.6.1.2.1 sgbc.c
--- o/sgbc.c 12 Aug 2004 16:42:47 -0000 1.9.4.1.2.12.6.1.2.1
+++ o/sgbc.c 20 May 2005 03:29:40 -0000
@@ -59,11 +59,11 @@
#define sgc_mark_pack_list(u) \
-do {register object xtmp = u; \
+do {object xtmp = u; \
while (xtmp != Cnil) \
- {if (ON_WRITABLE_PAGE(xtmp)) xtmp->d.m = TRUE; \
+ {if (ON_WRITABLE_PAGE(xtmp)) xtmp->d.m = 1; \
sgc_mark_object(xtmp->c.c_car); \
- xtmp=xtmp->c.c_cdr;}}while(0)
+ xtmp=xtmp->c.c_cdr;((object)&xtmp)->d.m=0;}}while(0)
#ifdef SDEBUG
@@ -98,12 +98,13 @@
MARK_CDR:
#endif
x = x->c.c_cdr;
+ ((object)&x)->d.m=0;
IF_WRITABLE(x, goto WRITABLE_CDR;);
return;
WRITABLE_CDR:
if (x->d.m) return;
if (type_of(x) == t_cons) {
- x->c.m = TRUE;
+ x->d.m = 1;
goto BEGIN;
}
sgc_mark_object1(x);
@@ -139,7 +140,7 @@
joe();
OK:
#endif
- if (x->d.m)
+ if (x->d.m || x->d.f)
return;
#ifdef SDEBUG
if(x==sdebug) joe1();
@@ -151,7 +152,7 @@
always fail on x that satisfy (NULL_OR_ON_C_STACK(x))
*/
- x->d.m = TRUE;
+ x->d.m = 1;
switch (type_of(x)) {
case t_fixnum:
break;
@@ -177,7 +178,7 @@
case t_symbol:
IF_WRITABLE(x->s.s_plist,if(x->s.s_plist->d.m==0)
- {x->s.s_plist->d.m=TRUE;
+ {x->s.s_plist->d.m=1;
sgc_mark_cons(x->s.s_plist);});
sgc_mark_object(x->s.s_gfdef);
sgc_mark_object(x->s.s_dbind);
@@ -599,7 +600,7 @@
static void
sgc_mark_stack_carefully(void *topv, void *bottomv, int offset) {
- long m,pageoffset;
+ long pageoffset;
unsigned long p;
object x;
struct typemanager *tm;
@@ -628,14 +629,15 @@
((pageoffset=((char *)*j - pagetochar(p))) %
tm->tm_size));
if ((pageoffset < (tm->tm_size * tm->tm_nppage))
- && (m=x->d.m) != FREE) {
- if (m==TRUE) continue;
- if (m!=0) {
- fprintf(stdout,
- "**bad value %ld of d.m in gbc page %ld skipping mark**"
- ,m,p);fflush(stdout);
- continue;
- }
+ && !x->d.f && !x->d.m) {
+/* && (m=x->d.m) != FREE) { */
+/* if (m==TRUE) continue; */
+/* if (m!=0) { */
+/* fprintf(stdout, */
+/* "**bad value %ld of d.m in gbc page %ld skipping mark**" */
+/* ,m,p);fflush(stdout); */
+/* continue; */
+/* } */
sgc_mark_object(x);
}
}
@@ -673,8 +675,8 @@
object x = (object) p;
if (SGC_OR_M(x))
continue;
- if (x->d.t==t_cons) {
- x->d.m = TRUE;
+ if (type_of(x)==t_cons /* x->d.t==t_cons */) {
+ x->d.m = 1;
sgc_mark_cons(x);
} else
sgc_mark_object1(x);
@@ -808,20 +810,21 @@
for (j = tm->tm_nppage; --j >= 0; p += size) {
x = (object)p;
- if (x->d.m == FREE)
+ if (x->d.f)
continue;
else if (x->d.m) {
- x->d.m = FALSE;
+ x->d.m = 0;
continue;
}
- if(x->d.s == SGC_NORMAL)
+ if(x->d.e && x->d.s == SGC_NORMAL)
continue;
/* it is ok to free x */
#ifdef OLD_DISPLACE
/* old_displace: from might be free, to not */
- if(x->d.t >=t_array && x->d.t <= t_bitvector) {
+/* if(x->d.t >=t_array && x->d.t <= t_bitvector) { */
+ if(type_of(x) >=t_array && type_of(x) <= t_bitvector) {
/* case t_array:
case t_vector:
case t_string:
@@ -841,13 +844,13 @@
}
#endif /* OLD_DISPLACE */
#ifdef GMP_USE_MALLOC
- if (x->d.t == t_bignum)
+ if (type_of(x) == t_bignum /* x->d.t == t_bignum */)
mpz_clear(MP(x));
#endif
SET_LINK(x,f);
- x->d.m = FREE;
- x->d.s = (int)SGC_RECENT;
+ x->d.f = 1;
+ if (x->d.e) x->d.s = (int)SGC_RECENT;
f = x;
k++;
}
@@ -857,7 +860,7 @@
else /*non sgc_page */
for (j = tm->tm_nppage; --j >= 0; p += size) {
x = (object)p;
- if (x->d.m == TRUE) x->d.m=FALSE;
+ if (x->d.m) x->d.m=0;
}
}
@@ -1201,7 +1204,7 @@
#define WSGC(tm) ({long
_t=MMAX(MMIN(tm->tm_opt_maxpage,tm->tm_npage),tm->tm_sgc);_t;})
/* If opt_maxpage is set, add full pages to the sgc set if needed
too. 20040804 CM*/
-#define FSGC(tm) (tm->tm_opt_maxpage ? 0 : tm->tm_sgc_minfree)
+#define FSGC(tm) (tm->tm_type==t_cons ? tm->tm_nppage : (tm->tm_opt_maxpage ?
0 : tm->tm_sgc_minfree))
int
sgc_start(void) {
@@ -1463,17 +1466,17 @@
while (f!=0) {
next=OBJ_LINK(f);
#ifdef SDEBUG
- if (f->d.m!=FREE)
+ if (!f->d.f)
printf("Not FREE in freelist f=%d",f);
#endif
if (ON_SGC_PAGE(f)) {
SET_LINK(f,x);
- f->d.s = SGC_RECENT;
+ if (f->d.e) f->d.s = SGC_RECENT;
x=f;
count++;
} else {
SET_LINK(f,y);
- f->d.s = SGC_NORMAL;
+ if (f->d.e) f->d.s = SGC_NORMAL;
y=f;
}
f=next;
@@ -1580,7 +1583,7 @@
if (type_map[i]==t && (sgc_type_map[i] & SGC_PAGE_FLAG))
for (p= pagetochar(i),j = tm->tm_nppage;
j > 0; --j, p += tm->tm_size)
- ((object) p)->d.s = SGC_NORMAL;
+ if (((object)p)->d.e) ((object) p)->d.s = SGC_NORMAL;
}
}
}
Index: o/usig2.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/usig2.c,v
retrieving revision 1.11.4.1.4.2
diff -u -r1.11.4.1.4.2 usig2.c
--- o/usig2.c 14 Sep 2003 02:30:45 -0000 1.11.4.1.4.2
+++ o/usig2.c 20 May 2005 03:29:40 -0000
@@ -290,7 +290,7 @@
if (p->free2[i])
{ x = (object) p->free2[i];
if (x->d.m) error("should not be free");
- x->d.m = FREE;
+ x->d.f = 1;
F_LINK(F_LINK(ad->tm_free)) = (long )current_fl;
ad->tm_nfree += 2;
}
Index: o/utils.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/utils.c,v
retrieving revision 1.10
diff -u -r1.10 utils.c
--- o/utils.c 17 Feb 2003 16:50:21 -0000 1.10
+++ o/utils.c 20 May 2005 03:29:40 -0000
@@ -184,7 +184,7 @@
object
Icheck_one_type(object x, enum type t)
-{ if (x->d.t != t)
+{ if (type_of(x) != t)
{ return CEerror("Expected a ~a ","Supply right
type",1,type_name(t),Cnil,Cnil,Cnil);
}
return x;
=============================================================================
Take care,
> Paul Dietz
>
> Camm Maguire wrote:
> > [ background for gcl-devel readers -- I';ve recently returned from a
> > visit to UT/Austin where there are quite a few serious GCL users,
> > mostly as a base lisp behind ACL2. I'll try to make a full report on
> > this visit soon. One of the suggestions raised were the excessive
> > memory requirements of GCL, esp. its current 3 word cons. ]
> > Greetings!
> > Found a little time, and managed to get a two word cons working on
> > version 2.7.0 (CVS head). Appears to be passing all tests with all GC
> > options, e.g. SGC, optimize-maximum-pages, etc. There are doubtless
> > a few issues remaining somewhere. But it looks quite doable.
> > I'm not sure the approach I took is best, so would like to consult.
> > I've taken advantage of the fact that even on 32bit machines, all our
> > structures are at least 2 words long, and can therefore be 8 byte
> > aligned, giving three mark bits. The least significant indicates that
> > the whole word is a traditional type word, the next is the GC mark
> > bit, and the the next is a bit indicating the object is free. This
> > allows basically all pointer indirection to proceed without masking as
> > pointers to be indirected in a cons only have bits set in the GC --
> > not that this is important from a performance point of view, but it
> > would take considerable work to rewrite the compiler to put the masks
> > in everywhere. The only explicit masking-prior-to-indirection that
> > needs doing is in the GC (e.g. mark_cons), which is thankfully
> > well-localized. This requires, however, that all odd word structures
> > on 32bit machines be padded by one word. This is most wasteful for
> > the other three word structs (complex, ratio, ...) which are now 4
> > words long (on 32bit only), but my (completely unsubstantiated) hunch
> > is that this wastage is dwarfed by the cons savings.
> > Here is what (room) looks like (p means struct has been padded by one
> > word, m means trimmed by one word):
> > (2 words) m
> > 800/1352 30.2% CONS FIXNUM SHORT-FLOAT CHARACTER RANDOM-STATE
> > READTABLE SPICE
> > (10 words) p
> > 102/301 87.3% SYMBOL
> > (14 words) p
> > 1/2 21.9% PACKAGE
> > (8 words) p p p p
> > p p 106/306 49.3% ARRAY HASH-TABLE VECTOR
> > BIT-VECTOR STREAM PATHNAME CCLOSURE CLOSURE
> > (4 words) p p p p
> > 267/321 9.0% STRUCTURE BIGNUM RATIO LONG-FLOAT COMPLEX CFUN
> > (6 words) p p p p p p
> > 56/276 88.2% SFUN STRING GFUN VFUN AFUN CFDATA
> > 612/768 1 contiguous (150 blocks)
> > 13107 hole
> > 5242 0.0% relocatable
> > 1332 pages for cells
> > 20293 total pages
> > 99672 pages available
> > 11107 pages in heap but not gc'd + pages needed for gc marking
> > 131072 maximum pages
> > While some of these might be compressed further, there is definitely
> > no compression room for the 4 word structs, the most wasteful of which
> > is likely the structure structs. In some 4 word cases, the compile of
> > course can inline the variables and pass them around on the stack.
> > Either I figure out how to live without a free object bit, or we
> > conclude that the cons load greatly dominates in all real world
> > situations, and that 64bit is the medium term future, where there is
> > only savings and no waste.
> > There is also a minor consequence for SGC. SGC basically selects a
> > subset of pages to work with and marks the rest read-only. All old
> > objects on the working set at the time sgc is turned on can never be
> > freed, as the mark might have to proceed via a read-only page, which
> > the algorithm skips for efficiency. These SGC_NORMAL vs. SGC_RECENT
> > objects were designated by yet another bit in the type word. 16 byte
> > alignment is definitely too wasteful IMHO, so there is no room for
> > this on cons (only), in which case we only claim totally free pages for
> > sgc, and use the sgc page flag to effectively determine SGC_RECENT
> > cons from SGC_NORMAL. Secondly, and perhaps more importantly, we
> > discussed how ld.so puts
> > the shared libraries at 0x40000000 on Linux for example, limiting or
> > corrupting a big heap depending on the robustness of GCL's
> > algorithms. The way around this appears to be via a linker script,
> > using a PT_LOAD entry in the program header to make a section taking
> > no ram or disk space but occupying and effectively reserving the
> > desired area. I should have more information on this soon.
> > Take care, "Warren A. Hunt Jr." <address@hidden> writes:
> >
> >>Hi Camm,
> >>
> >>Here are some of the things we discussed.
> >>
> >>Cheers,
> >>
> >>Warren
> >>++++++
> >>
> >> Items Discussed
> >>
> >> 1. Hash CONS (HONS).
> >> a. Weak Hash
> >> b. Randomize FIXNUM hashing
> >> 2. Clear understanding of (ROOM T)
> >> 3. Unbox FIXNUM or CONS for GC
> >> 4. Threads
> >> 5. Complier Emit Function Signatures and Boxing
> >> 6. Upon function redefintion, flush all function properties
> >> 7. Mutual Recursion
> >> 8. Bigger FIXNUM, si::allocate-bigger-fixnum ?
> >> 9. Bigger PageSize
> >>10. Fold xgcl into the standard build
> >>11. Replace #n# tables with dynamic tables
> >>12. Eliminate the compile-time maximum pages
> >>13. Place shared libraries elsewhere in memory
> >>14. Fix gethash and sethash code
> >>
> >>
> >>enum httest { /* hash table key test function */
> >> htt_eq, /* eq */
> >> htt_eql, /* eql */
> >> htt_equal /* equal */
> >>};
> >>
> >>struct htent { /* hash table entry */
> >> object hte_key; /* key */
> >> object hte_value; /* value */
> >>};
> >>
> >>struct hashtable { /* hash table header */
> >> FIRSTWORD;
> >> struct htent
> >> *ht_self; /* pointer to the hash table */
> >> object ht_rhsize; /* rehash size */
> >> object ht_rhthresh; /* rehash threshold */
> >> // WAH,Jr. -- At creation and extension, recomput this next number.
> >> int ht_int_thres /* Interger number of maxium entries */
> >> int ht_nent; /* number of entries */
> >> int ht_size; /* hash table size */
> >> short ht_test; /* key test function */
> >> /* of enum httest */
> >>};
> >>
> >>
> >>struct htent *
> >>gethash(key, hashtable)
> >>object key;
> >>object hashtable;
> >>{
> >> enum httest htest;
> >> int hsize;
> >> struct htent *e;
> >> object hkey;
> >> int i=0, j = -1, k; /* k added by chou */
> >> bool b=FALSE;
> >>
> >> htest = (enum httest)hashtable->ht.ht_test;
> >> hsize = hashtable->ht.ht_size;
> >>
> >> // WAH,Jr. -- Make "/ 4" into ">> WORDSIZE_IN_BYTES"
> >> if (htest == htt_eq)
> >> i = (long)key / 4;
> >> // WAH,Jr. -- Pull out FIXNUM and CHARACTER tests
> >> else if (htest == htt_eql)
> >> i = hash_eql(key);
> >> else if (htest == htt_equal)
> >> i = ihash_equal(key,0);
> >> // WAH,Jr. -- Fix constant below.
> >> i &= 0x7fffffff;
> >> // WAH,Jr. -- Restructure with two simple loops, don't use MOD, don't
> >> need k
> >> for (i %= hsize, k = 0; k < hsize; i = (i + 1) % hsize, k++) { /* k
> >> added by chou */
> >> e = &hashtable->ht.ht_self[i];
> >> hkey = e->hte_key;
> >> if (hkey == OBJNULL) {
> >> if (e->hte_value == OBJNULL)
> >> if (j < 0)
> >> return(e);
> >> else
> >> return(&hashtable->ht.ht_self[j]);
> >> else
> >> if (j < 0)
> >> j = i;
> >> else if (j==i)
> >> /* this was never returning --wfs
> >> but looping around with j=0 */
> >> return(e)
> >> ;
> >> continue;
> >> }
> >> // WAH,Jr. -- Eliminate these tests each time around the loop.
> >> if (htest == htt_eq)
> >> b = key == hkey;
> >> else if (htest == htt_eql)
> >> b = eql(key, hkey);
> >> else if (htest == htt_equal)
> >> b = equal(key, hkey);
> >> if (b)
> >> return(&hashtable->ht.ht_self[i]);
> >> }
> >> return(&hashtable->ht.ht_self[j]); /* added by chou */
> >>}
> >>
> >>
> >>static void
> >>extend_hashtable(object);
> >>
> >>void
> >>sethash(key, hashtable, value)
> >>object key, hashtable, value;
> >>{
> >> int i;
> >> bool over=FALSE;
> >> struct htent *e;
> >>
> >> i = hashtable->ht.ht_nent + 1;
> >> // WAH,Jr. Test for excess size by simple integer comparison.
> >> if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
> >> over = i >= fix(hashtable->ht.ht_rhthresh);
> >> else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat)
> >> over =
> >> i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh);
> >> else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat)
> >> over =
> >> i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh);
> >> if (over)
> >> extend_hashtable(hashtable);
> >> e = gethash(key, hashtable);
> >> if (e->hte_key == OBJNULL)
> >> hashtable->ht.ht_nent++;
> >> e->hte_key = key;
> >> e->hte_value = value;
> >>}
> >>
> >>static void
> >>extend_hashtable(hashtable)
> >>object hashtable;
> >>{
> >> object old;
> >> int new_size=0, i;
> >>
> >> if (type_of(hashtable->ht.ht_rhsize) == t_fixnum)
> >> new_size = hashtable->ht.ht_size +
> >> fix(hashtable->ht.ht_rhsize);
> >> else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat)
> >> new_size = hashtable->ht.ht_size *
> >> sf(hashtable->ht.ht_rhsize);
> >> else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat)
> >> new_size = hashtable->ht.ht_size *
> >> lf(hashtable->ht.ht_rhsize);
> >> {BEGIN_NO_INTERRUPT;
> >> old = alloc_object(t_hashtable);
> >> old->ht = hashtable->ht;
> >> vs_push(old);
> >> hashtable->ht.ht_self = NULL;
> >> hashtable->ht.ht_size = new_size;
> >> if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
> >> hashtable->ht.ht_rhthresh =
> >> make_fixnum(fix(hashtable->ht.ht_rhthresh) +
> >> (new_size - old->ht.ht_size));
> >> hashtable->ht.ht_self =
> >> (struct htent *)alloc_relblock(new_size * sizeof(struct htent));
> >> for (i = 0; i < new_size; i++) {
> >> hashtable->ht.ht_self[i].hte_key = OBJNULL;
> >> hashtable->ht.ht_self[i].hte_value = OBJNULL;
> >> }
> >> for (i = 0; i < old->ht.ht_size; i++) {
> >> if (old->ht.ht_self[i].hte_key != OBJNULL)
> >> sethash(old->ht.ht_self[i].hte_key,
> >> hashtable,
> >> old->ht.ht_self[i].hte_value);
> >> }
> >> hashtable->ht.ht_nent = old->ht.ht_nent;
> >> vs_popp;
> >> END_NO_INTERRUPT;}
> >>}
> >>
> >>
> >>
> >
>
>
>
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://lists.gnu.org/mailman/listinfo/gcl-devel
>
>
>
--
Camm Maguire address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah