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