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