![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to Talloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to Talloc.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: ! 2: static char *sccsid = "@(#)Talloc.c 34.11 10/31/80"; ! 3: ! 4: # include "global.h" ! 5: # include "structs.h" ! 6: # ifndef UNIXTS ! 7: # include <vadvise.h> ! 8: # endif ! 9: ! 10: # define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */ ! 11: # define BITQUADS TTSIZE * 2 /* length of bit map in quad words */ ! 12: ! 13: # define ftstbit asm(" ashl $-2,r11,r3");\ ! 14: asm(" bbcs r3,_bitmapq,$1");\ ! 15: asm(" .byte 4"); ! 16: /* define ftstbit if( readbit(p) ) return; oksetbit; */ ! 17: # define readbit(p) ((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7])) ! 18: # define lookbit(p) (bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7]) ! 19: # define setbit(p) {bitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} ! 20: # define oksetbit {bitmap[r] |= s;} ! 21: ! 22: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7]) ! 23: # define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} ! 24: # define roundup(x,l) (((x - 1) | (l - 1)) + 1) ! 25: ! 26: /* METER denotes something added to help meter storage allocation. */ ! 27: ! 28: extern struct heads header[]; ! 29: ! 30: FILE * chkport; /* garbage collection dump file */ ! 31: extern lispval datalim; /* end of data space */ ! 32: double bitmapq[BITQUADS]; /* the bit map--one bit per long */ ! 33: #ifdef METER ! 34: double Mbitmapq[BITQUADS]; ! 35: #endif ! 36: double zeroq; /* a quad word of zeros */ ! 37: char *bitmap = (char *) bitmapq; /* byte version of bit map array */ ! 38: int *bitmapi = (int *) bitmapq; /* integer version of bit map array */ ! 39: #ifdef METER ! 40: int *Mbitmapi = (int *) Mbitmapq; /* integer version of bit map array */ ! 41: int freefree,usedfree,freeused,usedused; ! 42: #endif ! 43: #ifndef METER ! 44: int freefree,usedfree,freeused,usedused; /* need so external refs will be ! 45: satisfied, remove when get rid ! 46: of meter stuff ! 47: */ ! 48: #endif ! 49: char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */ ! 50: extern int *bind_lists ; /* lisp data for compiled code */ ! 51: ! 52: char *xsbrk(); ! 53: char *gethspace(); ! 54: ! 55: ! 56: int atmlen; ! 57: ! 58: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str, ! 59: array_str, sdot_str, val_str, funct_str, hunk_str[]; ! 60: ! 61: lispval hunk_items[7], hunk_pages[7], hunk_name[7]; ! 62: ! 63: extern int initflag; /* starts off TRUE: initially gc not allowed */ ! 64: ! 65: int gcflag = FALSE; /* TRUE during garbage collection */ ! 66: ! 67: int current = 0; /* number of pages currently allocated */ ! 68: ! 69: static struct types *(spaces[NUMSPACES]) = ! 70: {&atom_str, &strng_str, &int_str, ! 71: &dtpr_str, &doub_str, &array_str, ! 72: &sdot_str, &val_str, &funct_str, ! 73: &hunk_str[0], &hunk_str[1], &hunk_str[2], ! 74: &hunk_str[3], &hunk_str[4], &hunk_str[5], ! 75: &hunk_str[6]}; ! 76: ! 77: /* this is a table of pointers to collectable struct types objects ! 78: * the index is the type number. ! 79: */ ! 80: struct types *gcableptr[] = ! 81: { (struct types *) 0, /* strings not collectable */ ! 82: (struct types *) 0, /* atoms not collectable */ ! 83: &int_str, &dtpr_str, &doub_str, ! 84: (struct types *) 0, /* binary objects not collectable */ ! 85: (struct types *) 0, /* port objects not collectable */ ! 86: &array_str, ! 87: (struct types *) 0, /* gap in the type number sequence */ ! 88: &sdot_str,&val_str, ! 89: &hunk_str[0], &hunk_str[1], &hunk_str[2], ! 90: &hunk_str[3], &hunk_str[4], &hunk_str[5], ! 91: &hunk_str[6]}; ! 92: ! 93: ! 94: /** get_more_space(type_struct) *****************************************/ ! 95: /* */ ! 96: /* Allocates and structures a new page, returning 0. */ ! 97: /* If no space is available, returns 1. */ ! 98: ! 99: get_more_space(type_struct) ! 100: struct types *type_struct; ! 101: { ! 102: int cntr; ! 103: char *start; ! 104: int *loop, *temp; ! 105: lispval p, plim; ! 106: struct heads *next; extern char holend[]; ! 107: ! 108: if(initflag == FALSE) ! 109: /* mustn't look at plist of plima too soon */ ! 110: { ! 111: while( plim=copval(plima,(lispval)CNIL), TYPE(plim)!=INT ) ! 112: copval(plima,error("BAD PAGE LIMIT",TRUE)); ! 113: if( plim->i <= current ) return(1); /* Can't allocate */ ! 114: } ! 115: ! 116: if( current >= TTSIZE ) return(2); ! 117: ! 118: #ifdef HOLE ! 119: if(type_struct==&strng_str || (type_struct==&funct_str)) ! 120: start = gethspace(NBPG,type_struct->type); ! 121: else ! 122: #endif ! 123: start = xsbrk(); ! 124: ! 125: ! 126: SETTYPE(start, type_struct->type); /* set type of page */ ! 127: ! 128: /* bump the page counter for this space */ ! 129: ! 130: ++((*(type_struct->pages))->i); ! 131: ! 132: type_struct->space_left = type_struct->space; ! 133: if(start >= holend) { ! 134: next = &header[ current++ ]; ! 135: next->pntr = start; ! 136: next->link = type_struct->first; ! 137: type_struct->first = next; ! 138: } ! 139: if(type_struct==&strng_str) { ! 140: type_struct->next_free = start; ! 141: return(0); /* space was available */ ! 142: } ! 143: type_struct->first = next; ! 144: temp = loop = (int *) start; ! 145: for(cntr=1; cntr < type_struct->space; cntr++) ! 146: loop = (int *) (*loop = (int) (loop + type_struct->type_len)); ! 147: *loop = (int) (type_struct->next_free); ! 148: type_struct->next_free = (char *) temp; ! 149: ! 150: /* if type atom, set pnames to CNIL */ ! 151: ! 152: if( type_struct == &atom_str ) ! 153: for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr) ! 154: { ! 155: p->a.pname = (char *) CNIL; ! 156: p = (lispval) ((int *)p + atom_str.type_len); ! 157: } ! 158: return(0); /* space was available */ ! 159: } ! 160: ! 161: ! 162: /** next_one(type_struct) ************************************************/ ! 163: /* */ ! 164: /* Allocates one new item of each kind of space, except STRNG. */ ! 165: /* If there is no space, calls gc, the garbage collector. */ ! 166: /* If there is still no space, allocates a new page using */ ! 167: /* get_more_space(type_struct) */ ! 168: ! 169: lispval ! 170: next_one(type_struct) ! 171: struct types *type_struct; ! 172: { ! 173: ! 174: register char *temp; ! 175: snpand(1); ! 176: ! 177: while(type_struct->next_free == (char *) CNIL) ! 178: { ! 179: int g; ! 180: ! 181: if((type_struct->type != ATOM) && /* can't collect atoms */ ! 182: (type_struct->type != STRNG) && /* can't collect strings */ ! 183: (type_struct->type != BCD) && /* nor function headers */ ! 184: (gcthresh->i <= current) && /* threshhold for gc */ ! 185: gcdis->a.clb == nil && /* gc not disabled */ ! 186: (NOTNIL(copval(gcload,CNIL)) || (loading->a.clb != tatom)) && ! 187: /* not to collect during load */ ! 188: (initflag == FALSE) && /* dont gc during init */ ! 189: (gcflag == FALSE)) /* don't recurse gc */ ! 190: ! 191: { ! 192: /* fputs("Collecting",poport); ! 193: dmpport(poport);*/ ! 194: gc(type_struct); /* collect */ ! 195: } ! 196: ! 197: if( type_struct->next_free != (char *) CNIL ) break; ! 198: ! 199: if(! (g=get_more_space(type_struct))) break; ! 200: ! 201: if( g==1 ) ! 202: { ! 203: plimit->i = current+NUMSPACES; ! 204: /* allow a few more pages */ ! 205: copval(plima,plimit); /* restore to reserved reg */ ! 206: ! 207: error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", ! 208: TRUE); ! 209: } ! 210: else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", ! 211: TRUE); ! 212: } ! 213: ! 214: temp = type_struct->next_free; ! 215: type_struct->next_free = * (char **)(type_struct->next_free); ! 216: return((lispval) temp); ! 217: } ! 218: ! 219: lispval ! 220: newint() ! 221: { ! 222: ++(int_items->i); ! 223: return(next_one(&int_str)); ! 224: } ! 225: ! 226: lispval ! 227: newdot() ! 228: { ! 229: lispval temp; ! 230: ! 231: ++(dtpr_items->i); ! 232: temp = next_one(&dtpr_str); ! 233: temp->d.car = temp->d.cdr = nil; ! 234: return(temp); ! 235: } ! 236: ! 237: lispval ! 238: newdoub() ! 239: { ! 240: ++(doub_items->i); ! 241: return(next_one(&doub_str)); ! 242: } ! 243: ! 244: lispval ! 245: newsdot() ! 246: { ! 247: register lispval temp; ! 248: ++(dtpr_items->i); ! 249: temp = next_one(&sdot_str); ! 250: temp->d.car = temp->d.cdr = 0; ! 251: return(temp); ! 252: } ! 253: ! 254: struct atom * ! 255: newatom() { ! 256: struct atom *save; ! 257: ! 258: ++(atom_items->i); ! 259: save = (struct atom *) next_one(&atom_str) ; ! 260: save->plist = save->fnbnd = nil; ! 261: save->hshlnk = (struct atom *)CNIL; ! 262: save->clb = CNIL; ! 263: save->pname = newstr(); ! 264: return (save); ! 265: } ! 266: ! 267: char *newstr() { ! 268: char *save; ! 269: int atmlen2,atmlen; ! 270: ! 271: ++(str_items->i); ! 272: atmlen = strlen(strbuf)+1; ! 273: if(atmlen > strng_str.space_left) ! 274: while(get_more_space(&strng_str)) ! 275: error("YOU HAVE RUN OUT OF SPACE",TRUE); ! 276: strcpy((save = strng_str.next_free), strbuf); ! 277: atmlen2 = atmlen; ! 278: while(atmlen2 & 3) ++atmlen2; /* even up length of string */ ! 279: strng_str.next_free += atmlen2; ! 280: strng_str.space_left -= atmlen2; ! 281: return(save); ! 282: } ! 283: ! 284: char *inewstr(s) char *s; ! 285: { ! 286: strbuf[STRBLEN-1] = '\0'; ! 287: strcpyn(strbuf,s,STRBLEN-1); ! 288: return(newstr()); ! 289: } ! 290: ! 291: lispval ! 292: newarray() ! 293: { ! 294: register lispval temp; ! 295: ! 296: ++(array_items->i); ! 297: temp = next_one(&array_str); ! 298: temp->ar.data = (char *)nil; ! 299: temp->ar.accfun = nil; ! 300: temp->ar.aux = nil; ! 301: temp->ar.length = SMALL(0); ! 302: temp->ar.delta = SMALL(0); ! 303: return(temp); ! 304: } ! 305: ! 306: lispval ! 307: badcall() ! 308: { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); } ! 309: ! 310: lispval ! 311: newfunct() ! 312: { ! 313: register lispval temp; ! 314: ++(funct_items->i); ! 315: temp = next_one(&funct_str); ! 316: temp->bcd.entry = badcall; ! 317: temp->bcd.discipline = nil; ! 318: return(temp); ! 319: } ! 320: ! 321: lispval ! 322: newval() ! 323: { ! 324: register lispval temp; ! 325: ++(val_items->i); ! 326: temp = next_one(&val_str); ! 327: temp->l = nil; ! 328: return(temp); ! 329: } ! 330: ! 331: lispval ! 332: newhunk(hunknum) ! 333: int hunknum; ! 334: { ! 335: register lispval temp; ! 336: ! 337: ++(hunk_items[hunknum]->i); /* Update used hunks count */ ! 338: temp = next_one(&hunk_str[hunknum]); /* Get a hunk */ ! 339: return(temp); ! 340: } ! 341: ! 342: lispval ! 343: inewval(arg) lispval arg; ! 344: { ! 345: lispval temp; ! 346: ++(val_items->i); ! 347: temp = next_one(&val_str); ! 348: temp->l = arg; ! 349: return(temp); ! 350: } ! 351: ! 352: ! 353: /** Ngc *****************************************************************/ ! 354: /* */ ! 355: /* LISP interface to gc. */ ! 356: ! 357: lispval Ngc() ! 358: { ! 359: lispval temp; ! 360: ! 361: if( ISNIL(lbot->val) ) return(gc(CNIL)); ! 362: ! 363: if( TYPE(lbot->val) != DTPR ) error("BAD CALL TO GC",FALSE); ! 364: ! 365: chkport = poport; ! 366: ! 367: if( NOTNIL(lbot->val->d.car) ) ! 368: { ! 369: temp = eval(lbot->val->d.car); ! 370: if( TYPE(temp) == PORT ) chkport = temp->p; ! 371: } ! 372: ! 373: gc1(TRUE); ! 374: ! 375: return(nil); ! 376: } ! 377: ! 378: /** gc(type_struct) *****************************************************/ ! 379: /* */ ! 380: /* garbage collector: Collects garbage by mark and sweep algorithm. */ ! 381: /* After this is done, calls the Nlambda, gcafter. */ ! 382: /* gc may also be called from LISP, as a lambda of no arguments. */ ! 383: ! 384: lispval ! 385: gc(type_struct) ! 386: struct types *type_struct; ! 387: { ! 388: lispval save; ! 389: struct { ! 390: long mytime; ! 391: long allelse[3]; ! 392: } begin, finish; ! 393: extern int GCtime; ! 394: ! 395: save = copval(gcport,CNIL); ! 396: if(GCtime) ! 397: times(&begin); ! 398: ! 399: while( (TYPE(save) != PORT) && NOTNIL(save)) ! 400: save = error("NEED PORT FOR GC",TRUE); ! 401: ! 402: chkport = (ISNIL(save) ? poport : save->p); ! 403: ! 404: gc1(NOTNIL(copval(gccheck,CNIL)) || (chkport!=poport)); /* mark&sweep */ ! 405: ! 406: /* Now we call gcafter--special case if gc called from LISP */ ! 407: ! 408: if( type_struct == (struct types *) CNIL ) ! 409: gccall1->d.cdr = nil; /* make the call "(gcafter)" */ ! 410: else ! 411: { ! 412: gccall1->d.cdr = gccall2; ! 413: gccall2->d.car = *(type_struct->type_name); ! 414: } ! 415: {lispval temp;temp = rdrsdot, rdrsdot = rdrsdot2, rdrsdot2 = temp; /*KLUDGE*/} ! 416: gcflag = TRUE; /* flag to indicate in garbage collector */ ! 417: save = eval(gccall1); /* call gcafter */ ! 418: gcflag = FALSE; /* turn off flag */ ! 419: {lispval temp;temp = rdrsdot, rdrsdot = rdrsdot2, rdrsdot2 = temp; /*KLUDGE*/} ! 420: ! 421: if(GCtime) { ! 422: times(&finish); ! 423: GCtime += (finish.mytime - begin.mytime); ! 424: } ! 425: return(save); /* return result of gcafter */ ! 426: } ! 427: ! 428: ! 429: ! 430: /* gc1() **************************************************************/ ! 431: /* */ ! 432: /* Mark-and-sweep phase */ ! 433: ! 434: gc1(chkflag) int chkflag; ! 435: { ! 436: int j, typep,k; ! 437: register int *start,bvalue,type_len; ! 438: register struct types *s; ! 439: int *point,i,freecnt,itemstogo,bits,bindex,type,enddat; ! 440: struct heads *loop; ! 441: struct argent *loop2; ! 442: struct nament *loop3; ! 443: #ifdef METER ! 444: int Mbvalue; ! 445: #endif ! 446: int markdp(); ! 447: int debugin = FALSE; /* temp debug flag */ ! 448: extern int *beginsweep; ! 449: #define ERDB(s) { printf(s); fflush(stdout); } ! 450: ! 451: #ifndef UNIXTS ! 452: vadvise(VA_ANOM); ! 453: /* decide whether to check LISP structure or not */ ! 454: #endif ! 455: ! 456: ! 457: ! 458: /* first set all bit maps to zero */ ! 459: ! 460: ! 461: if(debugin) ERDB("Begin gc\n"); ! 462: enddat = (int)datalim >> 8; ! 463: for(bvalue=0; bvalue < (int)enddat ; ++bvalue) ! 464: { ! 465: #ifdef METER ! 466: /* Mbitmapq[bvalue] = bitmapq[bvalue]; /* remember old vals */ ! 467: /* the C compiler will use a movd if we let it,and this ! 468: will not work since the bit maps may be illegal ! 469: floating point values ! 470: */ ! 471: asm(" movq _bitmapq[r10],_Mbitmapq[r10] "); ! 472: #endif ! 473: bitmapq[bvalue] = zeroq; ! 474: } ! 475: ! 476: /* try the movc5 to clear the bit maps */ ! 477: /* blzero(bitmap,TTSIZE * 16); */ ! 478: ! 479: ! 480: /* then mark all atoms' plists, clbs, and function bindings */ ! 481: ! 482: for(loop=atom_str.first; loop!=(struct heads *)CNIL; loop=loop->link) ! 483: for(start=(int *)(loop->pntr), i=1; ! 484: i <= atom_str.space; ! 485: start = start + atom_str.type_len, ++i) ! 486: { ! 487: ! 488: /* unused atoms are marked with pname == CNIL */ ! 489: /* this is done by get_more_space, as well as */ ! 490: /* by gc (in the future) */ ! 491: ! 492: if(((lispval)start)->a.pname == (char *)CNIL) continue; ! 493: #define MARKSUB(p) if(nil!=((lispval)start)->p)markdp(((lispval)start)->p); ! 494: MARKSUB(a.clb); ! 495: MARKSUB(a.fnbnd); ! 496: MARKSUB(a.plist); ! 497: } ! 498: ! 499: /* Mark all the atoms and ints associated with the hunk ! 500: data types */ ! 501: ! 502: for(i=0; i<8; i++) { ! 503: markdp(hunk_items[i]); ! 504: markdp(hunk_name[i]); ! 505: markdp(hunk_pages[i]); ! 506: } ! 507: /* next run up the name stack */ ! 508: if(debugin) ERDB("name stack\n"); ! 509: for(loop2 = np - 1; loop2 >= orgnp; --loop2) markdp((loop2->val)); ! 510: ! 511: /* now the bindstack (vals only, atoms are marked elsewhere ) */ ! 512: for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)markdp(loop3->val); ! 513: ! 514: if(debugin) ERDB("compiler stuff\n"); ! 515: /* from TBL 29july79 */ ! 516: /* next mark all compiler linked data */ ! 517: point = bind_lists; ! 518: while((start = point) != (int *)CNIL) { ! 519: if(debugin) ERDB("once "); ! 520: while( *start != -1 ) ! 521: markdp(*start++); ! 522: point = (int *)*(point-1); ! 523: } ! 524: /* end from TBL */ ! 525: ! 526: if(debugin) ERDB("signif stuff\n"); ! 527: /* next mark all system-significant lisp data */ ! 528: ! 529: for(i=0; i<SIGNIF; ++i) markdp((lispsys[i])); ! 530: ! 531: if(debugin) printf("time to sweep up\n"); ! 532: /* all accessible data has now been marked. */ ! 533: /* all collectable spaces must be swept, */ ! 534: /* and freelists constructed. */ ! 535: ! 536: /* first clear the structure elements for types ! 537: * we will sweep ! 538: */ ! 539: ! 540: for(k=0 ; k <= HUNK128 ; k++) ! 541: { ! 542: if( s=gcableptr[k] ) ! 543: { ! 544: (*(s->items))->i = 0; ! 545: s->space_left = 0; ! 546: s->next_free = (char *) CNIL; ! 547: } ! 548: } ! 549: ! 550: ! 551: /* sweep up in memory looking at gcable pages */ ! 552: ! 553: for(start = beginsweep, bindex = (int)start >> 7; ! 554: start < (int *)datalim; ! 555: start += 128) ! 556: { ! 557: /* printf(" start %x, bindex %x\n",start,bindex); */ ! 558: if(!(s=gcableptr[type = TYPE(start)])) ! 559: { ! 560: bindex += 4; /* and 4 words of 32 bit bitmap words */ ! 561: continue; ! 562: } ! 563: ! 564: freecnt = 0; /* number of free items found */ ! 565: itemstogo = s->space; /* number of items per page */ ! 566: bits = 32; /* number of bits per word */ ! 567: type_len = s->type_len; ! 568: ! 569: /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/ ! 570: bvalue = bitmapi[bindex++]; ! 571: #ifdef METER ! 572: Mbvalue = Mbitmapi[bindex-1]; ! 573: #endif ! 574: ! 575: point = start; ! 576: while(TRUE) ! 577: { ! 578: /*printf(" bv: %08x, ",bvalue);*/ ! 579: if(!(bvalue & 1)) /* if data element is not marked */ ! 580: { ! 581: freecnt++; ! 582: *point = (int) (s->next_free) ; ! 583: s->next_free = (char *) point; ! 584: #ifdef METER ! 585: if(type == DTPR) ! 586: { ! 587: if(Mbvalue & 1) usedfree++; ! 588: else freefree++; ! 589: } ! 590: #endif ! 591: } ! 592: #ifdef METER ! 593: else if(type == DTPR) ! 594: { ! 595: if (Mbvalue & 1) usedused++; ! 596: else freeused++; ! 597: } ! 598: #endif ! 599: ! 600: if( --itemstogo <= 0 ) ! 601: { if(type_len >= 64) ! 602: { ! 603: bindex++; ! 604: if(type_len >=128) bindex += 2; ! 605: } ! 606: break; ! 607: } ! 608: ! 609: point += type_len; ! 610: /* shift over mask by number of words in data type */ ! 611: ! 612: if( (bits -= type_len) > 0) ! 613: { bvalue = bvalue >> type_len; ! 614: #ifdef METER ! 615: Mbvalue = Mbvalue >> type_len; ! 616: #endif ! 617: } ! 618: else if( bits == 0 ) ! 619: { bvalue = bitmapi[bindex++]; ! 620: #ifdef METER ! 621: Mbvalue = Mbitmapi[bindex-1]; ! 622: #endif ! 623: bits = 32; ! 624: } ! 625: else ! 626: { bits = -bits; ! 627: while( bits >= 32) { bindex++; ! 628: bits -= 32; ! 629: } ! 630: bvalue = bitmapi[bindex++]; ! 631: bvalue = bvalue >> bits; ! 632: #ifdef METER ! 633: Mbvalue = Mbitmapi[bindex-1]; ! 634: Mbvalue = Mbvalue >> bits; ! 635: #endif ! 636: bits = 32 - bits;; ! 637: } ! 638: } ! 639: ! 640: /* printf(" t %d,fr %d ",type,freecnt); */ ! 641: s->space_left += freecnt; ! 642: (*(s->items))->i += s->space - freecnt; ! 643: } ! 644: ! 645: #ifndef UNIXTS ! 646: vadvise(VA_NORM); ! 647: #endif ! 648: } ! 649: ! 650: /** alloc() *************************************************************/ ! 651: /* */ ! 652: /* This routine tries to allocate one more page of the space named */ ! 653: /* by the argument. If no more space is available returns 1, else 0. */ ! 654: ! 655: lispval ! 656: alloc(tname,npages) ! 657: lispval tname; int npages; ! 658: { ! 659: int ii, jj; ! 660: ! 661: ii = typenum(tname); ! 662: ! 663: if(((int)datalim >> 9) + npages > TTSIZE) ! 664: error("Space request would exceed maximum memory allocation",FALSE); ! 665: ! 666: for( jj=0; jj<npages; ++jj) ! 667: if(get_more_space(spaces[ii])) break; ! 668: return(inewint(jj)); ! 669: } ! 670: ! 671: lispval ! 672: csegment(tname,nitems,useholeflag) ! 673: lispval tname; int nitems; ! 674: { ! 675: int ii, jj; ! 676: char *charadd; ! 677: ! 678: ii = typenum(tname); ! 679: ! 680: nitems = nitems*4*spaces[ii]->type_len; /* find c-length of space */ ! 681: nitems = roundup(nitems,512); /* round up to right length */ ! 682: #ifdef HOLE ! 683: if((tname==str_name) && useholeflag) ! 684: charadd = gethspace(nitems,ii); ! 685: else ! 686: #endif ! 687: { ! 688: current += nitems/512; ! 689: charadd = sbrk(nitems); ! 690: datalim = (lispval)(charadd+nitems); ! 691: } ! 692: if( (int) charadd == 0 ) ! 693: error("NOT ENOUGH SPACE FOR ARRAY",FALSE); ! 694: if((((int)datalim) >> 9) > TTSIZE) { ! 695: datalim = (lispval) (TTSIZE << 9); ! 696: badmem(53); ! 697: } ! 698: for(jj=0; jj<nitems; jj=jj+512) { ! 699: SETTYPE(charadd+jj, spaces[ii]->type); ! 700: } ! 701: blzero(charadd,nitems); ! 702: return((lispval)charadd); ! 703: } ! 704: ! 705: int csizeof(tname) lispval tname; ! 706: { ! 707: return( spaces[typenum(tname)]->type_len * 4 ); ! 708: } ! 709: ! 710: int typenum(tname) lispval tname; ! 711: { ! 712: int ii; ! 713: ! 714: chek: for(ii=0; ii<NUMSPACES; ++ii) ! 715: if(tname == *(spaces[ii]->type_name)) break; ! 716: if(ii == NUMSPACES) ! 717: { ! 718: tname = error("BAD TYPE NAME",TRUE); ! 719: goto chek; ! 720: } ! 721: ! 722: return(ii); ! 723: ! 724: } ! 725: char * ! 726: gethspace(segsiz,type) ! 727: { ! 728: extern usehole; extern char holend[]; extern char *curhbeg; ! 729: register char *value; ! 730: ! 731: if(usehole) { ! 732: curhbeg = (char *) roundup(((int)curhbeg),NBPG); ! 733: if((holend - curhbeg) < segsiz) ! 734: { printf("[fasl hole filled up]\n"); ! 735: usehole = FALSE; ! 736: } else { ! 737: value = curhbeg; ! 738: curhbeg = curhbeg + segsiz; ! 739: /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/ ! 740: return(value); ! 741: } ! 742: } ! 743: value = (ysbrk(segsiz/NBPG,type)); ! 744: datalim = (lispval)(value + segsiz); ! 745: return(value); ! 746: } ! 747: gcrebear() ! 748: { ! 749: #ifdef HOLE ! 750: /* this gets done upon rebirth */ ! 751: strng_str.space_left = 0; ! 752: funct_str.space_left = 0; ! 753: funct_str.next_free = (char *) CNIL; ! 754: #endif ! 755: } ! 756: ! 757: /** markit(p) ***********************************************************/ ! 758: /* just calls markdp */ ! 759: ! 760: markit(p) lispval *p; { markdp(*p); } ! 761: ! 762: /** markdp(p) ***********************************************************/ ! 763: /* */ ! 764: /* markdp is the routine which marks each data item. If it is a */ ! 765: /* dotted pair, the car and cdr are marked also. */ ! 766: /* An iterative method is used to mark list structure, to avoid */ ! 767: /* excessive recursion. */ ! 768: ! 769: ! 770: markdp(p) register lispval p; ! 771: { ! 772: /* register int r, s; (goes with non-asm readbit, oksetbit) */ ! 773: /* register hsize, hcntr; */ ! 774: int hsize, hcntr; ! 775: ! 776: ptr_loop: ! 777: if((int)p <= 0) return; /* do not mark special data types or nil=0 */ ! 778: ! 779: switch( TYPE(p) ) ! 780: { ! 781: case INT: ! 782: case DOUB: ! 783: /* setbit(p);*/ ! 784: ftstbit; ! 785: return; ! 786: case VALUE: ! 787: ftstbit; ! 788: p = p->l; ! 789: goto ptr_loop; ! 790: case DTPR: ! 791: ftstbit; ! 792: markdp(p->d.car); ! 793: p = p->d.cdr; ! 794: goto ptr_loop; ! 795: ! 796: case ARRAY: ! 797: ftstbit; /* mark array itself */ ! 798: ! 799: markdp(p->ar.accfun); /* mark access function */ ! 800: markdp(p->ar.aux); /* mark aux data */ ! 801: markdp(p->ar.length); /* mark length */ ! 802: markdp(p->ar.delta); /* mark delta */ ! 803: if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar) ! 804: return; ! 805: { ! 806: /* register int i, l; int d; */ ! 807: /* register char *dataptr = p->ar.data; */ ! 808: int i,l,d; ! 809: char *dataptr = p->ar.data; ! 810: ! 811: for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i) ! 812: { ! 813: markdp(dataptr); ! 814: dataptr += d; ! 815: } ! 816: return; ! 817: } ! 818: case SDOT: ! 819: do { ! 820: ftstbit; ! 821: p = p->s.CDR; ! 822: } while (p!=0); ! 823: return; ! 824: ! 825: case BCD: ! 826: ftstbit; ! 827: markdp(p->bcd.discipline); ! 828: return; ! 829: ! 830: case HUNK2: ! 831: case HUNK4: ! 832: case HUNK8: ! 833: case HUNK16: ! 834: case HUNK32: ! 835: case HUNK64: ! 836: case HUNK128: ! 837: { ! 838: hsize = 2 << HUNKSIZE(p); ! 839: ftstbit; ! 840: for (hcntr = 0; hcntr < hsize; hcntr++) ! 841: markdp(p->h.hunk[hcntr]); ! 842: return; ! 843: } ! 844: } ! 845: return; ! 846: } ! 847: ! 848: ! 849: ! 850: char * ! 851: xsbrk() ! 852: { ! 853: static char *xx; /* pointer to next available blank page */ ! 854: extern int xcycle; /* number of blank pages available */ ! 855: lispval u; /* used to compute limits of bit table */ ! 856: ! 857: if( (xcycle--) <= 0 ) ! 858: { ! 859: xcycle = 15; ! 860: xx = sbrk(16*NBPG); /* get pages 16 at a time */ ! 861: if( (int)xx== -1 ) ! 862: lispend("For sbrk from lisp: no space... Goodbye!"); ! 863: goto done; ! 864: } ! 865: xx += NBPG; ! 866: done: if( (u = (lispval)(xx+NBPG)) > datalim ) datalim = u; ! 867: return(xx); ! 868: } ! 869: ! 870: char *ysbrk(pages,type) int pages, type; ! 871: { ! 872: char *xx; /* will point to block of storage */ ! 873: int i; ! 874: ! 875: xx = sbrk(pages*NBPG); ! 876: if((int)xx == -1) ! 877: error("OUT OF SPACE FOR ARRAY REQUEST",FALSE); ! 878: ! 879: datalim = (lispval)(xx+pages*NBPG); /* compute bit table limit */ ! 880: ! 881: /* set type for pages */ ! 882: ! 883: for(i = 0; i < pages; ++i) { ! 884: SETTYPE((xx + i*NBPG),type); ! 885: } ! 886: ! 887: return(xx); /* return pointer to block of storage */ ! 888: } ! 889: ! 890: #ifdef VMS ! 891: /* sbrk - ! 892: * this function is used by the VMS franz to allocate space. ! 893: * It allocates space in the zfreespace array. ! 894: * The single argument passed to sbrk is the number of bytes to allocate ! 895: * ! 896: */ ! 897: ! 898: extern char zfreespace[]; ! 899: extern char *lsbrkpnt; ! 900: ! 901: char * ! 902: sbrk(n) ! 903: { ! 904: char *result; ! 905: if(lsbrkpnt == (char *)0) ! 906: { ! 907: lsbrkpnt = (char *) roundup((int)zfreespace,NBPG); ! 908: } ! 909: result = lsbrkpnt; ! 910: /* printf("lispbrk: %x \n",lsbrkpnt); ! 911: fflush(stdout); */ ! 912: lsbrkpnt += n; ! 913: if(lsbrkpnt > &zfreespace[FREESIZE]) ! 914: error("sbrk: out of space ",FALSE); ! 915: return(result); ! 916: } ! 917: #endif ! 918: /* getatom **************************************************************/ ! 919: /* returns either an existing atom with the name specified in strbuf, or*/ ! 920: /* if the atom does not already exist, regurgitates a new one and */ ! 921: /* returns it. */ ! 922: lispval ! 923: getatom() ! 924: { register lispval aptr; ! 925: register char *name, *endname; ! 926: register int hash; ! 927: register struct argent *lbot, *np; ! 928: lispval b; ! 929: char c; ! 930: ! 931: name = strbuf; ! 932: if (*name == (char)0377) return (eofa); ! 933: hash = hashfcn(name); ! 934: atmlen = strlen(name) + 1; ! 935: aptr = (lispval) hasht[hash]; ! 936: while (aptr != CNIL) ! 937: if (strcmp(name,aptr->a.pname)==0) ! 938: return (aptr); ! 939: else ! 940: aptr = (lispval) aptr->a.hshlnk; ! 941: aptr = (lispval) newatom(); ! 942: aptr->a.hshlnk = hasht[hash]; ! 943: hasht[hash] = (struct atom *) aptr; ! 944: endname = name + atmlen - 2; ! 945: if ((atmlen != 4) && (*name == 'c') && (*endname == 'r')) ! 946: { ! 947: b = newdot(); ! 948: protect(b); ! 949: b->d.car = lambda; ! 950: b->d.cdr = newdot(); ! 951: b = b->d.cdr; ! 952: b->d.car = newdot(); ! 953: (b->d.car)->d.car = xatom; ! 954: while(TRUE) ! 955: { ! 956: b->d.cdr = newdot(); ! 957: b= b->d.cdr; ! 958: if(++name == endname) ! 959: { ! 960: b->d.car= (lispval) xatom; ! 961: aptr->a.fnbnd = unprot(); ! 962: break; ! 963: } ! 964: b->d.car= newdot(); ! 965: b= b->d.car; ! 966: if((c = *name) == 'a') b->d.car = cara; ! 967: else if (c == 'd') b->d.car = cdra; ! 968: else{ unprot(); ! 969: break; ! 970: } ! 971: } ! 972: } ! 973: ! 974: return(aptr); ! 975: } ! 976: ! 977: /* our hash function */ ! 978: ! 979: hashfcn(symb) ! 980: char *symb; ! 981: { ! 982: register int i; ! 983: for (i=0 ; *symb ; i += i + *symb++); ! 984: return(i & (HASHTOP-1)); ! 985: } ! 986: ! 987: extern struct atom *hasht[HASHTOP];
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.