static char *sccsid
= "@(#)Talloc.c 34.11 10/31/80";
# define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
# define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
# define ftstbit asm(" ashl $-2,r11,r3");\
asm(" bbcs r3,_bitmapq,$1");\
/* define ftstbit if( readbit(p) ) return; oksetbit; */
# define readbit(p) ((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
# define lookbit(p) (bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
# define setbit(p) {bitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
# define oksetbit {bitmap[r] |= s;}
# define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
# define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
# define roundup(x,l) (((x - 1) | (l - 1)) + 1)
/* METER denotes something added to help meter storage allocation. */
extern struct heads header
[];
FILE * chkport
; /* garbage collection dump file */
extern lispval datalim
; /* end of data space */
double bitmapq
[BITQUADS
]; /* the bit map--one bit per long */
double Mbitmapq
[BITQUADS
];
double zeroq
; /* a quad word of zeros */
char *bitmap
= (char *) bitmapq
; /* byte version of bit map array */
int *bitmapi
= (int *) bitmapq
; /* integer version of bit map array */
int *Mbitmapi
= (int *) Mbitmapq
; /* integer version of bit map array */
int freefree
,usedfree
,freeused
,usedused
;
int freefree
,usedfree
,freeused
,usedused
; /* need so external refs will be
satisfied, remove when get rid
char bitmsk
[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */
extern int *bind_lists
; /* lisp data for compiled code */
extern struct types atom_str
, strng_str
, int_str
, dtpr_str
, doub_str
,
array_str
, sdot_str
, val_str
, funct_str
, hunk_str
[];
lispval hunk_items
[7], hunk_pages
[7], hunk_name
[7];
extern int initflag
; /* starts off TRUE: initially gc not allowed */
int gcflag
= FALSE
; /* TRUE during garbage collection */
int current
= 0; /* number of pages currently allocated */
static struct types
*(spaces
[NUMSPACES
]) =
{&atom_str
, &strng_str
, &int_str
,
&dtpr_str
, &doub_str
, &array_str
,
&sdot_str
, &val_str
, &funct_str
,
&hunk_str
[0], &hunk_str
[1], &hunk_str
[2],
&hunk_str
[3], &hunk_str
[4], &hunk_str
[5],
/* this is a table of pointers to collectable struct types objects
* the index is the type number.
struct types
*gcableptr
[] =
{ (struct types
*) 0, /* strings not collectable */
(struct types
*) 0, /* atoms not collectable */
&int_str
, &dtpr_str
, &doub_str
,
(struct types
*) 0, /* binary objects not collectable */
(struct types
*) 0, /* port objects not collectable */
(struct types
*) 0, /* gap in the type number sequence */
&hunk_str
[0], &hunk_str
[1], &hunk_str
[2],
&hunk_str
[3], &hunk_str
[4], &hunk_str
[5],
/** get_more_space(type_struct) *****************************************/
/* Allocates and structures a new page, returning 0. */
/* If no space is available, returns 1. */
get_more_space(type_struct
)
struct types
*type_struct
;
struct heads
*next
; extern char holend
[];
/* mustn't look at plist of plima too soon */
while( plim
=copval(plima
,(lispval
)CNIL
), TYPE(plim
)!=INT
)
copval(plima
,error("BAD PAGE LIMIT",TRUE
));
if( plim
->i
<= current
) return(1); /* Can't allocate */
if( current
>= TTSIZE
) return(2);
if(type_struct
==&strng_str
|| (type_struct
==&funct_str
))
start
= gethspace(NBPG
,type_struct
->type
);
SETTYPE(start
, type_struct
->type
); /* set type of page */
/* bump the page counter for this space */
++((*(type_struct
->pages
))->i
);
type_struct
->space_left
= type_struct
->space
;
next
= &header
[ current
++ ];
next
->link
= type_struct
->first
;
type_struct
->first
= next
;
if(type_struct
==&strng_str
) {
type_struct
->next_free
= start
;
return(0); /* space was available */
type_struct
->first
= next
;
temp
= loop
= (int *) start
;
for(cntr
=1; cntr
< type_struct
->space
; cntr
++)
loop
= (int *) (*loop
= (int) (loop
+ type_struct
->type_len
));
*loop
= (int) (type_struct
->next_free
);
type_struct
->next_free
= (char *) temp
;
/* if type atom, set pnames to CNIL */
if( type_struct
== &atom_str
)
for(cntr
=0, p
=(lispval
) temp
; cntr
<atom_str
.space
; ++cntr
)
p
->a
.pname
= (char *) CNIL
;
p
= (lispval
) ((int *)p
+ atom_str
.type_len
);
return(0); /* space was available */
/** next_one(type_struct) ************************************************/
/* Allocates one new item of each kind of space, except STRNG. */
/* If there is no space, calls gc, the garbage collector. */
/* If there is still no space, allocates a new page using */
/* get_more_space(type_struct) */
struct types
*type_struct
;
while(type_struct
->next_free
== (char *) CNIL
)
if((type_struct
->type
!= ATOM
) && /* can't collect atoms */
(type_struct
->type
!= STRNG
) && /* can't collect strings */
(type_struct
->type
!= BCD
) && /* nor function headers */
(gcthresh
->i
<= current
) && /* threshhold for gc */
gcdis
->a
.clb
== nil
&& /* gc not disabled */
(NOTNIL(copval(gcload
,CNIL
)) || (loading
->a
.clb
!= tatom
)) &&
/* not to collect during load */
(initflag
== FALSE
) && /* dont gc during init */
(gcflag
== FALSE
)) /* don't recurse gc */
/* fputs("Collecting",poport);
gc(type_struct
); /* collect */
if( type_struct
->next_free
!= (char *) CNIL
) break;
if(! (g
=get_more_space(type_struct
))) break;
plimit
->i
= current
+NUMSPACES
;
/* allow a few more pages */
copval(plima
,plimit
); /* restore to reserved reg */
error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED",
else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED",
temp
= type_struct
->next_free
;
type_struct
->next_free
= * (char **)(type_struct
->next_free
);
return(next_one(&int_str
));
temp
= next_one(&dtpr_str
);
temp
->d
.car
= temp
->d
.cdr
= nil
;
return(next_one(&doub_str
));
temp
= next_one(&sdot_str
);
temp
->d
.car
= temp
->d
.cdr
= 0;
save
= (struct atom
*) next_one(&atom_str
) ;
save
->plist
= save
->fnbnd
= nil
;
save
->hshlnk
= (struct atom
*)CNIL
;
atmlen
= strlen(strbuf
)+1;
if(atmlen
> strng_str
.space_left
)
while(get_more_space(&strng_str
))
error("YOU HAVE RUN OUT OF SPACE",TRUE
);
strcpy((save
= strng_str
.next_free
), strbuf
);
while(atmlen2
& 3) ++atmlen2
; /* even up length of string */
strng_str
.next_free
+= atmlen2
;
strng_str
.space_left
-= atmlen2
;
char *inewstr(s
) char *s
;
strbuf
[STRBLEN
-1] = '\0';
strcpyn(strbuf
,s
,STRBLEN
-1);
temp
= next_one(&array_str
);
temp
->ar
.data
= (char *)nil
;
temp
->ar
.length
= SMALL(0);
temp
->ar
.delta
= SMALL(0);
{ error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE
); }
temp
= next_one(&funct_str
);
temp
->bcd
.entry
= badcall
;
temp
->bcd
.discipline
= nil
;
temp
= next_one(&val_str
);
++(hunk_items
[hunknum
]->i
); /* Update used hunks count */
temp
= next_one(&hunk_str
[hunknum
]); /* Get a hunk */
inewval(arg
) lispval arg
;
temp
= next_one(&val_str
);
/** Ngc *****************************************************************/
/* LISP interface to gc. */
if( ISNIL(lbot
->val
) ) return(gc(CNIL
));
if( TYPE(lbot
->val
) != DTPR
) error("BAD CALL TO GC",FALSE
);
if( NOTNIL(lbot
->val
->d
.car
) )
temp
= eval(lbot
->val
->d
.car
);
if( TYPE(temp
) == PORT
) chkport
= temp
->p
;
/** gc(type_struct) *****************************************************/
/* garbage collector: Collects garbage by mark and sweep algorithm. */
/* After this is done, calls the Nlambda, gcafter. */
/* gc may also be called from LISP, as a lambda of no arguments. */
struct types
*type_struct
;
save
= copval(gcport
,CNIL
);
while( (TYPE(save
) != PORT
) && NOTNIL(save
))
save
= error("NEED PORT FOR GC",TRUE
);
chkport
= (ISNIL(save
) ? poport
: save
->p
);
gc1(NOTNIL(copval(gccheck
,CNIL
)) || (chkport
!=poport
)); /* mark&sweep */
/* Now we call gcafter--special case if gc called from LISP */
if( type_struct
== (struct types
*) CNIL
)
gccall1
->d
.cdr
= nil
; /* make the call "(gcafter)" */
gccall1
->d
.cdr
= gccall2
;
gccall2
->d
.car
= *(type_struct
->type_name
);
{lispval temp
;temp
= rdrsdot
, rdrsdot
= rdrsdot2
, rdrsdot2
= temp
; /*KLUDGE*/}
gcflag
= TRUE
; /* flag to indicate in garbage collector */
save
= eval(gccall1
); /* call gcafter */
gcflag
= FALSE
; /* turn off flag */
{lispval temp
;temp
= rdrsdot
, rdrsdot
= rdrsdot2
, rdrsdot2
= temp
; /*KLUDGE*/}
GCtime
+= (finish
.mytime
- begin
.mytime
);
return(save
); /* return result of gcafter */
/* gc1() **************************************************************/
/* Mark-and-sweep phase */
gc1(chkflag
) int chkflag
;
register int *start
,bvalue
,type_len
;
register struct types
*s
;
int *point
,i
,freecnt
,itemstogo
,bits
,bindex
,type
,enddat
;
int debugin
= FALSE
; /* temp debug flag */
#define ERDB(s) { printf(s); fflush(stdout); }
/* decide whether to check LISP structure or not */
/* first set all bit maps to zero */
if(debugin
) ERDB("Begin gc\n");
enddat
= (int)datalim
>> 8;
for(bvalue
=0; bvalue
< (int)enddat
; ++bvalue
)
/* Mbitmapq[bvalue] = bitmapq[bvalue]; /* remember old vals */
/* the C compiler will use a movd if we let it,and this
will not work since the bit maps may be illegal
asm(" movq _bitmapq[r10],_Mbitmapq[r10] ");
/* try the movc5 to clear the bit maps */
/* blzero(bitmap,TTSIZE * 16); */
/* then mark all atoms' plists, clbs, and function bindings */
for(loop
=atom_str
.first
; loop
!=(struct heads
*)CNIL
; loop
=loop
->link
)
for(start
=(int *)(loop
->pntr
), i
=1;
start
= start
+ atom_str
.type_len
, ++i
)
/* unused atoms are marked with pname == CNIL */
/* this is done by get_more_space, as well as */
/* by gc (in the future) */
if(((lispval
)start
)->a
.pname
== (char *)CNIL
) continue;
#define MARKSUB(p) if(nil!=((lispval)start)->p)markdp(((lispval)start)->p);
/* Mark all the atoms and ints associated with the hunk
/* next run up the name stack */
if(debugin
) ERDB("name stack\n");
for(loop2
= np
- 1; loop2
>= orgnp
; --loop2
) markdp((loop2
->val
));
/* now the bindstack (vals only, atoms are marked elsewhere ) */
for(loop3
= bnp
- 1; loop3
>= orgbnp
; --loop3
)markdp(loop3
->val
);
if(debugin
) ERDB("compiler stuff\n");
/* next mark all compiler linked data */
while((start
= point
) != (int *)CNIL
) {
if(debugin
) ERDB("once ");
point
= (int *)*(point
-1);
if(debugin
) ERDB("signif stuff\n");
/* next mark all system-significant lisp data */
for(i
=0; i
<SIGNIF
; ++i
) markdp((lispsys
[i
]));
if(debugin
) printf("time to sweep up\n");
/* all accessible data has now been marked. */
/* all collectable spaces must be swept, */
/* and freelists constructed. */
/* first clear the structure elements for types
for(k
=0 ; k
<= HUNK128
; k
++)
s
->next_free
= (char *) CNIL
;
/* sweep up in memory looking at gcable pages */
for(start
= beginsweep
, bindex
= (int)start
>> 7;
/* printf(" start %x, bindex %x\n",start,bindex); */
if(!(s
=gcableptr
[type
= TYPE(start
)]))
bindex
+= 4; /* and 4 words of 32 bit bitmap words */
freecnt
= 0; /* number of free items found */
itemstogo
= s
->space
; /* number of items per page */
bits
= 32; /* number of bits per word */
/* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
bvalue
= bitmapi
[bindex
++];
Mbvalue
= Mbitmapi
[bindex
-1];
/*printf(" bv: %08x, ",bvalue);*/
if(!(bvalue
& 1)) /* if data element is not marked */
*point
= (int) (s
->next_free
) ;
s
->next_free
= (char *) point
;
if(Mbvalue
& 1) usedfree
++;
if (Mbvalue
& 1) usedused
++;
if(type_len
>=128) bindex
+= 2;
/* shift over mask by number of words in data type */
if( (bits
-= type_len
) > 0)
{ bvalue
= bvalue
>> type_len
;
Mbvalue
= Mbvalue
>> type_len
;
{ bvalue
= bitmapi
[bindex
++];
Mbvalue
= Mbitmapi
[bindex
-1];
while( bits
>= 32) { bindex
++;
bvalue
= bitmapi
[bindex
++];
Mbvalue
= Mbitmapi
[bindex
-1];
Mbvalue
= Mbvalue
>> bits
;
/* printf(" t %d,fr %d ",type,freecnt); */
s
->space_left
+= freecnt
;
(*(s
->items
))->i
+= s
->space
- freecnt
;
/** alloc() *************************************************************/
/* This routine tries to allocate one more page of the space named */
/* by the argument. If no more space is available returns 1, else 0. */
lispval tname
; int npages
;
if(((int)datalim
>> 9) + npages
> TTSIZE
)
error("Space request would exceed maximum memory allocation",FALSE
);
for( jj
=0; jj
<npages
; ++jj
)
if(get_more_space(spaces
[ii
])) break;
csegment(tname
,nitems
,useholeflag
)
lispval tname
; int nitems
;
nitems
= nitems
*4*spaces
[ii
]->type_len
; /* find c-length of space */
nitems
= roundup(nitems
,512); /* round up to right length */
if((tname
==str_name
) && useholeflag
)
charadd
= gethspace(nitems
,ii
);
datalim
= (lispval
)(charadd
+nitems
);
error("NOT ENOUGH SPACE FOR ARRAY",FALSE
);
if((((int)datalim
) >> 9) > TTSIZE
) {
datalim
= (lispval
) (TTSIZE
<< 9);
for(jj
=0; jj
<nitems
; jj
=jj
+512) {
SETTYPE(charadd
+jj
, spaces
[ii
]->type
);
return((lispval
)charadd
);
int csizeof(tname
) lispval tname
;
return( spaces
[typenum(tname
)]->type_len
* 4 );
int typenum(tname
) lispval tname
;
chek
: for(ii
=0; ii
<NUMSPACES
; ++ii
)
if(tname
== *(spaces
[ii
]->type_name
)) break;
tname
= error("BAD TYPE NAME",TRUE
);
extern usehole
; extern char holend
[]; extern char *curhbeg
;
curhbeg
= (char *) roundup(((int)curhbeg
),NBPG
);
if((holend
- curhbeg
) < segsiz
)
{ printf("[fasl hole filled up]\n");
curhbeg
= curhbeg
+ segsiz
;
/*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
value
= (ysbrk(segsiz
/NBPG
,type
));
datalim
= (lispval
)(value
+ segsiz
);
/* this gets done upon rebirth */
strng_str
.space_left
= 0;
funct_str
.space_left
= 0;
funct_str
.next_free
= (char *) CNIL
;
/** markit(p) ***********************************************************/
markit(p
) lispval
*p
; { markdp(*p
); }
/** markdp(p) ***********************************************************/
/* markdp is the routine which marks each data item. If it is a */
/* dotted pair, the car and cdr are marked also. */
/* An iterative method is used to mark list structure, to avoid */
/* excessive recursion. */
markdp(p
) register lispval p
;
/* register int r, s; (goes with non-asm readbit, oksetbit) */
/* register hsize, hcntr; */
if((int)p
<= 0) return; /* do not mark special data types or nil=0 */
ftstbit
; /* mark array itself */
markdp(p
->ar
.accfun
); /* mark access function */
markdp(p
->ar
.aux
); /* mark aux data */
markdp(p
->ar
.length
); /* mark length */
markdp(p
->ar
.delta
); /* mark delta */
if(TYPE(p
->ar
.aux
)==DTPR
&& p
->ar
.aux
->d
.car
==Vnogbar
)
/* register int i, l; int d; */
/* register char *dataptr = p->ar.data; */
char *dataptr
= p
->ar
.data
;
for(i
=0, l
=p
->ar
.length
->i
, d
=p
->ar
.delta
->i
; i
<l
; ++i
)
markdp(p
->bcd
.discipline
);
hsize
= 2 << HUNKSIZE(p
);
for (hcntr
= 0; hcntr
< hsize
; hcntr
++)
markdp(p
->h
.hunk
[hcntr
]);
static char *xx
; /* pointer to next available blank page */
extern int xcycle
; /* number of blank pages available */
lispval u
; /* used to compute limits of bit table */
xx
= sbrk(16*NBPG
); /* get pages 16 at a time */
lispend("For sbrk from lisp: no space... Goodbye!");
done
: if( (u
= (lispval
)(xx
+NBPG
)) > datalim
) datalim
= u
;
char *ysbrk(pages
,type
) int pages
, type
;
char *xx
; /* will point to block of storage */
error("OUT OF SPACE FOR ARRAY REQUEST",FALSE
);
datalim
= (lispval
)(xx
+pages
*NBPG
); /* compute bit table limit */
for(i
= 0; i
< pages
; ++i
) {
SETTYPE((xx
+ i
*NBPG
),type
);
return(xx
); /* return pointer to block of storage */
* this function is used by the VMS franz to allocate space.
* It allocates space in the zfreespace array.
* The single argument passed to sbrk is the number of bytes to allocate
extern char zfreespace
[];
if(lsbrkpnt
== (char *)0)
lsbrkpnt
= (char *) roundup((int)zfreespace
,NBPG
);
/* printf("lispbrk: %x \n",lsbrkpnt);
if(lsbrkpnt
> &zfreespace
[FREESIZE
])
error("sbrk: out of space ",FALSE
);
/* getatom **************************************************************/
/* returns either an existing atom with the name specified in strbuf, or*/
/* if the atom does not already exist, regurgitates a new one and */
register char *name
, *endname
;
register struct argent
*lbot
, *np
;
if (*name
== (char)0377) return (eofa
);
atmlen
= strlen(name
) + 1;
aptr
= (lispval
) hasht
[hash
];
if (strcmp(name
,aptr
->a
.pname
)==0)
aptr
= (lispval
) aptr
->a
.hshlnk
;
aptr
= (lispval
) newatom();
aptr
->a
.hshlnk
= hasht
[hash
];
hasht
[hash
] = (struct atom
*) aptr
;
endname
= name
+ atmlen
- 2;
if ((atmlen
!= 4) && (*name
== 'c') && (*endname
== 'r'))
(b
->d
.car
)->d
.car
= xatom
;
b
->d
.car
= (lispval
) xatom
;
aptr
->a
.fnbnd
= unprot();
if((c
= *name
) == 'a') b
->d
.car
= cara
;
else if (c
== 'd') b
->d
.car
= cdra
;
for (i
=0 ; *symb
; i
+= i
+ *symb
++);
extern struct atom
*hasht
[HASHTOP
];