/* xldmem - xlisp dynamic memory management routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use
* HISTORY
* 28-Apr-03 Mazzoni
* eliminate some compiler warnings
* 14-Apr-88 Dannenberg
* Call free method when an EXTERN node is garbage collected
*/
/* #define DEBUG_MEM 1 */
#include "stdlib.h"
#include "string.h"
#include "xlisp.h"
#ifdef WIN32
#include "malloc.h" // defines alloca()
#endif
/* node flags */
#define MARK 1
#define LEFT 2
/* macro to compute the size of a segment */
#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
#ifdef DEBUG_INPUT
extern FILE *debug_input_fp;
#endif
/* variables local to xldmem.c and xlimage.c */
SEGMENT *segs,*lastseg,*fixseg,*charseg;
int anodes,nsegs,gccalls;
long nnodes,nfree,total;
LVAL fnodes;
#ifdef DEBUG_MEM
long xldmem_trace = 0; /* debugging */
#endif
/* forward declarations */
FORWARD LOCAL void findmem(void);
FORWARD LVAL newnode(int type);
FORWARD LOCAL unsigned char *stralloc(int size);
FORWARD LOCAL int addseg(void);
FORWARD void mark(LVAL ptr);
FORWARD LOCAL void sweep(void);
#ifdef DEBUG_GC
static long dbg_gc_n = 0; /* counts save operations */
long dbg_gc_count = 0; /* says when to stop */
LVAL *dbg_gc_addr = NULL; /* says what we're looking for */
void dbg_gc_xlsave(LVAL *n)
{
dbg_gc_n++;
if (n == dbg_gc_addr) {
printf("dbg_gc_xlsave: %x at count %d\n",
dbg_gc_addr, dbg_gc_n);
}
if (dbg_gc_count == dbg_gc_n) {
printf("dbg_gc_xlsave: reached %d\n",
dbg_gc_count);
}
}
#endif
/* cons - construct a new cons node */
LVAL cons(LVAL x, LVAL y)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
xlstkcheck(2);
xlprotect(x);
xlprotect(y);
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
xlpop();
xlpop();
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
--nfree;
/* initialize the new node */
nnode->n_type = CONS;
rplaca(nnode,x);
rplacd(nnode,y);
/* return the new node */
return (nnode);
}
/* cvstring - convert a string to a string node */
LVAL cvstring(const char *str)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = strlen(str) + 1;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),str);
xlpop();
return (val);
}
/* new_string - allocate and initialize a new string */
LVAL new_string(int size)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = size;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),"");
xlpop();
return (val);
}
/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(const char *pname)
{
/* pname points to a global buffer space. This is ok unless you have
* a gc hook that writes things and therefore uses the buffer. Then
* if newvector causes a GC, pname is overwritten before cvstring is
* called and the symbol will have the wrong name!
* The bug is fixed by copying pname to the stack.
*/
LVAL val;
int len = strlen(pname) + 1; /* don't forget the terminating zero */
char *local_pname_copy = (char *) alloca(len);
memcpy(local_pname_copy, pname, len);
xlsave1(val);
val = newvector(SYMSIZE);
val->n_type = SYMBOL;
setvalue(val,s_unbound);
setfunction(val,s_unbound);
setpname(val,cvstring(local_pname_copy));
xlpop();
return (val);
}
/* cvsubr - convert a function to a subr or fsubr */
LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
{
LVAL val;
val = newnode(type);
val->n_subr = fcn;
val->n_offset = offset;
return (val);
}
/* cvfile - convert a file pointer to a stream */
LVAL cvfile(FILE *fp)
{
LVAL val;
val = newnode(STREAM);
setfile(val,fp);
setsavech(val,'\0');
return (val);
}
/* cvfixnum - convert an integer to a fixnum node */
LVAL cvfixnum(FIXTYPE n)
{
LVAL val;
if (n >= SFIXMIN && n <= SFIXMAX)
return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
val = newnode(FIXNUM);
val->n_fixnum = n;
return (val);
}
/* cvflonum - convert a floating point number to a flonum node */
LVAL cvflonum(FLOTYPE n)
{
LVAL val;
val = newnode(FLONUM);
val->n_flonum = n;
return (val);
}
/* cvchar - convert an integer to a character node */
LVAL cvchar(int n)
{
if (n >= CHARMIN && n <= CHARMAX)
return (&charseg->sg_nodes[n-CHARMIN]);
xlerror("character code out of range",cvfixnum((FIXTYPE)n));
return NIL; /* won't reach this line */
}
/* newustream - create a new unnamed stream */
LVAL newustream(void)
{
LVAL val;
val = newnode(USTREAM);
sethead(val,NIL);
settail(val,NIL);
return (val);
}
/* newobject - allocate and initialize a new object */
LVAL newobject(LVAL cls, int size)
{
LVAL val;
val = newvector(size+1);
val->n_type = OBJECT;
setelement(val,0,cls);
return (val);
}
/* newclosure - allocate and initialize a new closure */
LVAL newclosure(LVAL name, LVAL type, LVAL env, LVAL fenv)
{
LVAL val;
val = newvector(CLOSIZE);
val->n_type = CLOSURE;
setname(val,name);
settype(val,type);
setenv(val,env);
setfenv(val,fenv);
return (val);
}
/* newvector - allocate and initialize a new vector node */
LVAL newvector(int size)
{
LVAL vect;
int bsize;
xlsave1(vect);
vect = newnode(VECTOR);
vect->n_vsize = 0;
if ((bsize = size * sizeof(LVAL))) {
if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
vect->n_vsize = size;
total += (long) bsize;
}
xlpop();
return (vect);
}
/* newnode - allocate a new node */
LVAL newnode(int type)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1L;
/* initialize the new node */
nnode->n_type = type;
rplacd(nnode,NIL);
/* return the new node */
return (nnode);
}
/* stralloc - allocate memory for a string adding a byte for the terminator */
LOCAL unsigned char *stralloc(int size)
{
unsigned char *sptr;
/* allocate memory for the string copy */
if ((sptr = (unsigned char *)malloc(size)) == NULL) {
gc();
if ((sptr = (unsigned char *)malloc(size)) == NULL)
xlfail("insufficient string space");
}
total += (long)size;
/* return the new string memory */
return (sptr);
}
/* findmem - find more memory by collecting then expanding */
LOCAL void findmem(void)
{
gc();
if (nfree < (long)anodes)
addseg();
}
/* gc - garbage collect (only called here and in xlimage.c) */
void gc(void)
{
register LVAL **p,*ap,tmp;
char buf[STRMAX+1];
LVAL *newfp,fun;
extern LVAL profile_fixnum;
/* print the start of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"[ gc: total %ld, ",nnodes);
stdputstr(buf);
}
/* mark the fixnum used by profiler */
if (!null(profile_fixnum)) mark(profile_fixnum);
/* mark the obarray, the argument list and the current environment */
if (obarray)
mark(obarray);
if (xlenv)
mark(xlenv);
if (xlfenv)
mark(xlfenv);
if (xldenv)
mark(xldenv);
/* mark the evaluation stack */
for (p = xlstack; p < xlstktop; ++p)
if ((tmp = **p))
mark(tmp);
/* mark the argument stack */
for (ap = xlargstkbase; ap < xlsp; ++ap)
if ((tmp = *ap))
mark(tmp);
/* sweep memory collecting all unmarked nodes */
sweep();
/* count the gc call */
++gccalls;
/* call the *gc-hook* if necessary */
if (s_gchook && (fun = getvalue(s_gchook))) {
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(cvfixnum((FIXTYPE)nnodes));
pusharg(cvfixnum((FIXTYPE)nfree));
xlfp = newfp;
xlapply(2);
}
/* print the end of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"%ld free", nfree);
stdputstr(buf);
/* print additional info (e.g. sound blocks in Nyquist) */
print_local_gc_info();
stdputstr(" ]\n");
stdflush(); /* output in a timely fashion so user sees progress */
}
#ifdef DEBUG_INPUT
if (debug_input_fp) {
int c = getc(debug_input_fp);
ungetc(c, debug_input_fp);
}
#endif
}
/* mark - mark all accessible nodes */
void mark(LVAL ptr)
{
register LVAL this,prev,tmp;
int type,i,n;
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
for (;;) {
/* descend as far as we can */
while (!(this->n_flags & MARK))
/* check cons and symbol nodes */
if (((type = ntype(this))) == CONS || type == USTREAM) {
if ((tmp = car(this))) {
this->n_flags |= MARK|LEFT;
rplaca(this,prev);
}
else if ((tmp = cdr(this))) {
this->n_flags |= MARK;
rplacd(this,prev);
}
else { /* both sides nil */
this->n_flags |= MARK;
break;
}
prev = this; /* step down the branch */
this = tmp;
}
/* mark other node types */
else {
this->n_flags |= MARK;
switch (type) {
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
for (i = 0, n = getsize(this); --n >= 0; ++i)
if ((tmp = getelement(this,i)))
mark(tmp);
break;
case EXTERN:
if (getdesc(this)->mark_meth) { (*(getdesc(this)->mark_meth))(getinst(this));
}
}
break;
}
/* backup to a point where we can continue descending */
for (;;)
/* make sure there is a previous node */
if (prev) {
if (prev->n_flags & LEFT) { /* came from left side */
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
if ((this = cdr(prev))) {
rplacd(prev,tmp);
break;
}
}
else { /* came from right side */
tmp = cdr(prev);
rplacd(prev,this);
}
this = prev; /* step back up the branch */
prev = tmp;
}
/* no previous node, must be done */
else
return;
}
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL void sweep(void)
{
SEGMENT *seg;
LVAL p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0L;
/* add all unmarked nodes */
for (seg = segs; seg; seg = seg->sg_next) {
if (seg == fixseg) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p) {
#ifdef DEBUG_MEM
if (xldmem_trace &&
ntype(p) == EXTERN &&
xldmem_trace == getinst(p)) {
printf("sweep: EXTERN node %lx is %smarked, points to %lx\n",
p, (p->n_flags & MARK ? "" : "un"), getinst(p));
}
#endif
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(LVAL));
free((void *) p->n_vdata);
}
break;
case EXTERN:
/* printf("GC about to free %x\n", p);
* fflush(stdout);
*/
if (getdesc(p)) { (*(getdesc(p)->free_meth))(getinst(p));
}
break;
}
p->n_type = FREE_NODE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
}
/* addseg - add a segment to the available memory */
LOCAL int addseg(void)
{
SEGMENT *newseg;
LVAL p;
int n;
/* allocate the new segment */
if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
return (FALSE);
/* add each new node to the free list */
p = &newseg->sg_nodes[0];
for (n = anodes; --n >= 0; ++p) {
rplacd(p,fnodes);
fnodes = p;
}
/* return successfully */
return (TRUE);
}
/* newsegment - create a new segment (only called here and in xlimage.c) */
SEGMENT *newsegment(int n)
{
SEGMENT *newseg;
/* allocate the new segment */
if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
return (NULL);
/* initialize the new segment */
newseg->sg_size = n;
newseg->sg_next = NULL;
if (segs)
lastseg->sg_next = newseg;
else
segs = newseg;
lastseg = newseg;
/* update the statistics */
total += (long)segsize(n);
nnodes += (long)n;
nfree += (long)n;
++nsegs;
/* return the new segment */
return (newseg);
}
/* stats - print memory statistics */
LOCAL void stats(void)
{
sprintf(buf,"Nodes: %ld\n",nnodes); stdputstr(buf);
sprintf(buf,"Free nodes: %ld\n",nfree); stdputstr(buf);
sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
}
/* xgc - xlisp function to force garbage collection */
LVAL xgc(void)
{
/* make sure there aren't any arguments */
xllastarg();
/* garbage collect */
gc();
/* return nil */
return (NIL);
}
/* xexpand - xlisp function to force memory expansion */
LVAL xexpand(void)
{
LVAL num;
int n,i;
/* get the new number to allocate */
if (moreargs()) {
num = xlgafixnum();
n = getfixnum(num);
}
else
n = 1;
xllastarg();
/* allocate more segments */
for (i = 0; i < n; i++)
if (!addseg())
break;
/* return the number of segments added */
return (cvfixnum((FIXTYPE)i));
}
/* xalloc - xlisp function to set the number of nodes to allocate */
LVAL xalloc(void)
{
int n,oldn;
LVAL num;
/* get the new number to allocate */
num = xlgafixnum();
n = getfixnum(num);
/* make sure there aren't any more arguments */
xllastarg();
/* set the new number of nodes to allocate */
oldn = anodes;
anodes = n;
/* return the old number */
return (cvfixnum((FIXTYPE)oldn));
}
/* xmem - xlisp function to print memory statistics */
LVAL xmem(void)
{
/* allow one argument for compatiblity with common lisp */
if (moreargs()) xlgetarg();
xllastarg();
/* print the statistics */
stats();
/* return nil */
return (NIL);
}
/* xinfo - show information on control-t */
LVAL xinfo()
{
char buf[80];
sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %d",
(int)nfree, (int)gccalls, (int)total);
stdputstr(buf);
print_local_gc_info();
stdputstr("]\n");
return NULL;
}
#ifdef SAVERESTORE
/* xsave - save the memory image */
LVAL xsave(void)
{
unsigned char *name;
/* get the file name, verbose flag and print flag */
name = getstring(xlgetfname());
xllastarg();
/* save the memory image */
return (xlisave((char *) name) ? s_true : NIL);
}
/* xrestore - restore a saved memory image */
LVAL xrestore(void)
{
extern jmp_buf top_level;
unsigned char *name;
/* get the file name, verbose flag and print flag */
name = getstring(xlgetfname());
xllastarg();
/* restore the saved memory image */
if (!xlirestore((char *) name))
return (NIL);
/* return directly to the top level */
stdputstr("[ returning to the top level ]\n");
_longjmp(top_level,1);
}
#endif
/* xlminit - initialize the dynamic memory module */
void xlminit(void)
{
LVAL p;
int i;
/* initialize our internal variables */
segs = lastseg = NULL;
nnodes = nfree = total = 0L;
nsegs = gccalls = 0;
anodes = NNODES;
fnodes = NIL;
/* allocate the fixnum segment */
if ((fixseg = newsegment(SFIXSIZE)) == NULL)
xlfatal("insufficient memory");
/* initialize the fixnum segment */
p = &fixseg->sg_nodes[0];
for (i = SFIXMIN; i <= SFIXMAX; ++i) {
p->n_type = FIXNUM;
p->n_fixnum = i;
++p;
}
/* allocate the character segment */
if ((charseg = newsegment(CHARSIZE)) == NULL)
xlfatal("insufficient memory");
/* initialize the character segment */
p = &charseg->sg_nodes[0];
for (i = CHARMIN; i <= CHARMAX; ++i) {
p->n_type = CHAR;
p->n_chcode = i;
++p;
}
/* initialize structures that are marked by the collector */
obarray = xlenv = xlfenv = xldenv = NIL;
s_gcflag = s_gchook = NIL;
/* allocate the evaluation stack */
if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
xlfatal("insufficient memory");
xlstack = xlstktop = xlstkbase + EDEPTH;
/* allocate the argument stack */
if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
xlfatal("insufficient memory");
// printf("ADEPTH is %d\n", ADEPTH);
xlargstktop = xlargstkbase + ADEPTH;
xlfp = xlsp = xlargstkbase;
*xlsp++ = NIL;
}