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