4.3BSD - /usr/src/ucb/lisp/franz/alloc.c

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: alloc.c,v 1.12 85/03/24 10:59:57 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Thu Feb  2 16:15:30 1984 by jkf]-
   7:  * 	alloc.c				$Locker:  $
   8:  * storage allocator and garbage collector
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: # include "global.h"
  14: # include "structs.h"
  15: 
  16: #include <sys/types.h>
  17: #include <sys/times.h>
  18: #ifdef METER
  19: #include <sys/vtimes.h>
  20: #endif
  21: 
  22: # define NUMWORDS TTSIZE * 128  /*  max number of words in P0 space  */
  23: # define BITQUADS TTSIZE * 2    /*  length of bit map in quad words  */
  24: # define BITLONGS TTSIZE * 4    /*  length of bit map in long words  */
  25: 
  26: # ifdef vax
  27: # define ftstbit    asm("	ashl	$-2,r11,r3");\
  28:             asm("	bbcs	r3,_bitmapi,1f");\
  29:             asm("	ret"); \
  30:             asm("1:");
  31: 
  32: /* setbit is a fast way of setting a bit, it is like ftstbit except it
  33:  * always continues on to the next instruction
  34:  */
  35: # define setbit     asm("	ashl	$-2,r11,r0"); \
  36:             asm("	bbcs	r0,_bitmapi,$0");
  37: # endif
  38: 
  39: # if m_68k
  40: # define ftstbit {if(Itstbt()) return;}
  41: # define setbit Itstbt()
  42: # endif
  43: 
  44: /*  define ftstbit	if( readbit(p) ) return; oksetbit;  */
  45: # define readbit(p) ((int)bbitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
  46: # define lookbit(p) (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
  47: /* # define setbit(p)	{bbitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} */
  48: # define oksetbit   {bbitmap[r] |= s;}
  49: 
  50: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
  51: # define setchk(p)  {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
  52: # define roundup(x,l)   (((x - 1) | (l - 1)) + 1)
  53: 
  54: # define MARKVAL(v) if(((int)v) >= (int)beginsweep) markdp(v);
  55: # define ATOLX(p)   ((((int)p)-OFFSET)>>7)
  56: 
  57: /* the Vax hardware only allows 2^16-1 bytes to be accessed with one
  58:  * movc5 instruction.  We use the movc5 instruction to clear the
  59:  * bitmaps.
  60:  */
  61: # define MAXCLEAR ((1<<16)-1)
  62: 
  63: /* METER denotes something added to help meter storage allocation. */
  64: 
  65: extern int *beginsweep;         /* first sweepable data		*/
  66: extern char purepage[];
  67: extern int fakettsize;
  68: extern int gcstrings;
  69: int debugin  = FALSE;   /* temp debug flag */
  70: 
  71: extern lispval datalim;         /*  end of data space */
  72: int bitmapi[BITLONGS];          /*  the bit map--one bit per long  */
  73: double zeroq;               /*  a quad word of zeros  */
  74: char *bbitmap = (char *) bitmapi;   /*  byte version of bit map array */
  75: double  *qbitmap = (double *) bitmapi;  /*  integer version of bit map array */
  76: #ifdef METER
  77: extern int gcstat;
  78: extern struct vtimes
  79:     premark,presweep,alldone;   /* actually struct tbuffer's */
  80: 
  81: extern int mrkdpcnt;
  82: extern int conssame, consdiff,consnil;  /* count of cells whose cdr point
  83: 					 * to the same page and different
  84: 					 * pages respectively
  85: 					 */
  86: #endif
  87: char bitmsk[8]={1,2,4,8,16,32,64,128};  /*  used by bit-marking macros  */
  88: extern int  *bind_lists ;       /*  lisp data for compiled code */
  89: 
  90: char *xsbrk();
  91: char *gethspace();
  92: 
  93: 
  94: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
  95:     array_str, sdot_str, val_str, funct_str, hunk_str[], vect_str,
  96:     vecti_str, other_str;
  97: 
  98: extern struct str_x str_current[];
  99: 
 100: lispval hunk_items[7], hunk_pages[7], hunk_name[7];
 101: 
 102: extern int initflag; /* starts off TRUE: initially gc not allowed */
 103: 
 104: 
 105: /* this is a table of pointers to all struct types objects
 106:  * the index is the type number.
 107:  */
 108: static struct types *spaces[NUMSPACES] =
 109:     {&strng_str, &atom_str, &int_str,
 110:      &dtpr_str, &doub_str, &funct_str,
 111:      (struct types *) 0,  /* port objects not allocated in this way  */
 112:      &array_str,
 113:      &other_str,  /* other objects not allocated in this way  */
 114:      &sdot_str,&val_str,
 115:      &hunk_str[0], &hunk_str[1], &hunk_str[2],
 116:      &hunk_str[3], &hunk_str[4], &hunk_str[5],
 117:      &hunk_str[6],
 118:      &vect_str, &vecti_str};
 119: 
 120: 
 121: /* this is a table of pointers to collectable struct types objects
 122:  * the index is the type number.
 123:  */
 124: struct types *gcableptr[] = {
 125: #ifndef GCSTRINGS
 126:      (struct types *) 0,  /* strings not collectable */
 127: #else
 128:      &strng_str,
 129: #endif
 130:      &atom_str,
 131:      &int_str, &dtpr_str, &doub_str,
 132:      (struct types *) 0,  /* binary objects not collectable */
 133:      (struct types *) 0,  /* port objects not collectable */
 134:      &array_str,
 135:      (struct types *) 0,  /* gap in the type number sequence */
 136:      &sdot_str,&val_str,
 137:      &hunk_str[0], &hunk_str[1], &hunk_str[2],
 138:      &hunk_str[3], &hunk_str[4], &hunk_str[5],
 139:      &hunk_str[6],
 140:      &vect_str, &vecti_str};
 141: 
 142: 
 143: /*
 144:  *   get_more_space(type_struct,purep)
 145:  *
 146:  *  Allocates and structures a new page, returning 0.
 147:  *  If no space is available, returns positive number.
 148:  *  If purep is TRUE, then pure space is allocated.
 149:  */
 150: get_more_space(type_struct,purep)
 151: struct types *type_struct;
 152: {
 153:     int cntr;
 154:     char *start;
 155:     int *loop, *temp;
 156:     lispval p;
 157:     extern char holend[];
 158: 
 159:     if( (int) datalim >= TTSIZE*LBPG+OFFSET ) return(2);
 160: 
 161:     /*
 162: 	 * If the hole is defined, then we allocate binary objects
 163: 	 * and strings in the hole.  However we don't put strings in
 164: 	 * the hole if strings are gc'ed.
 165: 	 */
 166: #ifdef HOLE
 167:     if(   purep
 168: #ifndef GCSTRINGS
 169:        || type_struct==&strng_str
 170: #endif
 171:        || type_struct==&funct_str)
 172:         start = gethspace(LBPG,type_struct->type);
 173:     else
 174: #endif
 175:         start = xsbrk(1);       /* get new page */
 176: 
 177: 
 178:     SETTYPE(start, type_struct->type,20);  /*  set type of page  */
 179: 
 180:     purepage[ATOX(start)] = (char)purep;  /* remember if page was pure*/
 181: 
 182:     /* bump the page counter for this space if not pure */
 183: 
 184:     if(!purep) ++((*(type_struct->pages))->i);
 185: 
 186:     type_struct->space_left = type_struct->space;
 187:     temp = loop = (int *) start;
 188:     for(cntr=1; cntr < type_struct->space; cntr++)
 189:         loop = (int *) (*loop = (int) (loop + type_struct->type_len));
 190: 
 191:     /* attach new cells to either the pure space free list  or the
 192: 	 * standard free list
 193: 	 */
 194:     if(purep) {
 195:         *loop = (int) (type_struct->next_pure_free);
 196:         type_struct->next_pure_free = (char *) temp;
 197:     }
 198:     else  {
 199:         *loop = (int) (type_struct->next_free);
 200:         type_struct->next_free = (char *) temp;
 201:     }
 202: 
 203:     /*  if type atom, set pnames to CNIL  */
 204: 
 205:     if( type_struct == &atom_str )
 206:         for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
 207:             {
 208:             p->a.pname = (char *) CNIL;
 209:             p = (lispval) ((int *)p + atom_str.type_len);
 210:             }
 211:     return(0);  /*  space was available  */
 212: }
 213: 
 214: 
 215: /*
 216:  * next_one(type_struct)
 217:  *
 218:  *  Allocates one new item of each kind of space, except STRNG.
 219:  *  If there is no space, calls gc, the garbage collector.
 220:  *  If there is still no space, allocates a new page using
 221:  *  get_more_space
 222:  */
 223: 
 224: lispval
 225: next_one(type_struct)
 226: struct types *type_struct;
 227: {
 228: 
 229:     register char *temp;
 230: 
 231:     while(type_struct->next_free == (char *) CNIL)
 232:         {
 233:         int g;
 234: 
 235:         if(
 236:            (initflag == FALSE) &&   /* dont gc during init */
 237: #ifndef GCSTRINGS
 238:            (type_struct->type != STRNG) && /* can't collect strings */
 239: #else
 240:            gcstrings &&         /* user (sstatus gcstrings) */
 241: #endif
 242:            (type_struct->type != BCD) &&   /* nor function headers  */
 243:            gcdis->a.clb == nil )        /* gc not disabled */
 244:                     /* not to collect during load */
 245: 
 246:             {
 247:             gc(type_struct);  /*  collect  */
 248:             }
 249: 
 250:         if( type_struct->next_free != (char *) CNIL ) break;
 251: 
 252:         if(! (g=get_more_space(type_struct,FALSE))) break;
 253: 
 254:         space_warn(g);
 255:         }
 256:     temp = type_struct->next_free;
 257:     type_struct->next_free = * (char **)(type_struct->next_free);
 258:     (*(type_struct->items))->i ++;
 259:     return((lispval) temp);
 260: }
 261: /*
 262:  * Warn about exhaustion of space,
 263:  * shared with next_pure_free().
 264:  */
 265: space_warn(g)
 266: {
 267:     if( g==1 ) {
 268:         plimit->i += NUMSPACES; /*  allow a few more pages  */
 269:         copval(plima,plimit);   /*  restore to reserved reg  */
 270: 
 271:         error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", TRUE);
 272:     } else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", TRUE);
 273: }
 274: 
 275: 
 276: /* allocate an element of a pure structure.  Pure structures will
 277:  * be ignored by the garbage collector.
 278:  */
 279: lispval
 280: next_pure_one(type_struct)
 281: struct types *type_struct;
 282: {
 283: 
 284:     register char *temp;
 285: 
 286:     while(type_struct->next_pure_free == (char *) CNIL)
 287:         {
 288:         int g;
 289:         if(! (g=get_more_space(type_struct,TRUE))) break;
 290:         space_warn(g);
 291:         }
 292: 
 293:     temp = type_struct->next_pure_free;
 294:     type_struct->next_pure_free = * (char **)(type_struct->next_pure_free);
 295:     return((lispval) temp);
 296: }
 297: 
 298: lispval
 299: newint()
 300: {
 301:     return(next_one(&int_str));
 302: }
 303: 
 304: lispval
 305: pnewint()
 306: {
 307:     return(next_pure_one(&int_str));
 308: }
 309: 
 310: lispval
 311: newdot()
 312: {
 313:     lispval temp;
 314: 
 315:     temp = next_one(&dtpr_str);
 316:     temp->d.car = temp->d.cdr = nil;
 317:     return(temp);
 318: }
 319: 
 320: lispval
 321: pnewdot()
 322: {
 323:     lispval temp;
 324: 
 325:     temp = next_pure_one(&dtpr_str);
 326:     temp->d.car = temp->d.cdr = nil;
 327:     return(temp);
 328: }
 329: 
 330: lispval
 331: newdoub()
 332: {
 333:     return(next_one(&doub_str));
 334: }
 335: 
 336: lispval
 337: pnewdb()
 338: {
 339:     return(next_pure_one(&doub_str));
 340: }
 341: 
 342: lispval
 343: newsdot()
 344: {
 345:     register lispval temp;
 346:     temp = next_one(&sdot_str);
 347:     temp->d.car = temp->d.cdr = 0;
 348:     return(temp);
 349: }
 350: 
 351: lispval
 352: pnewsdot()
 353: {
 354:     register lispval temp;
 355:     temp = next_pure_one(&sdot_str);
 356:     temp->d.car = temp->d.cdr = 0;
 357:     return(temp);
 358: }
 359: 
 360: struct atom *
 361: newatom(pure) {
 362:     struct atom *save; char *mypname;
 363: 
 364:     mypname = newstr(pure);
 365:     pnameprot = ((lispval) mypname);
 366:     save = (struct atom *) next_one(&atom_str) ;
 367:     save->plist = save->fnbnd = nil;
 368:     save->hshlnk = (struct atom *)CNIL;
 369:     save->clb = CNIL;
 370:     save->pname = mypname;
 371:     return (save);
 372: }
 373: 
 374: char *
 375: newstr(purep) {
 376:     char *save, *strcpy();
 377:     int atmlen;
 378:     register struct str_x *p = str_current + purep;
 379: 
 380:     atmlen = strlen(strbuf)+1;
 381:     if(atmlen > p->space_left) {
 382:         if(atmlen >= STRBLEN) {
 383:             save = (char *)csegment(OTHER, atmlen, purep);
 384:             SETTYPE(save,STRNG,40);
 385:             purepage[ATOX(save)] = (char)purep;
 386:             strcpy(save,strbuf);
 387:             return(save);
 388:         }
 389:         p->next_free =  (char *) (purep ?
 390:             next_pure_one(&strng_str) : next_one(&strng_str)) ;
 391:         p->space_left = LBPG;
 392:     }
 393:     strcpy((save = p->next_free), strbuf);
 394:     /*while(atmlen & 3) ++atmlen;	/*  even up length of string  */
 395:     p->next_free += atmlen;
 396:     p->space_left -= atmlen;
 397:     return(save);
 398: }
 399: 
 400: static char * Iinewstr(s,purep) char *s;
 401: {
 402:     int len = strlen(s);
 403:     while(len > (endstrb - strbuf - 1)) atomtoolong(strbuf);
 404:     strcpy(strbuf,s);
 405:     return(newstr(purep));
 406: }
 407: 
 408: 
 409: char *inewstr(s) char *s;
 410: {
 411:     Iinewstr(s,0);
 412: }
 413: 
 414: char *pinewstr(s) char *s;
 415: {
 416:     Iinewstr(s,1);
 417: }
 418: 
 419: lispval
 420: newarray()
 421:     {
 422:     register lispval temp;
 423: 
 424:     temp = next_one(&array_str);
 425:     temp->ar.data = (char *)nil;
 426:     temp->ar.accfun = nil;
 427:     temp->ar.aux = nil;
 428:     temp->ar.length = SMALL(0);
 429:     temp->ar.delta = SMALL(0);
 430:     return(temp);
 431:     }
 432: 
 433: lispval
 434: newfunct()
 435:     {
 436:     register lispval temp;
 437:     lispval Badcall();
 438:     temp = next_one(&funct_str);
 439:     temp->bcd.start = Badcall;
 440:     temp->bcd.discipline = nil;
 441:     return(temp);
 442:     }
 443: 
 444: lispval
 445: newval()
 446:     {
 447:     register lispval temp;
 448:     temp = next_one(&val_str);
 449:     temp->l = nil;
 450:     return(temp);
 451:     }
 452: 
 453: lispval
 454: pnewval()
 455:     {
 456:     register lispval temp;
 457:     temp = next_pure_one(&val_str);
 458:     temp->l = nil;
 459:     return(temp);
 460:     }
 461: 
 462: lispval
 463: newhunk(hunknum)
 464: int hunknum;
 465:     {
 466:     register lispval temp;
 467: 
 468:     temp = next_one(&hunk_str[hunknum]);    /* Get a hunk */
 469:     return(temp);
 470:     }
 471: 
 472: lispval
 473: pnewhunk(hunknum)
 474: int hunknum;
 475:     {
 476:     register lispval temp;
 477: 
 478:     temp = next_pure_one(&hunk_str[hunknum]);   /* Get a hunk */
 479:     return(temp);
 480:     }
 481: 
 482: lispval
 483: inewval(arg) lispval arg;
 484:     {
 485:     lispval temp;
 486:     temp = next_one(&val_str);
 487:     temp->l = arg;
 488:     return(temp);
 489:     }
 490: 
 491: /*
 492:  * Vector allocators.
 493:  * a vector looks like:
 494:  *  longword: N = size in bytes
 495:  *  longword: pointer to lisp object, this is the vector property field
 496:  *  N consecutive bytes
 497:  *
 498:  */
 499: lispval getvec();
 500: 
 501: lispval
 502: newvec(size)
 503: {
 504:     return(getvec(size,&vect_str,FALSE));
 505: }
 506: 
 507: lispval
 508: pnewvec(size)
 509: {
 510:     return(getvec(size,&vect_str,TRUE));
 511: }
 512: 
 513: lispval
 514: nveci(size)
 515: {
 516:     return(getvec(size,&vecti_str,FALSE));
 517: }
 518: 
 519: lispval
 520: pnveci(size)
 521: {
 522:     return(getvec(size,&vecti_str,TRUE));
 523: }
 524: 
 525: /*
 526:  * getvec
 527:  *  get a vector of size byte, from type structure typestr and
 528:  * get it from pure space if purep is TRUE.
 529:  *  vectors are stored linked through their property field.  Thus
 530:  * when the code here refers to v.vector[0], it is the prop field
 531:  * and vl.vectorl[-1] is the size field.   In other code,
 532:  * v.vector[-1] is the prop field, and vl.vectorl[-2] is the size.
 533:  */
 534: lispval
 535: getvec(size,typestr,purep)
 536: register struct types *typestr;
 537: {
 538:     register lispval back, current;
 539:     int sizewant, bytes, thissize, pages, pindex, triedgc = FALSE;
 540: 
 541:     /* we have to round up to a multiple of 4 bytes to determine the
 542:      * size of vector we want.  The rounding up assures that the
 543:      * property pointers are longword aligned
 544:      */
 545:     sizewant = VecTotSize(size);
 546:     if(debugin) fprintf(stderr,"want vect %db\n",size);
 547:  again:
 548:     if(purep)
 549:         back = (lispval) &(typestr->next_pure_free);
 550:     else
 551:         back = (lispval) &(typestr->next_free);
 552:     current = back->v.vector[0];
 553:     while(current !=  CNIL)
 554:     {
 555:     if(debugin)
 556:             fprintf(stderr,"next free size %db; ", current->vl.vectorl[-1]);
 557:     if ((thissize = VecTotSize(current->vl.vectorl[-1])) == sizewant)
 558:     {
 559:         if(debugin) fprintf(stderr,"exact match of size %d at 0x%x\n",
 560:                     4*thissize, &current->v.vector[1]);
 561:         back->v.vector[0]
 562:             = current->v.vector[0];/* change free pointer*/
 563:         current->v.vector[0] = nil; /* put nil in property */
 564:         /* to the user, vector begins one after property*/
 565:         return((lispval)&current->v.vector[1]);
 566:     }
 567:     else if (thissize >= sizewant + 3)
 568:     {
 569:         /* the reason that there is a `+ 3' instead of `+ 2'
 570: 	     * is that we don't want to leave a zero sized vector which
 571: 	     * isn't guaranteed to be followed by another vector
 572: 	     */
 573:         if(debugin)
 574:          fprintf(stderr,"breaking a %d vector into a ",
 575:                         current->vl.vectorl[-1]);
 576: 
 577:         current->v.vector[1+sizewant+1]
 578:                 = current->v.vector[0];  /* free list pointer */
 579:         current->vl.vectorl[1+sizewant]
 580:                 = VecTotToByte(thissize - sizewant - 2);/*size info */
 581:         back->v.vector[0] = (lispval) &(current->v.vector[1+sizewant+1]);
 582:         current->vl.vectorl[-1] = size;
 583: 
 584:         if(debugin)fprintf(stderr," %d one and a %d one\n",
 585:             current->vl.vectorl[-1],current->vl.vectorl[1+sizewant]);
 586:         current->v.vector[0] = nil; /* put nil in property */
 587:         /* vector begins one after the property */
 588:         if(debugin) fprintf(stderr," and returning vector at 0x%x\n",
 589:                     &current->v.vector[1]);
 590:         return((lispval)(&current->v.vector[1]));
 591:     }
 592:     back =  current;
 593:     current =  current->v.vector[0];
 594:     }
 595:     if(!triedgc
 596:         && !purep
 597:         && (gcdis->a.clb == nil)
 598:     && (initflag == FALSE))
 599:     {
 600:     gc(typestr);
 601:     triedgc = TRUE;
 602:     goto again;
 603:     }
 604: 
 605:     /* set bytes to size needed for this vector */
 606:     bytes = size + 2*sizeof(long);
 607: 
 608:     /* must make sure that if the vector we are allocating doesnt
 609:        completely fill a page, there is room for another vector to record
 610:        the size left over */
 611:     if((bytes & (LBPG - 1)) > (LBPG - 2*sizeof(long))) bytes += LBPG;
 612:     bytes = roundup(bytes,LBPG);
 613: 
 614:     current = csegment(typestr->type,bytes/sizeof(long),purep);
 615:     current->vl.vectorl[0] = bytes - 2*sizeof(long);
 616: 
 617:     if(purep) {
 618:         current->v.vector[1] = (lispval)(typestr->next_pure_free);
 619:         typestr->next_pure_free = (char *) &(current->v.vector[1]);
 620:     /* make them pure */
 621:     pages = bytes/LBPG;
 622:     for(pindex = ATOX(current); pages ; pages--)
 623:     {
 624:         purepage[pindex++] = TRUE;
 625:     }
 626:     } else {
 627:         current->v.vector[1] = (lispval)(typestr->next_free);
 628:         typestr->next_free = (char *) &(current->v.vector[1]);
 629:     if(debugin) fprintf(stderr,"grabbed %d vec pages\n",bytes/LBPG);
 630:     }
 631:     if(debugin)
 632:       fprintf(stderr,"creating a new vec, size %d\n",current->v.vector[0]);
 633:     goto again;
 634: }
 635: 
 636: /*
 637:  * Ipurep :: routine to check for pureness of a data item
 638:  *
 639:  */
 640: lispval
 641: Ipurep(element)
 642: lispval element;
 643: {
 644:     if(purepage[ATOX(element)]) return(tatom) ; else return(nil);
 645: }
 646: 
 647: /* routines to return space to the free list.  These are used by the
 648:  * arithmetic routines which tend to create large intermediate results
 649:  * which are know to be garbage after the calculation is over.
 650:  *
 651:  * There are jsb callable versions of these routines in qfuncl.s
 652:  */
 653: 
 654: /* pruneb   - prune bignum. A bignum is an sdot followed by a list of
 655:  *  dtprs.    The dtpr list is linked by car instead of cdr so when we
 656:  *  put it in the free list, we have to change the links.
 657:  */
 658: pruneb(bignum)
 659: lispval bignum;
 660: {
 661:     register lispval temp = bignum;
 662: 
 663:     if(TYPE(temp) != SDOT)
 664:         errorh(Vermisc,"value to pruneb not a sdot",nil,FALSE,0);
 665: 
 666:     --(sdot_items->i);
 667:     temp->s.I = (int) sdot_str.next_free;
 668:     sdot_str.next_free = (char *) temp;
 669: 
 670:     /* bignums are not terminated by nil on the dual,
 671: 	   they are terminated by (lispval) 0 */
 672: 
 673:     while(temp = temp->s.CDR)
 674:     {
 675:         if(TYPE(temp) != DTPR)
 676:           errorh(Vermisc,"value to pruneb not a list",
 677:               nil,FALSE,0);
 678:         --(dtpr_items->i);
 679:         temp->s.I = (int) dtpr_str.next_free;
 680:         dtpr_str.next_free = (char *) temp;
 681:     }
 682: }
 683: lispval
 684: Badcall()
 685:     { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
 686: 
 687: 
 688: 
 689: /*
 690:  * Ngc
 691:  *  this is the lisp function gc
 692:  *
 693:  */
 694: 
 695: lispval
 696: Ngc()
 697: {
 698:     return(gc((struct types *)CNIL));
 699: }
 700: 
 701: /*
 702:  * gc(type_struct)
 703:  *
 704:  *  garbage collector:  Collects garbage by mark and sweep algorithm.
 705:  *  After this is done, calls the Nlambda, gcafter.
 706:  *  gc may also be called from LISP, as an  nlambda of no arguments.
 707:  * type_struct is the type of lisp data that ran out causing this
 708:  * garbage collection
 709:  */
 710: int printall = 0;
 711: lispval
 712: gc(type_struct)
 713:     struct types *type_struct;
 714:     {
 715:     lispval save;
 716:     struct tms begin, finish;
 717:     extern int gctime;
 718: 
 719:     /* if this was called automatically when space ran out
 720: 	 * print out a message
 721: 	 */
 722:     if((Vgcprint->a.clb != nil)
 723:        && (type_struct != (struct types *) CNIL ))
 724:     {
 725:         FILE *port = okport(Vpoport->a.clb,poport);
 726:         fprintf(port,"gc:");
 727:         fflush(port);
 728:     }
 729: 
 730:     if(gctime) times(&begin);
 731: 
 732:     gc1(); /* mark&sweep */
 733: 
 734:     /* Now we call gcafter--special c ase if gc called from LISP */
 735: 
 736:     if( type_struct == (struct types *) CNIL )
 737:         gccall1->d.cdr = nil;  /* make the call "(gcafter)" */
 738:     else
 739:         {
 740:         gccall1->d.cdr = gccall2;
 741:         gccall2->d.car = *(type_struct->type_name);
 742:         }
 743:     PUSHDOWN(gcdis,gcdis);  /*  flag to indicate in garbage collector  */
 744:     save = eval(gccall1);   /*  call gcafter  */
 745:     POP;            /*  turn off flag  */
 746: 
 747:     if(gctime) {
 748:         times(&finish);
 749:         gctime += (finish.tms_utime - begin.tms_utime);
 750:     }
 751:     return(save);   /*  return result of gcafter  */
 752:     }
 753: 
 754: 
 755: 
 756: /*  gc1()  **************************************************************/
 757: /*									*/
 758: /*  Mark-and-sweep phase						*/
 759: 
 760: gc1()
 761: {
 762:     int j, k;
 763:     register int *start,bvalue,type_len;
 764:     register struct types *s;
 765:     int *point,i,freecnt,itemstogo,bits,bindex,type,bytestoclear;
 766:     int usedcnt;
 767:     char *pindex;
 768:     struct argent *loop2;
 769:     struct nament *loop3;
 770:     struct atom *symb;
 771:     int markdp();
 772:     extern int hashtop;
 773: 
 774:     pagerand();
 775:     /*  decide whether to check LISP structure or not  */
 776: 
 777: 
 778: #ifdef METER
 779:     vtimes(&premark,0);
 780:     mrkdpcnt = 0;
 781:     conssame = consdiff = consnil = 0;
 782: #endif
 783: 
 784:     /*  first set all bit maps to zero  */
 785: 
 786: 
 787: #ifdef SLOCLEAR
 788:     {
 789:         int enddat;
 790:         enddat = (int)(datalim-OFFSET) >> 8;
 791:         for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
 792:         {
 793:          qbitmap[bvalue] = zeroq;
 794:         }
 795:     }
 796: #endif
 797: 
 798:     /* try the movc5 to clear the bit maps */
 799:     /* the maximum number of bytes we can clear in one sweep is
 800: 	 * 2^16 (or 1<<16 in the C lingo)
 801: 	 */
 802:     bytestoclear = ((((int)datalim)-((int)beginsweep)) >> 9) * 16;
 803:     for(start = bitmapi + ATOLX(beginsweep);
 804:         bytestoclear > 0;)
 805:         {
 806:         if(bytestoclear > MAXCLEAR)
 807:             blzero((int)start,MAXCLEAR);
 808:         else
 809:             blzero((int)start,bytestoclear);
 810:         start = (int *) (MAXCLEAR + (int) start);
 811:         bytestoclear -= MAXCLEAR;
 812:         }
 813: 
 814:     /* mark all atoms in the oblist */
 815:         for( bvalue=0 ; bvalue <= hashtop-1 ; bvalue++ ) /* though oblist */
 816:         {
 817:         for( symb = hasht[bvalue] ; symb != (struct atom *) CNIL ;
 818:               symb = symb-> hshlnk) {
 819:           markdp((lispval)symb);
 820:         }
 821:     }
 822: 
 823: 
 824:     /* Mark all the atoms and ints associated with the hunk
 825: 	   data types */
 826: 
 827:     for(i=0; i<7; i++) {
 828:         markdp(hunk_items[i]);
 829:         markdp(hunk_name[i]);
 830:         markdp(hunk_pages[i]);
 831:     }
 832:     /* next run up the name stack */
 833:     for(loop2 = np - 1; loop2 >=  orgnp; --loop2) MARKVAL(loop2->val);
 834: 
 835:     /* now the bindstack (vals only, atoms are marked elsewhere ) */
 836:     for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)MARKVAL(loop3->val);
 837: 
 838: 
 839:     /* next mark all compiler linked data */
 840:     /* if the Vpurcopylits switch is non nil (lisp variable $purcopylits)
 841: 	 * then when compiled code is read in, it tables will not be linked
 842: 	 * into this table and thus will not be marked here.  That is ok
 843: 	 * though, since that data is assumed to be pure.
 844: 	 */
 845:      point = bind_lists;
 846:      while((start = point) != (int *)CNIL) {
 847:         while( *start != -1 )
 848:         {
 849:             markdp((lispval)*start);
 850:             start++;
 851:         }
 852:         point = (int *)*(point-1);
 853:      }
 854: 
 855:     /* next mark all system-significant lisp data */
 856: 
 857: 
 858:     for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
 859: 
 860: #ifdef METER
 861:     vtimes(&presweep,0);
 862: #endif
 863:     /* all accessible data has now been marked. */
 864:     /* all collectable spaces must be swept,    */
 865:     /* and freelists constructed.		    */
 866: 
 867:     /* first clear the structure elements for types
 868: 	 * we will sweep
 869: 	 */
 870: 
 871:     for(k=0 ; k <= VECTORI ; k++)
 872:     {
 873:         if( s=gcableptr[k]) {
 874:             if(k==STRNG && !gcstrings) { /* don't do anything*/ }
 875:             else
 876:             {
 877:               (*(s->items))->i = 0;
 878:               s->space_left = 0;
 879:               s->next_free = (char *) CNIL;
 880:             }
 881:         }
 882:     }
 883: #if m_68k
 884:     fixbits(bitmapi+ATOLX(beginsweep),bitmapi+ATOLX(datalim));
 885: #endif
 886: 
 887: 
 888:     /* sweep up in memory looking at gcable pages */
 889: 
 890:     for(start = beginsweep,  bindex = ATOLX(start),
 891:           pindex = &purepage[ATOX(start)];
 892:         start < (int *)datalim;
 893:         start += 128, pindex++)
 894:     {
 895:         if(!(s=gcableptr[type = TYPE(start)]) || *pindex
 896: #ifdef GCSTRINGS
 897:          || (type==STRNG && !gcstrings)
 898: #endif
 899:         )
 900:         {
 901:         /* ignore this page but advance pointer 	*/
 902:         bindex += 4;   /* and 4 words of 32 bit bitmap words */
 903:         continue;
 904:         }
 905: 
 906:         freecnt = 0;        /* number of free items found */
 907:         usedcnt = 0;        /* number of used items found */
 908: 
 909:         point = start;
 910:         /* sweep dtprs as a special case, since
 911: 	     * 1) there will (usually) be more dtpr pages than any other type
 912: 	     * 2) most dtpr pages will be empty so we can really win by special
 913: 	     *    caseing the sweeping of massive numbers of free cells
 914: 	     */
 915:         /* since sdot's have the same structure as dtprs, this code will
 916: 	       work for them too
 917: 	     */
 918:         if((type == DTPR) || (type == SDOT))
 919:         {
 920:         int *head,*lim;
 921:         head = (int *) s->next_free;    /* first value on free list*/
 922: 
 923:         for(i=0; i < 4; i++)    /* 4 bit map words per page  */
 924:         {
 925:             bvalue = bitmapi[bindex++]; /* 32 bits = 16 dtprs */
 926:             if(bvalue == 0) /* if all are free	*/
 927:             {
 928:             *point = (int)head;
 929:             lim = point + 32;   /* 16 dtprs = 32 ints */
 930:             for(point += 2; point < lim ; point += 2)
 931:             {
 932:                 *point = (int)(point - 2);
 933:             }
 934:             head = point - 2;
 935:             freecnt += 16;
 936:             }
 937:             else for(j = 0; j < 16 ; j++)
 938:             {
 939:             if(!(bvalue & 1))
 940:             {
 941:                 freecnt++;
 942:                 *point = (int)head;
 943:                 head = point;
 944:             }
 945: #ifdef METER
 946:             /* check if the page address of this cell is the
 947: 			 * same as the address of its cdr
 948: 			 */
 949:             else if(FALSE && gcstat && (type == DTPR))
 950:             {
 951:                if(((int)point & ~511)
 952:                   == ((int)(*point) & ~511)) conssame++;
 953:                else consdiff++;
 954:                usedcnt++;
 955:             }
 956: #endif
 957:             else usedcnt++;     /* keep track of used */
 958: 
 959:             point += 2;
 960:             bvalue = bvalue >> 2;
 961:             }
 962:         }
 963:         s->next_free = (char *) head;
 964:         }
 965:         else if((type == VECTOR) || (type == VECTORI))
 966:         {
 967:         int canjoin = FALSE;
 968:         int *tempp;
 969: 
 970:         /* check if first item on freelist ends exactly at
 971: 		   this page
 972: 		 */
 973:         if(((tempp = (int *)s->next_free) != (int *)CNIL)
 974:            && ((VecTotSize(((lispval)tempp)->vl.vectorl[-1])
 975:                                 + 1 + tempp)
 976:                     == point))
 977:            canjoin = TRUE;
 978: 
 979:         /* arbitrary sized vector sweeper */
 980:         /*
 981: 		 * jump past first word since that is a size fixnum
 982: 		 * and second word since that is property word
 983: 		 */
 984:         if(debugin)
 985:           fprintf(stderr,"vector sweeping, start at 0x%x\n",
 986:                 point);
 987:         bits = 30;
 988:         bvalue = bitmapi[bindex++] >> 2;
 989:         point += 2;
 990:         while (TRUE) {
 991:             type_len = point[VSizeOff];
 992:             if(debugin) {
 993:               fprintf(stderr,"point: 0x%x, type_len %d\n",
 994:                     point, type_len);
 995:               fprintf(stderr,"bvalue: 0x%x, bits: %d, bindex: 0x%x\n",
 996:                 bvalue, bits, bindex);
 997:             }
 998:                         /* get size of vector */
 999:             if(!(bvalue & 1))   /* if free */
1000:             {
1001:             if(debugin) fprintf(stderr,"free\n");
1002:             freecnt += type_len + 2*sizeof(long);
1003:             if(canjoin)
1004:             {
1005:                 /* join by adjusting size of first vector */
1006:                 ((lispval)(s->next_free))->vl.vectorl[-1]
1007:                   +=  type_len + 2*sizeof(long);
1008:                 if(debugin)
1009:                   fprintf(stderr,"joined size: %d\n",
1010:                       ((lispval)(s->next_free))->vl.vectorl[-1]);
1011:             }
1012:             else {
1013:                 /* vectors are linked at the property word */
1014:                 *(point - 1) = (int)(s->next_free);
1015:                 s->next_free = (char *) (point - 1);
1016:             }
1017:             canjoin = TRUE;
1018:             }
1019:             else {
1020:                 canjoin = FALSE;
1021:             usedcnt += type_len + 2*sizeof(long);
1022:             }
1023: 
1024:             point += VecTotSize(type_len);
1025:             /* we stop sweeping only when we reach a page
1026: 		       boundary since vectors can span pages
1027: 		     */
1028:             if(((int)point & 511) == 0)
1029:             {
1030:             /* reset the counters, we cannot predict how
1031: 			 * many pages we have crossed over
1032: 			 */
1033:             bindex = ATOLX(point);
1034:             /* these will be inced, so we must dec */
1035:             pindex = &purepage[ATOX(point)] - 1;
1036:             start = point - 128;
1037:             if(debugin)
1038:             fprintf(stderr,
1039:                 "out of vector sweep when point = 0x%x\n",
1040:                 point);
1041:             break;
1042:             }
1043:             /* must advance to next point and next value in bitmap.
1044: 		     * we add VecTotSize(type_len) + 2 to get us to the 0th
1045: 		     * entry in the next vector (beyond the size fixnum)
1046: 		     */
1047:             point += 2;     /* point to next 0th entry */
1048:             if ( (bits -= (VecTotSize(type_len) + 2)) > 0)
1049:                 bvalue = bvalue >> (VecTotSize(type_len) + 2);
1050:             else {
1051:             bits = -bits;   /* must advance to next word in map */
1052:             bindex += bits / 32; /* this is tricky stuff... */
1053:             bits = bits % 32;
1054:             bvalue = bitmapi[bindex++] >> bits;
1055:             bits = 32 - bits;
1056:             }
1057:         }
1058:         }
1059:         else {
1060:         /* general sweeper, will work for all types */
1061:         itemstogo = s->space;   /* number of items per page  */
1062:         bits = 32;          /* number of bits per word */
1063:         type_len = s->type_len;
1064: 
1065:         /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
1066:         bvalue = bitmapi[bindex++];
1067: 
1068:         while(TRUE)
1069:         {
1070:             if(!(bvalue & 1))   /* if data element is not marked */
1071:             {
1072:             freecnt++;
1073:             *point = (int) (s->next_free) ;
1074:             s->next_free = (char *) point;
1075:             }
1076:             else usedcnt++;
1077: 
1078:             if( --itemstogo <= 0 )
1079:             {    if(type_len >= 64)
1080:              {
1081:                 bindex++;
1082:                 if(type_len >=128) bindex += 2;
1083:              }
1084:              break;
1085:             }
1086: 
1087:             point += type_len;
1088:             /* shift over mask by number of words in data type */
1089: 
1090:             if( (bits -= type_len) > 0)
1091:             {  bvalue = bvalue >> type_len;
1092:             }
1093:             else if( bits == 0 )
1094:             {  bvalue = bitmapi[bindex++];
1095:                bits = 32;
1096:             }
1097:             else
1098:             {  bits = -bits;
1099:                while( bits >= 32) { bindex++;
1100:                         bits -= 32;
1101:                       }
1102:                bvalue = bitmapi[bindex++];
1103:                bvalue = bvalue >> bits;
1104:                bits = 32 - bits;;
1105:             }
1106:         }
1107:     }
1108: 
1109:      s->space_left += freecnt;
1110:      (*(s->items))->i += usedcnt;
1111:      }
1112: 
1113: #ifdef METER
1114:         vtimes(&alldone,0);
1115:     if(gcstat) gcdump();
1116: #endif
1117:     pagenorm();
1118: }
1119: 
1120: /*
1121:  * alloc
1122:  *
1123:  *  This routine tries to allocate one or more pages of the space named
1124:  *  by the first argument.   Returns the number of pages actually allocated.
1125:  *
1126:  */
1127: 
1128: lispval
1129: alloc(tname,npages)
1130: lispval tname; long npages;
1131: {
1132:     long ii, jj;
1133:     struct types *typeptr;
1134: 
1135:     ii = typenum(tname);
1136:         typeptr = spaces[ii];
1137:     if(npages <= 0) return(inewint(npages));
1138: 
1139:     if((ATOX(datalim)) + npages > TTSIZE)
1140:        error("Space request would exceed maximum memory allocation",FALSE);
1141:     if((ii == VECTOR) || (ii == VECTORI))
1142:     {
1143:         /* allocate in one big chunk */
1144:         tname = csegment((int) ii,(int) npages*128,0);
1145:         tname->vl.vectorl[0] = (npages*512 - 2*sizeof(long));
1146:         tname->v.vector[1] = (lispval) typeptr->next_free;
1147:         typeptr->next_free = (char *) &(tname->v.vector[1]);
1148:         if(debugin) fprintf(stderr,"alloced %d vec pages\n",npages);
1149:         return(inewint(npages));
1150:     }
1151: 
1152:     for( jj=0; jj<npages; ++jj)
1153:         if(get_more_space(spaces[ii],FALSE)) break;
1154:     return(inewint(jj));
1155: }
1156: 
1157: /*
1158:  * csegment(typecode,nitems,useholeflag)
1159:  *  allocate nitems of type typecode.  If useholeflag is true, then
1160:  * allocate in the hole if there is room.  This routine doesn't look
1161:  * in the free lists, it always allocates space.
1162:  */
1163: lispval
1164: csegment(typecode,nitems,useholeflag)
1165: {
1166:     register int ii, jj;
1167:     register char *charadd;
1168: 
1169:     ii = typecode;
1170: 
1171:     if(ii!=OTHER) nitems *= 4*spaces[ii]->type_len;
1172:     nitems = roundup(nitems,512);       /*  round up to right length  */
1173: #ifdef HOLE
1174:     if(useholeflag)
1175:         charadd = gethspace(nitems,ii);
1176:     else
1177: #endif
1178:     {
1179:         charadd = sbrk(nitems);
1180:         datalim = (lispval)(charadd+nitems);
1181:     }
1182:     if( (int) charadd <= 0 )
1183:         error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
1184:     /*if(ii!=OTHER)*/ (*spaces[ii]->pages)->i +=  nitems/512;
1185:     if(ATOX(datalim) > fakettsize) {
1186:         datalim = (lispval) (OFFSET + (fakettsize << 9));
1187:         if(fakettsize >= TTSIZE)
1188:         {
1189:             printf("There isn't room enough to continue, goodbye\n");
1190:             franzexit(1);
1191:         }
1192:         fakettsize++;
1193:         badmem(53);
1194:     }
1195:     for(jj=0; jj<nitems; jj=jj+512) {
1196:         SETTYPE(charadd+jj, ii,30);
1197:     }
1198:     ii = (int) charadd;
1199:     while(nitems > MAXCLEAR)
1200:     {
1201:         blzero(ii,MAXCLEAR);
1202:         nitems -= MAXCLEAR;
1203:         ii += MAXCLEAR;
1204:     }
1205:     blzero(ii,nitems);
1206:     return((lispval)charadd);
1207: }
1208: 
1209: int csizeof(tname) lispval tname;
1210:     {
1211:     return( spaces[typenum(tname)]->type_len * 4 );
1212:     }
1213: 
1214: int typenum(tname) lispval tname;
1215:     {
1216:     int ii;
1217: 
1218: chek:   for(ii=0; ii<NUMSPACES; ++ii)
1219:         if(spaces[ii] && tname == *(spaces[ii]->type_name)) break;
1220:     if(ii == NUMSPACES)
1221:         {
1222:         tname = error("BAD TYPE NAME",TRUE);
1223:         goto chek;
1224:         }
1225: 
1226:     return(ii);
1227: 
1228:     }
1229: char *
1230: gethspace(segsiz,type)
1231: {
1232:     extern usehole; extern char holend[]; extern char *curhbeg;
1233:     register char *value;
1234: 
1235:     if(usehole) {
1236:         curhbeg = (char *) roundup(((int)curhbeg),LBPG);
1237:         if((holend - curhbeg) < segsiz)
1238:         {
1239:             usehole = FALSE;
1240:             curhbeg = holend;
1241:         } else {
1242:             value = curhbeg;
1243:             curhbeg = curhbeg + segsiz;
1244:             /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
1245:             return(value);
1246:         }
1247:     }
1248:     value = (ysbrk(segsiz/LBPG,type));
1249:     datalim = (lispval)(value + segsiz);
1250:     return(value);
1251: }
1252: gcrebear()
1253: {
1254: #ifdef HOLE
1255:         register int i; register struct types *p;
1256: 
1257:     /* this gets done upon rebirth */
1258:     str_current[1].space_left = 0;
1259: #ifndef GCSTRINGS
1260:     str_current[0].space_left = 0;  /* both kinds of strings go in hole*/
1261: #endif
1262:     funct_str.space_left = 0;
1263:     funct_str.next_free = (char *) CNIL;
1264:     /* clear pure space pointers */
1265:     for(i = 0; i < NUMSPACES; i++)
1266:     {
1267:         if(p=spaces[i])
1268:         p->next_pure_free = (char *) CNIL;
1269:     }
1270: #endif
1271: }
1272: 
1273: /** markit(p) ***********************************************************/
1274: /*  just calls markdp							*/
1275: 
1276: markit(p) lispval *p; { markdp(*p); }
1277: 
1278: /*
1279:  * markdp(p)
1280:  *
1281:  *  markdp is the routine which marks each data item.  If it is a
1282:  *  dotted pair, the car and cdr are marked also.
1283:  *  An iterative method is used to mark list structure, to avoid
1284:  *  excessive recursion.
1285:  */
1286: markdp(p) register lispval p;
1287:     {
1288: /*	register int r, s;	(goes with non-asm readbit, oksetbit)	*/
1289: /*	register hsize, hcntr;						*/
1290:     int hsize, hcntr;
1291: 
1292: #ifdef METER
1293:     mrkdpcnt++;
1294: #endif
1295: ptr_loop:
1296:     if(((int)p) <= ((int)nil)) return;  /*  do not mark special data types or nil=0  */
1297: 
1298: 
1299:     switch( TYPE(p) )
1300:         {
1301:         case ATOM:
1302:             ftstbit;
1303:             MARKVAL(p->a.clb);
1304:             MARKVAL(p->a.plist);
1305:             MARKVAL(p->a.fnbnd);
1306: #ifdef GCSTRINGS
1307:             if(gcstrings) MARKVAL(((lispval)p->a.pname));
1308:             return;
1309: 
1310:         case STRNG:
1311:             p = (lispval) (((int) p) & ~ (LBPG-1));
1312:             ftstbit;
1313: #endif
1314:             return;
1315: 
1316:         case INT:
1317:         case DOUB:
1318:             ftstbit;
1319:             return;
1320:         case VALUE:
1321:             ftstbit;
1322:             p = p->l;
1323:             goto ptr_loop;
1324:         case DTPR:
1325:             ftstbit;
1326:             MARKVAL(p->d.car);
1327: #ifdef METER
1328:             /* if we are metering , then check if the cdr is
1329: 			 * nil, or if the cdr is on the same page, and if
1330: 			 * it isn't one of those, then it is on a different
1331: 			 * page
1332: 			 */
1333:              if(gcstat)
1334:              {
1335:                  if(p->d.cdr == nil) consnil++;
1336:                  else if(((int)p & ~511)
1337:                      == (((int)(p->d.cdr)) & ~511))
1338:                 conssame++;
1339:                  else consdiff++;
1340:               }
1341: #endif
1342:             p = p->d.cdr;
1343:             goto ptr_loop;
1344: 
1345:         case ARRAY:
1346:             ftstbit;    /* mark array itself */
1347: 
1348:             MARKVAL(p->ar.accfun);  /* mark access function */
1349:             MARKVAL(p->ar.aux);     /* mark aux data */
1350:             MARKVAL(p->ar.length);  /* mark length */
1351:             MARKVAL(p->ar.delta);   /* mark delta */
1352:             if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
1353:             {
1354:                 /* a non garbage collected array must have its
1355: 			     * array space marked but the value of the array
1356: 			     * space is not marked
1357: 			     */
1358:                  int l;
1359:                  int cnt,d;
1360:                  if(debugin && FALSE) {
1361:                    printf("mark array holders len %d, del %d, start 0x%x\n",
1362:                      p->ar.length->i,p->ar.delta->i,p->ar.data);
1363:                  fflush(stdout);
1364:                 }
1365:                  l = p->ar.length->i; /* number of elements */
1366:                  d = p->ar.delta->i;  /* bytes per element  */
1367:                  p = (lispval) p->ar.data;/* address of first one*/
1368:                  if(purepage[ATOX(p)]) return;
1369: 
1370:                  for((cnt = 0); cnt<l ;
1371:                       p = (lispval)(((char *) p) + d), cnt++)
1372:                  {
1373:                 setbit;
1374:                  }
1375:             } else {
1376: /*			register int i, l; int d;		*/
1377: /*			register char *dataptr = p->ar.data;	*/
1378:             int i,l,d;
1379:             char *dataptr = p->ar.data;
1380: 
1381:             for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
1382:                 {
1383:                 markdp((lispval)dataptr);
1384:                 dataptr += d;
1385:                 }
1386:             }
1387:             return;
1388:         case SDOT:
1389:             do {
1390:                 ftstbit;
1391:                 p = p->s.CDR;
1392:             } while (p!=0);
1393:             return;
1394: 
1395:         case BCD:
1396:             ftstbit;
1397:             markdp(p->bcd.discipline);
1398:             return;
1399: 
1400:         case HUNK2:
1401:         case HUNK4:
1402:         case HUNK8:
1403:         case HUNK16:
1404:         case HUNK32:
1405:         case HUNK64:
1406:         case HUNK128:
1407:             {
1408:                 hsize = 2 << HUNKSIZE(p);
1409:                 ftstbit;
1410:                 for (hcntr = 0; hcntr < hsize; hcntr++)
1411:                     MARKVAL(p->h.hunk[hcntr]);
1412:                 return;
1413:             }
1414: 
1415:         case VECTORI:
1416:             ftstbit;
1417:             MARKVAL(p->v.vector[-1]);   /* mark property */
1418:             return;
1419: 
1420:         case VECTOR:
1421:             {
1422:                 register int vsize;
1423:                 ftstbit;
1424:                 vsize = VecSize(p->vl.vectorl[VSizeOff]);
1425:                 if(debugin)
1426:                    fprintf(stderr,"mark vect at %x  size %d\n",
1427:                         p,vsize);
1428:                 while(--vsize >= -1)
1429:                 {
1430:                 MARKVAL(p->v.vector[vsize]);
1431:                 };
1432:                 return;
1433:             }
1434:         }
1435:     return;
1436:     }
1437: 
1438: 
1439: /* xsbrk allocates space in large chunks (currently 16 pages)
1440:  * xsbrk(1)  returns a pointer to a page
1441:  * xsbrk(0)  returns a pointer to the next page we will allocate (like sbrk(0))
1442:  */
1443: 
1444: char *
1445: xsbrk(n)
1446:     {
1447:     static char *xx;    /*  pointer to next available blank page  */
1448:     extern int xcycle;  /*  number of blank pages available  */
1449:     lispval u;          /*  used to compute limits of bit table  */
1450: 
1451:     if( (xcycle--) <= 0 )
1452:         {
1453:         xcycle = 15;
1454:         xx = sbrk(16*LBPG); /*  get pages 16 at a time  */
1455:         if( (int)xx== -1 )
1456:             lispend("For sbrk from lisp: no space... Goodbye!");
1457:         }
1458:     else xx += LBPG;
1459: 
1460:     if(n == 0)
1461:     {
1462:         xcycle++;   /* don't allocate the page */
1463:         xx -= LBPG;
1464:         return(xx); /* just return its address */
1465:     }
1466: 
1467:     if( (u = (lispval)(xx+LBPG))  > datalim ) datalim = u;
1468:     return(xx);
1469:     }
1470: 
1471: char *ysbrk(pages,type) int pages, type;
1472:     {
1473:     char *xx;   /*  will point to block of storage  */
1474:     int i;
1475: 
1476:     xx = sbrk(pages*LBPG);
1477:     if((int)xx == -1)
1478:         error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
1479: 
1480:     datalim = (lispval)(xx+pages*LBPG); /*  compute bit table limit  */
1481: 
1482:     /*  set type for pages  */
1483: 
1484:     for(i = 0; i < pages; ++i) {
1485:         SETTYPE((xx + i*LBPG),type,10);
1486:     }
1487: 
1488:     return(xx); /*  return pointer to block of storage  */
1489:     }
1490: 
1491: /*
1492:  * getatom
1493:  * returns either an existing atom with the name specified in strbuf, or
1494:  * if the atom does not already exist, regurgitates a new one and
1495:  * returns it.
1496:  */
1497: lispval
1498: getatom(purep)
1499: {   register lispval aptr;
1500:     register char *name, *endname;
1501:     register int hash;
1502:     lispval b;
1503:     char    c;
1504: 
1505:     name = strbuf;
1506:     if (*name == (char)0377) return (eofa);
1507:     hash = hashfcn(name);
1508:     atmlen = strlen(name) + 1;
1509:     aptr = (lispval) hasht[hash];
1510:     while (aptr != CNIL)
1511:         /* if (strcmp(name,aptr->a.pname)==0) */
1512:         if (*name==*aptr->a.pname && strcmp(name,aptr->a.pname)==0)
1513:         return (aptr);
1514:         else
1515:         aptr = (lispval) aptr->a.hshlnk;
1516:     aptr = (lispval) newatom(purep);  /*share pname of atoms on oblist*/
1517:     aptr->a.hshlnk = hasht[hash];
1518:     hasht[hash] = (struct atom *) aptr;
1519:     endname = name + atmlen - 2;
1520:     if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
1521:         {
1522:         b = newdot();
1523:         protect(b);
1524:         b->d.car = lambda;
1525:         b->d.cdr = newdot();
1526:         b = b->d.cdr;
1527:         b->d.car = newdot();
1528:         (b->d.car)->d.car = xatom;
1529:         while(TRUE)
1530:             {
1531:             b->d.cdr = newdot();
1532:             b= b->d.cdr;
1533:             if(++name == endname)
1534:                 {
1535:                 b->d.car= (lispval) xatom;
1536:                 aptr->a.fnbnd = (--np)->val;
1537:                 break;
1538:                 }
1539:             b->d.car= newdot();
1540:             b= b->d.car;
1541:             if((c = *name) == 'a') b->d.car = cara;
1542:             else if (c == 'd') b->d.car = cdra;
1543:             else{ --np;
1544:                break;
1545:              }
1546:             }
1547:         }
1548: 
1549:     return(aptr);
1550:     }
1551: 
1552: /*
1553:  * inewatom is like getatom, except that you provide it a string
1554:  * to be used as the print name.  It doesn't do the automagic
1555:  * creation of things of the form c[ad]*r.
1556:  */
1557: lispval
1558: inewatom(name)
1559: register char *name;
1560: {   register struct atom *aptr;
1561:     register int hash;
1562:     extern struct types atom_str;
1563:     char    c;
1564: 
1565:     if (*name == (char)0377) return (eofa);
1566:     hash = hashfcn(name);
1567:     aptr = hasht[hash];
1568:     while (aptr != (struct atom *)CNIL)
1569:         if (strcmp(name,aptr->pname)==0)
1570:         return ((lispval) aptr);
1571:         else
1572:         aptr = aptr->hshlnk;
1573:     aptr = (struct atom *) next_one(&atom_str) ;
1574:     aptr->plist = aptr->fnbnd = nil;
1575:     aptr->clb = CNIL;
1576:     aptr->pname = name;
1577:     aptr->hshlnk = hasht[hash];
1578:     hasht[hash] = aptr;
1579:     return((lispval)aptr);
1580: }
1581: 
1582: 
1583: /* our hash function */
1584: 
1585: hashfcn(symb)
1586: register char *symb;
1587: {
1588:     register int i;
1589: /*	for (i=0 ; *symb ; i += i + *symb++); return(i & (HASHTOP-1)); */
1590:     for (i=0 ; *symb ; i += i*2 + *symb++);
1591:     return(i&077777 % HASHTOP);
1592: }
1593: 
1594: lispval
1595: LImemory()
1596: {
1597:     int nextadr, pagesinuse;
1598: 
1599:     printf("Memory report. max pages = %d (0x%x) = %d Bytes\n",
1600:             TTSIZE,TTSIZE,TTSIZE*LBPG);
1601: #ifdef HOLE
1602:         printf("This lisp has a hole:\n");
1603:     printf("  current hole start: %d (0x%x), end %d (0x%x)\n",
1604:         curhbeg, curhbeg, holend, holend);
1605:     printf("  hole free: %d bytes = %d pages\n\n",
1606:            holend-curhbeg, (holend-curhbeg)/LBPG);
1607: #endif
1608:     nextadr = (int) xsbrk(0);   /* next space to be allocated */
1609:     pagesinuse = nextadr/LBPG;
1610:     printf("Next allocation at addr %d (0x%x) = page %d\n",
1611:             nextadr, nextadr, pagesinuse);
1612:     printf("Free data pages: %d\n", TTSIZE-pagesinuse);
1613:     return(nil);
1614: }
1615: 
1616: extern struct atom *hasht[HASHTOP];
1617: myhook(){}

Defined functions

Defined variables

Defined macros