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