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