![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to alloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / gcc|
Return to alloc.c CVS log | Up to [Research Unix] / researchv10dc / cmd / gcc |
1.1 ! root 1: /* Storage allocation and gc for GNU Emacs Lisp interpreter. ! 2: Copyright (C) 1985 Richard M. Stallman. ! 3: ! 4: This file is part of GNU Emacs. ! 5: ! 6: GNU Emacs is distributed in the hope that it will be useful, ! 7: but WITHOUT ANY WARRANTY. No author or distributor ! 8: accepts responsibility to anyone for the consequences of using it ! 9: or for whether it serves any particular purpose or works at all, ! 10: unless he says so in writing. Refer to the GNU Emacs General Public ! 11: License for full details. ! 12: ! 13: Everyone is granted permission to copy, modify and redistribute ! 14: GNU Emacs, but only under the conditions described in the ! 15: GNU Emacs General Public License. A copy of this license is ! 16: supposed to have been given to you along with GNU Emacs so you ! 17: can know your rights and responsibilities. It should be in a ! 18: file named COPYING. Among other things, the copyright notice ! 19: and this notice must be preserved on all copies. */ ! 20: ! 21: ! 22: #include "config.h" ! 23: ! 24: /* Number of bytes of consing done since the last gc */ ! 25: int consing_since_gc; ! 26: ! 27: /* Number of bytes of consing since gc before another gc should be done. */ ! 28: int gc_cons_threshold; ! 29: ! 30: /* Nonzero during gc */ ! 31: int gc_in_progress; ! 32: ! 33: #ifndef VIRT_ADDR_VARIES ! 34: /* Address below which pointers should not be traced */ ! 35: extern char edata[]; ! 36: #endif /* VIRT_ADDR_VARIES */ ! 37: ! 38: #ifndef VIRT_ADDR_VARIES ! 39: extern ! 40: #endif /* VIRT_ADDR_VARIES */ ! 41: int malloc_sbrk_used; ! 42: ! 43: #ifndef VIRT_ADDR_VARIES ! 44: extern ! 45: #endif /* VIRT_ADDR_VARIES */ ! 46: int malloc_sbrk_unused; ! 47: ! 48: /* Non-nil means defun should do purecopy on the function definition */ ! 49: Lisp_Object Vpurify_flag; ! 50: ! 51: int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ ! 52: ! 53: #define PUREBEG (char *) pure ! 54: ! 55: /* Index in pure at which next pure object will be allocated. */ ! 56: int pureptr; ! 57: ! 58: Lisp_Object ! 59: malloc_warning_1 (str) ! 60: Lisp_Object str; ! 61: { ! 62: return Fprinc (str, Vstandard_output); ! 63: } ! 64: ! 65: /* malloc calls this if it finds we are near exhausting storage */ ! 66: malloc_warning (str) ! 67: char *str; ! 68: { ! 69: Lisp_Object val; ! 70: val = build_string (str); ! 71: internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val); ! 72: } ! 73: ! 74: /* Called if malloc returns zero */ ! 75: memory_full () ! 76: { ! 77: error ("Memory exhausted"); ! 78: } ! 79: ! 80: /* like malloc and realloc but check for no memory left */ ! 81: ! 82: long * ! 83: xmalloc (size) ! 84: int size; ! 85: { ! 86: long *val = (long *) malloc (size); ! 87: if (!val) memory_full (); ! 88: return val; ! 89: } ! 90: ! 91: long * ! 92: xrealloc (block, size) ! 93: long *block; ! 94: int size; ! 95: { ! 96: long *val = (long *) realloc (block, size); ! 97: if (!val) memory_full (); ! 98: return val; ! 99: } ! 100: ! 101: /* Allocation of cons cells */ ! 102: /* We store cons cells inside of cons_blocks, allocating a new ! 103: cons_block with malloc whenever necessary. Cons cells reclaimed by ! 104: GC are put on a free list to be reallocated before allocating ! 105: any new cons cells from the latest cons_block. ! 106: ! 107: Each cons_block is just under 1020 bytes long, ! 108: since malloc really allocates in units of powers of two ! 109: and uses 4 bytes for its own overhead. */ ! 110: ! 111: #define CONS_BLOCK_SIZE \ ! 112: ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons)) ! 113: ! 114: struct cons_block ! 115: { ! 116: struct cons_block *next; ! 117: struct Lisp_Cons conses[CONS_BLOCK_SIZE]; ! 118: }; ! 119: ! 120: struct cons_block *cons_block; ! 121: int cons_block_index; ! 122: ! 123: struct Lisp_Cons *cons_free_list; ! 124: ! 125: void ! 126: init_cons () ! 127: { ! 128: cons_block = (struct cons_block *) malloc (sizeof (struct cons_block)); ! 129: cons_block->next = 0; ! 130: bzero (cons_block->conses, sizeof cons_block->conses); ! 131: cons_block_index = 0; ! 132: cons_free_list = 0; ! 133: } ! 134: ! 135: /* Explicitly free a cons cell. */ ! 136: free_cons (ptr) ! 137: struct Lisp_Cons *ptr; ! 138: { ! 139: XSETCONS (ptr->car, cons_free_list); ! 140: cons_free_list = ptr; ! 141: } ! 142: ! 143: DEFUN ("cons", Fcons, Scons, 2, 2, 0, ! 144: "Create a new cons, give it CAR and CDR as components, and return it.") ! 145: (car, cdr) ! 146: Lisp_Object car, cdr; ! 147: { ! 148: register Lisp_Object val; ! 149: ! 150: if (cons_free_list) ! 151: { ! 152: XSET (val, Lisp_Cons, cons_free_list); ! 153: cons_free_list = XCONS (cons_free_list->car); ! 154: } ! 155: else ! 156: { ! 157: if (cons_block_index == CONS_BLOCK_SIZE) ! 158: { ! 159: register struct cons_block *new = (struct cons_block *) malloc (sizeof (struct cons_block)); ! 160: if (!new) memory_full (); ! 161: new->next = cons_block; ! 162: cons_block = new; ! 163: cons_block_index = 0; ! 164: } ! 165: XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]); ! 166: } ! 167: XCONS (val)->car = car; ! 168: XCONS (val)->cdr = cdr; ! 169: consing_since_gc += sizeof (struct Lisp_Cons); ! 170: return val; ! 171: } ! 172: ! 173: DEFUN ("list", Flist, Slist, 0, MANY, 0, ! 174: "Return a newly created list whose elements are the arguments (any number).") ! 175: (nargs, args) ! 176: int nargs; ! 177: Lisp_Object *args; ! 178: { ! 179: Lisp_Object len, val, val_tail; ! 180: ! 181: XFASTINT (len) = nargs; ! 182: val = Fmake_list (len, Qnil); ! 183: val_tail = val; ! 184: while (!NULL (val_tail)) ! 185: { ! 186: XCONS (val_tail)->car = *args++; ! 187: val_tail = XCONS (val_tail)->cdr; ! 188: } ! 189: return val; ! 190: } ! 191: ! 192: DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, ! 193: "Return a newly created list of length LENGTH, with each element being INIT.") ! 194: (length, init) ! 195: Lisp_Object length, init; ! 196: { ! 197: register Lisp_Object val; ! 198: register int size; ! 199: ! 200: if (XTYPE (length) != Lisp_Int || XINT (length) < 0) ! 201: length = wrong_type_argument (Qnatnump, length); ! 202: size = XINT (length); ! 203: ! 204: val = Qnil; ! 205: while (size-- > 0) ! 206: val = Fcons (init, val); ! 207: return val; ! 208: } ! 209: ! 210: /* Allocation of vectors */ ! 211: ! 212: struct Lisp_Vector *all_vectors; ! 213: ! 214: DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, ! 215: "Return a newly created vector of length LENGTH, with each element being INIT.") ! 216: (length, init) ! 217: Lisp_Object length, init; ! 218: { ! 219: register int sizei, index; ! 220: register Lisp_Object vector; ! 221: ! 222: if (XTYPE (length) != Lisp_Int || XINT (length) < 0) ! 223: length = wrong_type_argument (Qnatnump, length); ! 224: sizei = XINT (length); ! 225: ! 226: XSET (vector, Lisp_Vector, ! 227: (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object))); ! 228: consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object); ! 229: if (!XVECTOR (vector)) ! 230: memory_full (); ! 231: ! 232: XVECTOR (vector)->size = sizei; ! 233: XVECTOR (vector)->next = all_vectors; ! 234: all_vectors = XVECTOR (vector); ! 235: ! 236: for (index = 0; index < sizei; index++) ! 237: XVECTOR (vector)->contents[index] = init; ! 238: ! 239: return vector; ! 240: } ! 241: ! 242: DEFUN ("vector", Fvector, Svector, 0, MANY, 0, ! 243: "Return a newly created vector with our arguments (any number) as its elements.") ! 244: (nargs, args) ! 245: int nargs; ! 246: Lisp_Object *args; ! 247: { ! 248: register Lisp_Object len, val; ! 249: register int index; ! 250: register struct Lisp_Vector *p; ! 251: ! 252: XFASTINT (len) = nargs; ! 253: val = Fmake_vector (len, Qnil); ! 254: p = XVECTOR (val); ! 255: for (index = 0; index < nargs; index++) ! 256: p->contents[index] = args[index]; ! 257: return val; ! 258: } ! 259: ! 260: /* Allocation of symbols. ! 261: Just like allocation of conses! ! 262: ! 263: Each symbol_block is just under 1020 bytes long, ! 264: since malloc really allocates in units of powers of two ! 265: and uses 4 bytes for its own overhead. */ ! 266: ! 267: #define SYMBOL_BLOCK_SIZE \ ! 268: ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol)) ! 269: ! 270: struct symbol_block ! 271: { ! 272: struct symbol_block *next; ! 273: struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE]; ! 274: }; ! 275: ! 276: struct symbol_block *symbol_block; ! 277: int symbol_block_index; ! 278: ! 279: struct Lisp_Symbol *symbol_free_list; ! 280: ! 281: void ! 282: init_symbol () ! 283: { ! 284: symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block)); ! 285: symbol_block->next = 0; ! 286: bzero (symbol_block->symbols, sizeof symbol_block->symbols); ! 287: symbol_block_index = 0; ! 288: symbol_free_list = 0; ! 289: } ! 290: ! 291: DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, ! 292: "Return a newly allocated uninterned symbol whose name is NAME.\n\ ! 293: Its value and function definition are void, and its property list is NIL.") ! 294: (str) ! 295: Lisp_Object str; ! 296: { ! 297: register Lisp_Object val; ! 298: ! 299: CHECK_STRING (str, 0); ! 300: ! 301: if (symbol_free_list) ! 302: { ! 303: XSET (val, Lisp_Symbol, symbol_free_list); ! 304: symbol_free_list = XSYMBOL (symbol_free_list->value); ! 305: } ! 306: else ! 307: { ! 308: if (symbol_block_index == SYMBOL_BLOCK_SIZE) ! 309: { ! 310: struct symbol_block *new = (struct symbol_block *) malloc (sizeof (struct symbol_block)); ! 311: if (!new) memory_full (); ! 312: new->next = symbol_block; ! 313: symbol_block = new; ! 314: symbol_block_index = 0; ! 315: } ! 316: XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]); ! 317: } ! 318: XSYMBOL (val)->name = XSTRING (str); ! 319: XSYMBOL (val)->plist = Qnil; ! 320: XSYMBOL (val)->value = Qunbound; ! 321: XSYMBOL (val)->function = Qunbound; ! 322: XSYMBOL (val)->next = 0; ! 323: consing_since_gc += sizeof (struct Lisp_Symbol); ! 324: return val; ! 325: } ! 326: ! 327: /* Allocation of markers. ! 328: Works like allocation of conses. */ ! 329: ! 330: #define MARKER_BLOCK_SIZE \ ! 331: ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker)) ! 332: ! 333: struct marker_block ! 334: { ! 335: struct marker_block *next; ! 336: struct Lisp_Marker markers[MARKER_BLOCK_SIZE]; ! 337: }; ! 338: ! 339: struct marker_block *marker_block; ! 340: int marker_block_index; ! 341: ! 342: struct Lisp_Marker *marker_free_list; ! 343: ! 344: void ! 345: init_marker () ! 346: { ! 347: marker_block = (struct marker_block *) malloc (sizeof (struct marker_block)); ! 348: marker_block->next = 0; ! 349: bzero (marker_block->markers, sizeof marker_block->markers); ! 350: marker_block_index = 0; ! 351: marker_free_list = 0; ! 352: } ! 353: ! 354: DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, ! 355: "Return a newly allocated marker which does not point at any place.") ! 356: () ! 357: { ! 358: register Lisp_Object val; ! 359: ! 360: if (marker_free_list) ! 361: { ! 362: XSET (val, Lisp_Marker, marker_free_list); ! 363: marker_free_list = XMARKER (marker_free_list->chain); ! 364: } ! 365: else ! 366: { ! 367: if (marker_block_index == MARKER_BLOCK_SIZE) ! 368: { ! 369: struct marker_block *new = (struct marker_block *) malloc (sizeof (struct marker_block)); ! 370: if (!new) memory_full (); ! 371: new->next = marker_block; ! 372: marker_block = new; ! 373: marker_block_index = 0; ! 374: } ! 375: XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]); ! 376: } ! 377: XMARKER (val)->buffer = 0; ! 378: XMARKER (val)->bufpos = 0; ! 379: XMARKER (val)->modified = 0; ! 380: XMARKER (val)->chain = Qnil; ! 381: consing_since_gc += sizeof (struct Lisp_Marker); ! 382: return val; ! 383: } ! 384: ! 385: /* Allocation of strings */ ! 386: ! 387: /* Strings reside inside of string_blocks. The entire data of the string, ! 388: both the size and the contents, live in part of the `chars' component of a string_block. ! 389: The `pos' component is the index within `chars' of the first free byte */ ! 390: ! 391: /* String blocks contain this many bytes. ! 392: Power of 2, minus 4 for malloc overhead. */ ! 393: #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head)) ! 394: ! 395: /* A string bigger than this gets its own specially-made string block ! 396: if it doesn't fit in the current one. */ ! 397: #define STRING_BLOCK_OUTSIZE 1024 ! 398: ! 399: struct string_block_head ! 400: { ! 401: struct string_block *next; ! 402: int pos; ! 403: }; ! 404: ! 405: struct string_block ! 406: { ! 407: struct string_block *next; ! 408: int pos; ! 409: char chars[STRING_BLOCK_SIZE]; ! 410: }; ! 411: ! 412: /* This points to the string block we are now allocating strings in ! 413: which is also the beginning of the chain of all string blocks ever made */ ! 414: ! 415: struct string_block *current_string_block; ! 416: ! 417: void ! 418: init_strings () ! 419: { ! 420: current_string_block = (struct string_block *) malloc (sizeof (struct string_block)); ! 421: consing_since_gc += sizeof (struct string_block); ! 422: current_string_block->next = 0; ! 423: current_string_block->pos = 0; ! 424: } ! 425: ! 426: static Lisp_Object make_zero_string (); ! 427: ! 428: DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, ! 429: "Return a newly created string of length LENGTH, with each element being INIT.\n\ ! 430: Both LENGTH and INIT must be numbers.") ! 431: (length, init) ! 432: Lisp_Object length, init; ! 433: { ! 434: if (XTYPE (length) != Lisp_Int || XINT (length) < 0) ! 435: length = wrong_type_argument (Qnatnump, length); ! 436: CHECK_NUMBER (init, 1); ! 437: return make_zero_string (XINT (length), XINT (init)); ! 438: } ! 439: ! 440: Lisp_Object ! 441: make_string (contents, length) ! 442: char *contents; ! 443: int length; ! 444: { ! 445: Lisp_Object val; ! 446: val = make_zero_string (length, 0); ! 447: bcopy (contents, XSTRING (val)->data, length); ! 448: return val; ! 449: } ! 450: ! 451: Lisp_Object ! 452: build_string (str) ! 453: char *str; ! 454: { ! 455: return make_string (str, strlen (str)); ! 456: } ! 457: ! 458: static Lisp_Object ! 459: make_zero_string (length, init) ! 460: int length; ! 461: register int init; ! 462: { ! 463: register Lisp_Object val; ! 464: register int fullsize = length + sizeof (int); ! 465: register unsigned char *p, *end; ! 466: ! 467: if (length < 0) abort (); ! 468: ! 469: /* Round `fullsize' up to multiple of size of int; also add one for terminating zero */ ! 470: fullsize += sizeof (int); ! 471: fullsize &= ~(sizeof (int) - 1); ! 472: ! 473: if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos) ! 474: /* This string can fit in the current string block */ ! 475: { ! 476: XSET (val, Lisp_String, ! 477: (struct Lisp_String *) (current_string_block->chars + current_string_block->pos)); ! 478: current_string_block->pos += fullsize; ! 479: } ! 480: else if (fullsize > STRING_BLOCK_OUTSIZE) ! 481: /* This string gets its own string block */ ! 482: { ! 483: struct string_block *new = (struct string_block *) malloc (sizeof (struct string_block_head) + fullsize); ! 484: if (!new) memory_full (); ! 485: consing_since_gc += sizeof (struct string_block_head) + fullsize; ! 486: new->pos = fullsize; ! 487: new->next = current_string_block->next; ! 488: current_string_block->next = new; ! 489: XSET (val, Lisp_String, ! 490: (struct Lisp_String *) ((struct string_block_head *)new + 1)); ! 491: } ! 492: else ! 493: /* Make a new current string block and start it off with this string */ ! 494: { ! 495: struct string_block *new = (struct string_block *) malloc (sizeof (struct string_block)); ! 496: if (!new) memory_full (); ! 497: consing_since_gc += sizeof (struct string_block); ! 498: new->next = current_string_block; ! 499: current_string_block = new; ! 500: new->pos = fullsize; ! 501: XSET (val, Lisp_String, ! 502: (struct Lisp_String *) current_string_block->chars); ! 503: } ! 504: ! 505: XSTRING (val)->size = length; ! 506: p = XSTRING (val)->data; ! 507: end = p + XSTRING (val)->size; ! 508: while (p != end) ! 509: *p++ = init; ! 510: *p = 0; ! 511: ! 512: return val; ! 513: } ! 514: ! 515: /* Must get an error if pure storage is full, ! 516: since if it cannot hold a large string ! 517: it may be able to hold conses that point to that string; ! 518: then the string is not protected from gc. */ ! 519: ! 520: Lisp_Object ! 521: make_pure_string (data, length) ! 522: char *data; ! 523: int length; ! 524: { ! 525: Lisp_Object new; ! 526: int size = sizeof (int) + length + 1; ! 527: ! 528: if (pureptr + size > PURESIZE) ! 529: error ("Pure Lisp storage exhausted"); ! 530: XSET (new, Lisp_String, PUREBEG + pureptr); ! 531: XSTRING (new)->size = length; ! 532: bcopy (data, XSTRING (new)->data, length); ! 533: XSTRING (new)->data[length] = 0; ! 534: pureptr += (size + sizeof (int) - 1) ! 535: / sizeof (int) * sizeof (int); ! 536: return new; ! 537: } ! 538: ! 539: Lisp_Object ! 540: pure_cons (car, cdr) ! 541: Lisp_Object car, cdr; ! 542: { ! 543: Lisp_Object new; ! 544: ! 545: if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE) ! 546: error ("Pure Lisp storage exhausted"); ! 547: XSET (new, Lisp_Cons, PUREBEG + pureptr); ! 548: pureptr += sizeof (struct Lisp_Cons); ! 549: XCONS (new)->car = Fpurecopy (car); ! 550: XCONS (new)->cdr = Fpurecopy (cdr); ! 551: return new; ! 552: } ! 553: ! 554: Lisp_Object ! 555: make_pure_vector (len) ! 556: int len; ! 557: { ! 558: Lisp_Object new; ! 559: int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); ! 560: ! 561: if (pureptr + size > PURESIZE) ! 562: error ("Pure Lisp storage exhausted"); ! 563: ! 564: XSET (new, Lisp_Vector, PUREBEG + pureptr); ! 565: pureptr += size; ! 566: XVECTOR (new)->size = len; ! 567: return new; ! 568: } ! 569: ! 570: DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, ! 571: "Make a copy of OBJECT in pure storage.\n\ ! 572: Recursively copies contents of vectors and cons cells.\n\ ! 573: Does not copy symbols.") ! 574: (obj) ! 575: Lisp_Object obj; ! 576: { ! 577: Lisp_Object new, tem; ! 578: int i; ! 579: ! 580: #ifndef VIRT_ADDR_VARIES ! 581: /* Need not trace pointers to pure storage */ ! 582: if (XUINT (obj) < (unsigned int) edata && XUINT (obj) >= 0) ! 583: return obj; ! 584: #else /* VIRT_ADDR_VARIES */ ! 585: if (XUINT (obj) < (unsigned int) ((char *) pure + PURESIZE) ! 586: && XUINT (obj) >= (unsigned int) pure) ! 587: return obj; ! 588: #endif /* VIRT_ADDR_VARIES */ ! 589: ! 590: #ifdef SWITCH_ENUM_BUG ! 591: switch ((int) XTYPE (obj)) ! 592: #else ! 593: switch (XTYPE (obj)) ! 594: #endif ! 595: { ! 596: case Lisp_Marker: ! 597: error ("Attempt to copy a marker to pure storage"); ! 598: ! 599: case Lisp_Cons: ! 600: return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr); ! 601: ! 602: case Lisp_String: ! 603: return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size); ! 604: ! 605: case Lisp_Vector: ! 606: new = make_pure_vector (XVECTOR (obj)->size); ! 607: for (i = 0; i < XVECTOR (obj)->size; i++) ! 608: { ! 609: tem = XVECTOR (obj)->contents[i]; ! 610: XVECTOR (new)->contents[i] = Fpurecopy (tem); ! 611: } ! 612: return new; ! 613: ! 614: default: ! 615: return obj; ! 616: } ! 617: } ! 618: ! 619: /* Recording what needs to be marked for gc. */ ! 620: ! 621: struct gcpro *gcprolist; ! 622: ! 623: #define NSTATICS 100 ! 624: ! 625: char staticvec1[NSTATICS * sizeof (Lisp_Object *)] = {0}; ! 626: ! 627: int staticidx = 0; ! 628: ! 629: #define staticvec ((Lisp_Object **) staticvec1) ! 630: ! 631: /* Put an entry in staticvec, pointing at the variable whose address is given */ ! 632: ! 633: void ! 634: staticpro (varaddress) ! 635: Lisp_Object *varaddress; ! 636: { ! 637: staticvec[staticidx++] = varaddress; ! 638: if (staticidx >= NSTATICS) ! 639: abort (); ! 640: } ! 641: ! 642: struct catchtag ! 643: { ! 644: Lisp_Object tag; ! 645: Lisp_Object val; ! 646: struct catchtag *next; ! 647: /* jmp_buf jmp; /* We don't need this for GC purposes */ ! 648: }; ! 649: ! 650: extern struct catchtag *catchlist; ! 651: ! 652: struct backtrace ! 653: { ! 654: struct backtrace *next; ! 655: Lisp_Object *function; ! 656: Lisp_Object *args; /* Points to vector of args. */ ! 657: int nargs; /* length of vector */ ! 658: /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */ ! 659: char evalargs; ! 660: }; ! 661: ! 662: extern struct backtrace *backtrace_list; ! 663: ! 664: /* On vector, means it has been marked. ! 665: On string, means it has been copied. */ ! 666: static int most_negative_fixnum; ! 667: ! 668: /* On string, means do not copy it. ! 669: This is set in all copies, and perhaps will be used ! 670: to indicate strings that there is no need to copy. */ ! 671: static int dont_copy_flag; ! 672: ! 673: int total_conses, total_markers, total_symbols, total_string_size, total_vector_size; ! 674: int total_free_conses, total_free_markers, total_free_symbols; ! 675: ! 676: /* Garbage collection: mark and sweep, except copy strings. */ ! 677: static Lisp_Object mark_object (); ! 678: static void clear_marks (), gc_sweep (); ! 679: ! 680: DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", ! 681: "Reclaim storage for Lisp objects no longer needed.\n\ ! 682: Returns info on amount of space in use:\n\ ! 683: ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\ ! 684: (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS)\n\ ! 685: Garbage collection happens automatically if you cons more than\n\ ! 686: gc-cons-threshold bytes of Lisp data since previous garbage collection.") ! 687: () ! 688: { ! 689: struct string_block *old_string_block; ! 690: ! 691: register struct gcpro *tail; ! 692: register struct specbinding *bind; ! 693: struct catchtag *catch; ! 694: struct handler *handler; ! 695: register struct backtrace *backlist; ! 696: register Lisp_Object tem; ! 697: char *omessage = minibuf_message; ! 698: ! 699: register int i; ! 700: ! 701: if (!noninteractive) ! 702: message1 ("Garbage collecting..."); ! 703: ! 704: /* Don't keep command history around forever */ ! 705: tem = Fnthcdr (make_number (30), Vcommand_history); ! 706: if (LISTP (tem)) ! 707: XCONS (tem)->cdr = Qnil; ! 708: ! 709: gc_in_progress = 1; ! 710: ! 711: clear_marks (); ! 712: old_string_block = current_string_block; ! 713: current_string_block = 0; ! 714: total_string_size = 0; ! 715: init_strings (); ! 716: ! 717: for (tail = gcprolist; tail; tail = tail->next) ! 718: { ! 719: for (i = 0; i < tail->nvars; i++) ! 720: { ! 721: tem = tail->var[i]; ! 722: tail->var[i] = mark_object (tem); ! 723: } ! 724: } ! 725: for (i = 0; i < staticidx; i++) ! 726: { ! 727: tem = *staticvec[i]; ! 728: *staticvec[i] = mark_object (tem); ! 729: } ! 730: for (bind = specpdl; bind != specpdl_ptr; bind++) ! 731: { ! 732: bind->symbol = mark_object (bind->symbol); ! 733: bind->old_value = mark_object (bind->old_value); ! 734: } ! 735: for (catch = catchlist; catch; catch = catch->next) ! 736: { ! 737: catch->tag = mark_object (catch->tag); ! 738: catch->val = mark_object (catch->val); ! 739: } ! 740: for (handler = handlerlist; handler; handler = handler->next) ! 741: { ! 742: handler->handler = mark_object (handler->handler); ! 743: handler->var = mark_object (handler->var); ! 744: } ! 745: for (backlist = backtrace_list; backlist; backlist = backlist->next) ! 746: { ! 747: tem = *backlist->function; ! 748: *backlist->function = mark_object (tem); ! 749: if (backlist->nargs == UNEVALLED || backlist->nargs == MANY) ! 750: { ! 751: tem = *backlist->args; ! 752: *backlist->args = mark_object (tem); ! 753: } ! 754: else ! 755: for (i = 0; i < backlist->nargs; i++) ! 756: { ! 757: tem = backlist->args[i]; ! 758: backlist->args[i] = mark_object (tem); ! 759: } ! 760: } ! 761: ! 762: gc_sweep (old_string_block); ! 763: ! 764: clear_marks (); ! 765: gc_in_progress = 0; ! 766: ! 767: consing_since_gc = 0; ! 768: if (gc_cons_threshold < 10000) ! 769: gc_cons_threshold = 10000; ! 770: ! 771: if (omessage) ! 772: message1 (omessage); ! 773: else if (!noninteractive) ! 774: message1 ("Garbage collecting...done"); ! 775: ! 776: return Fcons (Fcons (make_number (total_conses), ! 777: make_number (total_free_conses)), ! 778: Fcons (Fcons (make_number (total_symbols), ! 779: make_number (total_free_symbols)), ! 780: Fcons (Fcons (make_number (total_markers), ! 781: make_number (total_free_markers)), ! 782: Fcons (make_number (total_string_size), ! 783: Fcons (make_number (total_vector_size), ! 784: Qnil))))); ! 785: } ! 786: ! 787: static void ! 788: clear_marks () ! 789: { ! 790: /* Clear marks on all strings */ ! 791: { ! 792: register struct string_block *csb; ! 793: register int pos; ! 794: ! 795: for (csb = current_string_block; csb; csb = csb->next) ! 796: { ! 797: pos = 0; ! 798: while (pos < csb->pos) ! 799: { ! 800: register struct Lisp_String *nextstr ! 801: = (struct Lisp_String *) &csb->chars[pos]; ! 802: register int fullsize; ! 803: ! 804: nextstr->size &= ~dont_copy_flag; ! 805: fullsize = nextstr->size + sizeof (int); ! 806: ! 807: fullsize += sizeof (int); ! 808: fullsize &= ~(sizeof (int) - 1); ! 809: pos += fullsize; ! 810: } ! 811: } ! 812: } ! 813: /* Clear marks on all conses */ ! 814: { ! 815: register struct cons_block *cblk; ! 816: register int lim = cons_block_index; ! 817: ! 818: for (cblk = cons_block; cblk; cblk = cblk->next) ! 819: { ! 820: register int i; ! 821: for (i = 0; i < lim; i++) ! 822: XUNMARK (cblk->conses[i].car); ! 823: lim = CONS_BLOCK_SIZE; ! 824: } ! 825: } ! 826: /* Clear marks on all symbols */ ! 827: { ! 828: register struct symbol_block *sblk; ! 829: register int lim = symbol_block_index; ! 830: ! 831: for (sblk = symbol_block; sblk; sblk = sblk->next) ! 832: { ! 833: register int i; ! 834: for (i = 0; i < lim; i++) ! 835: XUNMARK (sblk->symbols[i].plist); ! 836: lim = SYMBOL_BLOCK_SIZE; ! 837: } ! 838: } ! 839: /* Clear marks on all markers */ ! 840: { ! 841: register struct marker_block *sblk; ! 842: register int lim = marker_block_index; ! 843: ! 844: for (sblk = marker_block; sblk; sblk = sblk->next) ! 845: { ! 846: register int i; ! 847: for (i = 0; i < lim; i++) ! 848: XUNMARK (sblk->markers[i].chain); ! 849: lim = MARKER_BLOCK_SIZE; ! 850: } ! 851: } ! 852: /* Clear mark bits on all buffers */ ! 853: { ! 854: register struct buffer *nextb = all_buffers; ! 855: ! 856: while (nextb) ! 857: { ! 858: XUNMARK (nextb->name); ! 859: nextb = nextb->next; ! 860: } ! 861: } ! 862: } ! 863: ! 864: /* Mark one Lisp object, and recursively mark all the objects it points to ! 865: if this is the first time it is being marked. ! 866: If the object is a string, it is copied (once, only) and the copy is returned. ! 867: The original string's `size' is set to a value in which 1<<31 is set ! 868: and the rest of which is the string address shifted right by one. ! 869: If the object is not a string, it is returned unchanged. */ ! 870: ! 871: static Lisp_Object ! 872: mark_object (obj) ! 873: Lisp_Object obj; ! 874: { ! 875: Lisp_Object original; ! 876: ! 877: original = obj; ! 878: ! 879: loop: ! 880: #ifndef VIRT_ADDR_VARIES ! 881: /* Need not trace pointers to pure storage */ ! 882: if (XUINT (obj) < (unsigned int) edata && XUINT (obj) >= 0) ! 883: return original; ! 884: #else /* VIRT_ADDR_VARIES */ ! 885: if (XUINT (obj) < (unsigned int) ((char *) pure + PURESIZE) ! 886: && XUINT (obj) >= (unsigned int) pure) ! 887: return original; ! 888: #endif /* VIRT_ADDR_VARIES */ ! 889: ! 890: #ifdef SWITCH_ENUM_BUG ! 891: switch ((int) XGCTYPE (obj)) ! 892: #else ! 893: switch (XGCTYPE (obj)) ! 894: #endif ! 895: { ! 896: case Lisp_String: ! 897: { ! 898: register struct Lisp_String *ptr = XSTRING (obj); ! 899: Lisp_Object tem; ! 900: ! 901: if (ptr->size & most_negative_fixnum) ! 902: { ! 903: XSETSTRING (obj, (struct Lisp_String *) (ptr->size & ~most_negative_fixnum)); ! 904: return obj; ! 905: } ! 906: if (ptr->size & dont_copy_flag) ! 907: return obj; ! 908: total_string_size += ptr->size; ! 909: tem = make_string (ptr->data, ptr->size); ! 910: ptr->size = most_negative_fixnum | XINT (tem); ! 911: XSTRING (tem)->size |= dont_copy_flag; ! 912: return tem; ! 913: } ! 914: ! 915: case Lisp_Vector: ! 916: case Lisp_Window: ! 917: case Lisp_Process: ! 918: { ! 919: register struct Lisp_Vector *ptr = XVECTOR (obj); ! 920: register int size = ptr->size; ! 921: register int i; ! 922: Lisp_Object tem; ! 923: ! 924: if (size & most_negative_fixnum) break; /* Already marked */ ! 925: ptr->size |= most_negative_fixnum; /* Else mark it */ ! 926: for (i = 0; i < size; i++) /* and then mark its elements */ ! 927: { ! 928: tem = ptr->contents[i]; ! 929: ptr->contents[i] = mark_object (tem); ! 930: } ! 931: } ! 932: break; ! 933: ! 934: case Lisp_Temp_Vector: ! 935: { ! 936: register struct Lisp_Vector *ptr = XVECTOR (obj); ! 937: register int size = ptr->size; ! 938: register int i; ! 939: Lisp_Object tem; ! 940: ! 941: for (i = 0; i < size; i++) /* and then mark its elements */ ! 942: { ! 943: tem = ptr->contents[i]; ! 944: ptr->contents[i] = mark_object (tem); ! 945: } ! 946: } ! 947: break; ! 948: ! 949: case Lisp_Symbol: ! 950: { ! 951: register struct Lisp_Symbol *ptr = XSYMBOL (obj); ! 952: struct Lisp_Symbol *ptrx; ! 953: Lisp_Object tem; ! 954: ! 955: if (XMARKBIT (ptr->plist)) break; ! 956: XMARK (ptr->plist); ! 957: XSET (tem, Lisp_String, ptr->name); ! 958: tem = mark_object (tem); ! 959: ptr->name = XSTRING (tem); ! 960: ptr->value = mark_object (ptr->value); ! 961: ptr->function = mark_object (ptr->function); ! 962: tem = ptr->plist; ! 963: XUNMARK (tem); ! 964: ptr->plist = mark_object (tem); ! 965: XMARK (ptr->plist); ! 966: ptr = ptr->next; ! 967: if (ptr) ! 968: { ! 969: ptrx = ptr; /* Use pf ptrx avoids compiled bug on Sun */ ! 970: XSETSYMBOL (obj, ptrx); ! 971: goto loop; ! 972: } ! 973: } ! 974: break; ! 975: ! 976: case Lisp_Marker: ! 977: XMARK (XMARKER (obj)->chain); ! 978: /* DO NOT mark thru the marker's chain. ! 979: The buffer's markers chain does not preserve markers from gc; ! 980: instead, markers are removed from the chain when they are freed by gc. */ ! 981: break; ! 982: ! 983: case Lisp_Cons: ! 984: case Lisp_Buffer_Local_Value: ! 985: case Lisp_Some_Buffer_Local_Value: ! 986: { ! 987: Lisp_Object tem; ! 988: register struct Lisp_Cons *ptr = XCONS (obj); ! 989: if (XMARKBIT (ptr->car)) break; ! 990: tem = ptr->car; ! 991: XMARK (ptr->car); ! 992: ptr->car = mark_object (tem); ! 993: XMARK (ptr->car); ! 994: if (XGCTYPE (ptr->cdr) != Lisp_String) ! 995: { ! 996: obj = ptr->cdr; ! 997: goto loop; ! 998: } ! 999: ptr->cdr = mark_object (ptr->cdr); ! 1000: } ! 1001: break; ! 1002: ! 1003: case Lisp_Objfwd: ! 1004: *XOBJFWD (obj) = mark_object (*XOBJFWD (obj)); ! 1005: break; ! 1006: ! 1007: case Lisp_Buffer: ! 1008: if (!XMARKBIT (XBUFFER (obj)->name)) ! 1009: mark_buffer (obj); ! 1010: break; ! 1011: ! 1012: /* Don't bother with Lisp_Buffer_Objfwd, ! 1013: since all markable slots in current buffer marked anyway. */ ! 1014: } ! 1015: return original; ! 1016: } ! 1017: ! 1018: /* Mark the pointers in a buffer structure. */ ! 1019: ! 1020: mark_buffer (buf) ! 1021: Lisp_Object buf; ! 1022: { ! 1023: Lisp_Object tem; ! 1024: register struct buffer *buffer = XBUFFER (buf); ! 1025: ! 1026: buffer->number = mark_object (buffer->number); ! 1027: buffer->name = mark_object (buffer->name); ! 1028: XMARK (buffer->name); ! 1029: buffer->filename = mark_object (buffer->filename); ! 1030: buffer->directory = mark_object (buffer->directory); ! 1031: buffer->save_length = mark_object (buffer->save_length); ! 1032: buffer->auto_save_file_name = mark_object (buffer->auto_save_file_name); ! 1033: buffer->read_only = mark_object (buffer->read_only); ! 1034: /* buffer->markers does not preserve from gc: scavenger removes marker from ! 1035: the markers chain if it is freed. See gc_sweep */ ! 1036: buffer->mark = mark_object (buffer->mark); ! 1037: buffer->major_mode = mark_object (buffer->major_mode); ! 1038: buffer->mode_name = mark_object (buffer->mode_name); ! 1039: buffer->mode_line_format = mark_object (buffer->mode_line_format); ! 1040: buffer->keymap = mark_object (buffer->keymap); ! 1041: XSET (tem, Lisp_Vector, buffer->syntax_table_v); ! 1042: if (buffer->syntax_table_v) ! 1043: mark_object (tem); ! 1044: buffer->abbrev_table = mark_object (buffer->abbrev_table); ! 1045: buffer->case_fold_search = mark_object (buffer->case_fold_search); ! 1046: buffer->tab_width = mark_object (buffer->tab_width); ! 1047: buffer->fill_column = mark_object (buffer->fill_column); ! 1048: buffer->left_margin = mark_object (buffer->left_margin); ! 1049: buffer->auto_fill_hook = mark_object (buffer->auto_fill_hook); ! 1050: buffer->local_var_alist = mark_object (buffer->local_var_alist); ! 1051: buffer->truncate_lines = mark_object (buffer->truncate_lines); ! 1052: buffer->ctl_arrow = mark_object (buffer->ctl_arrow); ! 1053: buffer->selective_display = mark_object (buffer->selective_display); ! 1054: buffer->minor_modes = mark_object (buffer->minor_modes); ! 1055: buffer->overwrite_mode = mark_object (buffer->overwrite_mode); ! 1056: buffer->abbrev_mode = mark_object (buffer->abbrev_mode); ! 1057: ! 1058: } ! 1059: ! 1060: /* Find all structures not marked, and free them. */ ! 1061: ! 1062: static void ! 1063: gc_sweep (old_string_block) ! 1064: struct string_block *old_string_block; ! 1065: { ! 1066: /* Put all unmarked conses on free list */ ! 1067: { ! 1068: register struct cons_block *cblk; ! 1069: register int lim = cons_block_index; ! 1070: register int num_free = 0, num_used = 0; ! 1071: ! 1072: cons_free_list = 0; ! 1073: ! 1074: for (cblk = cons_block; cblk; cblk = cblk->next) ! 1075: { ! 1076: register int i; ! 1077: for (i = 0; i < lim; i++) ! 1078: if (!XMARKBIT (cblk->conses[i].car)) ! 1079: { ! 1080: XSETCONS (cblk->conses[i].car, cons_free_list); ! 1081: num_free++; ! 1082: cons_free_list = &cblk->conses[i]; ! 1083: } ! 1084: else num_used++; ! 1085: lim = CONS_BLOCK_SIZE; ! 1086: } ! 1087: total_conses = num_used; ! 1088: total_free_conses = num_free; ! 1089: } ! 1090: ! 1091: /* Put all unmarked symbols on free list */ ! 1092: { ! 1093: register struct symbol_block *sblk; ! 1094: register int lim = symbol_block_index; ! 1095: register int num_free = 0, num_used = 0; ! 1096: ! 1097: symbol_free_list = 0; ! 1098: ! 1099: for (sblk = symbol_block; sblk; sblk = sblk->next) ! 1100: { ! 1101: register int i; ! 1102: for (i = 0; i < lim; i++) ! 1103: if (!XMARKBIT (sblk->symbols[i].plist)) ! 1104: { ! 1105: XSETSYMBOL (sblk->symbols[i].value, symbol_free_list); ! 1106: symbol_free_list = &sblk->symbols[i]; ! 1107: num_free++; ! 1108: } ! 1109: else num_used++; ! 1110: lim = SYMBOL_BLOCK_SIZE; ! 1111: } ! 1112: total_symbols = num_used; ! 1113: total_free_symbols = num_free; ! 1114: } ! 1115: ! 1116: #ifndef standalone ! 1117: /* Put all unmarked markers on free list. ! 1118: Dechain each one first from the buffer it points into. */ ! 1119: { ! 1120: register struct marker_block *mblk; ! 1121: struct Lisp_Marker *tem1; ! 1122: register int lim = marker_block_index; ! 1123: register int num_free = 0, num_used = 0; ! 1124: ! 1125: marker_free_list = 0; ! 1126: ! 1127: for (mblk = marker_block; mblk; mblk = mblk->next) ! 1128: { ! 1129: register int i; ! 1130: for (i = 0; i < lim; i++) ! 1131: if (!XMARKBIT (mblk->markers[i].chain)) ! 1132: { ! 1133: Lisp_Object tem; ! 1134: tem1 = &mblk->markers[i]; /* tem1 avoids Sun compiler bug */ ! 1135: XSET (tem, Lisp_Marker, tem1); ! 1136: unchain_marker (tem); ! 1137: XSETMARKER (mblk->markers[i].chain, marker_free_list); ! 1138: marker_free_list = &mblk->markers[i]; ! 1139: num_free++; ! 1140: } ! 1141: else num_used++; ! 1142: lim = MARKER_BLOCK_SIZE; ! 1143: } ! 1144: ! 1145: total_markers = num_used; ! 1146: total_free_markers = num_free; ! 1147: } ! 1148: ! 1149: /* Free all unmarked buffers */ ! 1150: { ! 1151: register struct buffer *buffer = all_buffers, *prev = 0, *next = 0; ! 1152: ! 1153: while (buffer) ! 1154: if (!XMARKBIT (buffer->name)) ! 1155: { ! 1156: if (prev) ! 1157: prev->next = buffer->next; ! 1158: else ! 1159: all_buffers = buffer->next; ! 1160: next = buffer->next; ! 1161: free (buffer); ! 1162: buffer = next; ! 1163: } ! 1164: else ! 1165: { ! 1166: XUNMARK (buffer->name); ! 1167: prev = buffer, buffer = buffer->next; ! 1168: } ! 1169: } ! 1170: ! 1171: #endif standalone ! 1172: ! 1173: /* Free all unmarked vectors */ ! 1174: { ! 1175: register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next = 0; ! 1176: total_vector_size = 0; ! 1177: ! 1178: while (vector) ! 1179: if (!(vector->size & most_negative_fixnum)) ! 1180: { ! 1181: if (prev) ! 1182: prev->next = vector->next; ! 1183: else ! 1184: all_vectors = vector->next; ! 1185: next = vector->next; ! 1186: free (vector); ! 1187: vector = next; ! 1188: } ! 1189: else ! 1190: { ! 1191: vector->size &= ~most_negative_fixnum; ! 1192: total_vector_size += vector->size; ! 1193: prev = vector, vector = vector->next; ! 1194: } ! 1195: } ! 1196: ! 1197: /* Free all old string blocks, since all strings still used have been copied. */ ! 1198: { ! 1199: register struct string_block *sblk = old_string_block; ! 1200: while (sblk) ! 1201: { ! 1202: struct string_block *next = sblk->next; ! 1203: free (sblk); ! 1204: sblk = next; ! 1205: } ! 1206: } ! 1207: } ! 1208: ! 1209: /* Initialization */ ! 1210: ! 1211: init_alloc_once () ! 1212: { ! 1213: register int i, x; ! 1214: /* Compute an int in which only the sign bit is set. */ ! 1215: for (i = 0, x = 1; (x <<= 1) & ~1; i++) ! 1216: /*empty loop*/; ! 1217: most_negative_fixnum = 1 << i; ! 1218: dont_copy_flag = 1 << (i - 1); ! 1219: ! 1220: Vpurify_flag = Qt; ! 1221: ! 1222: pureptr = 0; ! 1223: all_vectors = 0; ! 1224: init_strings (); ! 1225: init_cons (); ! 1226: init_symbol (); ! 1227: init_marker (); ! 1228: gcprolist = 0; ! 1229: staticidx = 0; ! 1230: consing_since_gc = 0; ! 1231: gc_cons_threshold = 100000; ! 1232: #ifdef VIRT_ADDR_VARIES ! 1233: malloc_sbrk_unused = 1<<22; /* A large number */ ! 1234: malloc_sbrk_used = 100000; /* as reasonable as any number */ ! 1235: #endif /* VIRT_ADDR_VARIES */ ! 1236: } ! 1237: ! 1238: init_alloc () ! 1239: { ! 1240: gcprolist = 0; ! 1241: } ! 1242: ! 1243: void ! 1244: syms_of_alloc () ! 1245: { ! 1246: DefIntVar ("gc-cons-threshold", &gc_cons_threshold, ! 1247: "*Number of bytes of consing between garbage collections."); ! 1248: ! 1249: DefIntVar ("pure-bytes-used", &pureptr, ! 1250: "Number of bytes of sharable Lisp data allocated so far."); ! 1251: ! 1252: DefIntVar ("data-bytes-used", &malloc_sbrk_used, ! 1253: "Number of bytes of unshared memory allocated in this session."); ! 1254: ! 1255: DefIntVar ("data-bytes-free", &malloc_sbrk_unused, ! 1256: "Number of bytes of unshared memory remaining available in this session."); ! 1257: ! 1258: DefLispVar ("purify-flag", &Vpurify_flag, ! 1259: "Non-nil means defun should purecopy the function definition."); ! 1260: ! 1261: defsubr (&Scons); ! 1262: defsubr (&Slist); ! 1263: defsubr (&Svector); ! 1264: defsubr (&Smake_list); ! 1265: defsubr (&Smake_vector); ! 1266: defsubr (&Smake_string); ! 1267: defsubr (&Smake_symbol); ! 1268: defsubr (&Smake_marker); ! 1269: defsubr (&Spurecopy); ! 1270: defsubr (&Sgarbage_collect); ! 1271: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.