4.3BSD - /usr/src/new/emacs/src/alloc.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros