1 /* values.c -- Handling of Lisp data (includes garbage collection)
2 Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk>
3 $Id$
4
5 This file is part of Jade.
6
7 Jade is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 Jade is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with Jade; see the file COPYING. If not, write to
19 the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
20
21 #define _GNU_SOURCE
22
23 /* AIX requires this to be the first thing in the file. */
24 #include <config.h>
25 #ifdef __GNUC__
26 # define alloca __builtin_alloca
27 #else
28 # if HAVE_ALLOCA_H
29 # include <alloca.h>
30 # else
31 # ifdef _AIX
32 #pragma alloca
33 # else
34 # ifndef alloca /* predefined by HP cc +Olibcalls */
35 char *alloca ();
36 # endif
37 # endif
38 # endif
39 #endif
40
41 #include "repint.h"
42 #include <string.h>
43 #include <stdlib.h>
44 #include <assert.h>
45
46 #ifdef NEED_MEMORY_H
47 # include <memory.h>
48 #endif
49
50 /* #define GC_MONITOR_STK */
51
52 #define rep_STRINGBLK_SIZE 510 /* ~4k */
53
54 /* Structure of string header allocation blocks */
55 typedef struct rep_string_block_struct {
56 union {
57 struct rep_string_block_struct *p;
58 /* ensure that the following cons cell is aligned to at
59 least sizeof (rep_string) (for the dcache) */
60 rep_string dummy;
61 } next;
62 rep_string data[rep_STRINGBLK_SIZE];
63 } rep_string_block;
64
65 /* Dumped data */
66 rep_cons *rep_dumped_cons_start, *rep_dumped_cons_end;
67 rep_symbol *rep_dumped_symbols_start, *rep_dumped_symbols_end;
68 repv rep_dumped_non_constants;
69
70 int rep_guardian_type;
71
72 DEFSYM(after_gc_hook, "after-gc-hook");
73
74
75 /* Type handling */
76
77 #define TYPE_HASH_SIZE 32
78 #define TYPE_HASH(type) (((type) >> 1) & (TYPE_HASH_SIZE-1))
79
80 static unsigned int next_free_type = 0;
81 static rep_type *data_types[TYPE_HASH_SIZE];
82
83 void
rep_register_type(unsigned int code,char * name,int (* compare)(repv,repv),void (* princ)(repv,repv),void (* print)(repv,repv),void (* sweep)(void),void (* mark)(repv),void (* mark_type)(void),int (* getc)(repv),int (* ungetc)(repv,int),int (* putc)(repv,int),int (* puts)(repv,void *,int,rep_bool),repv (* bind)(repv),void (* unbind)(repv))84 rep_register_type(unsigned int code, char *name,
85 int (*compare)(repv, repv),
86 void (*princ)(repv, repv),
87 void (*print)(repv, repv),
88 void (*sweep)(void),
89 void (*mark)(repv),
90 void (*mark_type)(void),
91 int (*getc)(repv),
92 int (*ungetc)(repv, int),
93 int (*putc)(repv, int),
94 int (*puts)(repv, void *, int, rep_bool),
95 repv (*bind)(repv),
96 void (*unbind)(repv))
97 {
98 rep_type *t = rep_alloc(sizeof(rep_type));
99 if (t == 0)
100 {
101 rep_mem_error ();
102 return;
103 }
104 t->code = code;
105 t->name = name;
106 t->compare = compare ? compare : rep_ptr_cmp;
107 t->princ = princ;
108 t->print = print;
109 t->sweep = sweep;
110 t->mark = mark;
111 t->mark_type = mark_type;
112 t->getc = getc;
113 t->ungetc = ungetc;
114 t->putc = putc;
115 t->puts = puts;
116 t->bind = bind;
117 t->unbind = unbind;
118 t->next = data_types[TYPE_HASH(code)];
119 data_types[TYPE_HASH(code)] = t;
120 }
121
122 unsigned int
rep_register_new_type(char * name,int (* compare)(repv,repv),void (* princ)(repv,repv),void (* print)(repv,repv),void (* sweep)(void),void (* mark)(repv),void (* mark_type)(void),int (* getc)(repv),int (* ungetc)(repv,int),int (* putc)(repv,int),int (* puts)(repv,void *,int,rep_bool),repv (* bind)(repv),void (* unbind)(repv))123 rep_register_new_type(char *name,
124 int (*compare)(repv, repv),
125 void (*princ)(repv, repv),
126 void (*print)(repv, repv),
127 void (*sweep)(void),
128 void (*mark)(repv),
129 void (*mark_type)(void),
130 int (*getc)(repv),
131 int (*ungetc)(repv, int),
132 int (*putc)(repv, int),
133 int (*puts)(repv, void *, int, rep_bool),
134 repv (*bind)(repv),
135 void (*unbind)(repv))
136 {
137 unsigned int code;
138 assert(next_free_type != 256);
139 code = (next_free_type++ << rep_CELL16_TYPE_SHIFT) | rep_CELL_IS_8 | rep_CELL_IS_16;
140 rep_register_type(code, name, compare, princ, print,
141 sweep, mark, mark_type,
142 getc, ungetc, putc, puts, bind, unbind);
143 return code;
144 }
145
146 rep_type *
rep_get_data_type(unsigned int code)147 rep_get_data_type(unsigned int code)
148 {
149 rep_type *t = data_types[TYPE_HASH(code)];
150 while (t != 0 && t->code != code)
151 t = t->next;
152 assert (t != 0);
153 return t;
154 }
155
156
157 /* General object handling */
158
159 /* Returns zero if V1 == V2, less than zero if V1 < V2, and greater than
160 zero otherwise. */
161 int
rep_value_cmp(repv v1,repv v2)162 rep_value_cmp(repv v1, repv v2)
163 {
164 if(v1 != rep_NULL && v2 != rep_NULL)
165 {
166 rep_type *t1 = rep_get_data_type(rep_TYPE(v1));
167 if (t1 != 0)
168 return (v1 == v2) ? 0 : t1->compare(v1, v2);
169 else
170 return (v1 == v2) ? 0 : 1;
171 }
172 return 1;
173 }
174
175 void
rep_princ_val(repv strm,repv val)176 rep_princ_val(repv strm, repv val)
177 {
178 if(val != rep_NULL)
179 {
180 rep_type *t = rep_get_data_type(rep_TYPE(val));
181 rep_GC_root gc_strm, gc_val;
182 rep_PUSHGC(gc_strm, strm);
183 rep_PUSHGC(gc_val, val);
184 t->princ(strm, val);
185 rep_POPGC; rep_POPGC;
186 }
187 }
188
189 void
rep_print_val(repv strm,repv val)190 rep_print_val(repv strm, repv val)
191 {
192 if(val != rep_NULL)
193 {
194 rep_type *t = rep_get_data_type(rep_TYPE(val));
195 rep_GC_root gc_strm, gc_val;
196 rep_PUSHGC(gc_strm, strm);
197 rep_PUSHGC(gc_val, val);
198 t->print(strm, val);
199 rep_POPGC; rep_POPGC;
200 }
201 }
202
203 int
rep_type_cmp(repv val1,repv val2)204 rep_type_cmp(repv val1, repv val2)
205 {
206 return !(rep_TYPE(val1) == rep_TYPE(val2));
207 }
208
209
210 /* Strings */
211
212 static rep_string_block *string_block_chain;
213 static rep_string *string_freelist;
214 static int allocated_strings, used_strings, allocated_string_bytes;
215
216 DEFSTRING(null_string_const, "");
217
218 repv
rep_null_string(void)219 rep_null_string(void)
220 {
221 return rep_VAL(&null_string_const);
222 }
223
224 DEFSTRING(string_overflow, "String too long");
225
226 /* PTR should have been allocated using rep_alloc or malloc. Ownership
227 of its memory passes to the lisp system. LEN _doesn't_ include the zero
228 terminator */
229 repv
rep_box_string(char * ptr,long len)230 rep_box_string (char *ptr, long len)
231 {
232 rep_string *str;
233
234 if(len > rep_MAX_STRING)
235 return Fsignal(Qerror, rep_LIST_1(rep_VAL(&string_overflow)));
236
237 /* find a string header */
238 str = string_freelist;
239 if(str == NULL)
240 {
241 rep_string_block *cb;
242 cb = rep_alloc(sizeof(rep_string_block));
243 if(cb != NULL)
244 {
245 int i;
246 allocated_strings += rep_STRINGBLK_SIZE;
247 cb->next.p = string_block_chain;
248 string_block_chain = cb;
249 for(i = 0; i < (rep_STRINGBLK_SIZE - 1); i++)
250 cb->data[i].car = rep_VAL(&cb->data[i + 1]);
251 cb->data[i].car = 0;
252 string_freelist = cb->data;
253 }
254 else
255 return rep_mem_error ();
256 str = string_freelist;
257 }
258 string_freelist = rep_STRING(str->car);
259 used_strings++;
260 rep_data_after_gc += sizeof(rep_string);
261
262 str->car = rep_MAKE_STRING_CAR (len);
263 rep_data_after_gc += len;
264 str->data = ptr;
265 return rep_VAL (str);
266 }
267
268 /* Return a string object with room for exactly LEN characters. No extra
269 byte is allocated for a zero terminator; do this manually if required. */
270 repv
rep_make_string(long len)271 rep_make_string(long len)
272 {
273 char *data = rep_alloc (len);
274 if(data != NULL)
275 return rep_box_string (data, len - 1);
276 else
277 return rep_NULL;
278 }
279
280 repv
rep_string_dupn(const char * src,long slen)281 rep_string_dupn(const char *src, long slen)
282 {
283 rep_string *dst = rep_STRING(rep_make_string(slen + 1));
284 if(dst != NULL)
285 {
286 memcpy(rep_STR(dst), src, slen);
287 rep_STR(dst)[slen] = 0;
288 }
289 return rep_VAL(dst);
290 }
291
292 repv
rep_string_dup(const char * src)293 rep_string_dup(const char *src)
294 {
295 return rep_string_dupn(src, strlen(src));
296 }
297
298 repv
rep_concat2(char * s1,char * s2)299 rep_concat2(char *s1, char *s2)
300 {
301 int len = strlen(s1) + strlen(s2);
302 repv res = rep_make_string(len + 1);
303 stpcpy(stpcpy(rep_STR(res), s1), s2);
304 return(res);
305 }
306
307 repv
rep_concat3(char * s1,char * s2,char * s3)308 rep_concat3(char *s1, char *s2, char *s3)
309 {
310 int len = strlen(s1) + strlen(s2) + strlen(s3);
311 repv res = rep_make_string(len + 1);
312 stpcpy(stpcpy(stpcpy(rep_STR(res), s1), s2), s3);
313 return(res);
314 }
315
316 repv
rep_concat4(char * s1,char * s2,char * s3,char * s4)317 rep_concat4(char *s1, char *s2, char *s3, char *s4)
318 {
319 int len = strlen(s1) + strlen(s2) + strlen(s3) + strlen(s4);
320 repv res = rep_make_string(len + 1);
321 stpcpy(stpcpy(stpcpy(stpcpy(rep_STR(res), s1), s2), s3), s4);
322 return(res);
323 }
324
325 static int
string_cmp(repv v1,repv v2)326 string_cmp(repv v1, repv v2)
327 {
328 if(rep_STRINGP(v1) && rep_STRINGP(v2))
329 {
330 long len1 = rep_STRING_LEN(v1);
331 long len2 = rep_STRING_LEN(v2);
332 long tem = memcmp(rep_STR(v1), rep_STR(v2), MIN(len1, len2));
333 return tem != 0 ? tem : (len1 - len2);
334 }
335 else
336 return 1;
337 }
338
339 static void
string_sweep(void)340 string_sweep(void)
341 {
342 rep_string_block *cb = string_block_chain;
343 string_block_chain = NULL;
344 string_freelist = NULL;
345 used_strings = 0;
346 allocated_string_bytes = 0;
347 while(cb != NULL)
348 {
349 rep_string_block *nxt = cb->next.p;
350 rep_string *newfree = NULL, *newfreetail = NULL, *this;
351 int i, newused = 0;
352 for(i = 0, this = cb->data; i < rep_STRINGBLK_SIZE; i++, this++)
353 {
354 /* if on the freelist then the CELL_IS_8 bit
355 will be unset (since the pointer is long aligned) */
356 if(rep_CELL_CONS_P(rep_VAL(this))
357 || !rep_GC_CELL_MARKEDP(rep_VAL(this)))
358 {
359 if(!newfreetail)
360 newfreetail = this;
361 if (!rep_CELL_CONS_P(rep_VAL(this)))
362 rep_free (this->data);
363 this->car = rep_VAL(newfree);
364 newfree = this;
365 }
366 else
367 {
368 rep_GC_CLR_CELL(rep_VAL(this));
369 allocated_string_bytes += rep_STRING_LEN(rep_VAL(this));
370 newused++;
371 }
372 }
373 if(newused == 0)
374 {
375 /* Whole block is unused, get rid of it. */
376 rep_free(cb);
377 allocated_strings -= rep_STRINGBLK_SIZE;
378 }
379 else
380 {
381 if(newfreetail != NULL)
382 {
383 /* Link this mini-freelist onto the main one. */
384 newfreetail->car = rep_VAL(string_freelist);
385 string_freelist = newfree;
386 used_strings += newused;
387 }
388 /* Have to rebuild the block chain as well. */
389 cb->next.p = string_block_chain;
390 string_block_chain = cb;
391 }
392 cb = nxt;
393 }
394 }
395
396 /* Sets the length-field of the dynamic string STR to LEN. */
397 rep_bool
rep_set_string_len(repv str,long len)398 rep_set_string_len(repv str, long len)
399 {
400 if(rep_STRING_WRITABLE_P(str))
401 {
402 rep_STRING(str)->car = rep_MAKE_STRING_CAR(len);
403 return rep_TRUE;
404 }
405 else
406 return rep_FALSE;
407 }
408
409
410 /* Misc */
411
412 int
rep_ptr_cmp(repv v1,repv v2)413 rep_ptr_cmp(repv v1, repv v2)
414 {
415 if(rep_TYPE(v1) == rep_TYPE(v2))
416 return !(rep_PTR(v1) == rep_PTR(v2));
417 else
418 return 1;
419 }
420
421 repv
rep_box_pointer(void * p)422 rep_box_pointer (void *p)
423 {
424 unsigned rep_PTR_SIZED_INT low;
425 low = (unsigned rep_PTR_SIZED_INT)p;
426 if (low <= rep_LISP_MAX_INT)
427 return rep_MAKE_INT (low);
428 else
429 {
430 int i;
431 unsigned rep_PTR_SIZED_INT high = (unsigned rep_PTR_SIZED_INT)p;
432 for (i = rep_PTR_SIZED_INT_BITS / 2; i < rep_PTR_SIZED_INT_BITS; i++)
433 low &= ~(1 << i);
434 high = high >> (rep_PTR_SIZED_INT_BITS/2);
435 return Fcons (rep_MAKE_INT(high), rep_MAKE_INT(low));
436 }
437 }
438
439 void *
rep_unbox_pointer(repv v)440 rep_unbox_pointer (repv v)
441 {
442 if (rep_INTP(v))
443 return (void *) rep_INT(v);
444 else if (rep_CONSP(v))
445 {
446 unsigned rep_PTR_SIZED_INT low, high;
447 low = rep_INT(rep_CDR(v));
448 high = rep_INT(rep_CAR(v));
449 return (void *) (low | high << (rep_PTR_SIZED_INT_BITS/2));
450 }
451 else
452 return 0;
453 }
454
455
456 /* Cons */
457
458 rep_cons_block *rep_cons_block_chain;
459 rep_cons *rep_cons_freelist;
460 int rep_allocated_cons, rep_used_cons;
461
462 rep_cons *
rep_allocate_cons(void)463 rep_allocate_cons (void)
464 {
465 rep_cons *cn;
466 cn = rep_cons_freelist;
467 if(cn == NULL)
468 {
469 rep_cons_block *cb;
470 cb = rep_alloc(sizeof(rep_cons_block));
471 if(cb != NULL)
472 {
473 int i;
474 rep_allocated_cons += rep_CONSBLK_SIZE;
475 cb->next.p = rep_cons_block_chain;
476 rep_cons_block_chain = cb;
477 for(i = 0; i < (rep_CONSBLK_SIZE - 1); i++)
478 cb->cons[i].cdr = rep_CONS_VAL(&cb->cons[i + 1]);
479 cb->cons[i].cdr = 0;
480 rep_cons_freelist = cb->cons;
481 }
482 else
483 return rep_CONS (rep_mem_error ());
484 cn = rep_cons_freelist;
485 }
486 return cn;
487 }
488
489 DEFUN("cons", Fcons, Scons, (repv car, repv cdr), rep_Subr2) /*
490 ::doc:rep.data#cons::
491 cons CAR CDR
492
493 Returns a new cons-cell with car CAR and cdr CDR.
494 ::end:: */
495 {
496 rep_cons *c = rep_cons_freelist;
497 if (c == 0)
498 c = rep_allocate_cons ();
499 rep_cons_freelist = rep_CONS (c->cdr);
500 rep_used_cons++;
501 rep_data_after_gc += sizeof(rep_cons);
502
503 c->car = car;
504 c->cdr = cdr;
505 return rep_CONS_VAL (c);
506 }
507
508 void
rep_cons_free(repv cn)509 rep_cons_free(repv cn)
510 {
511 rep_CDR(cn) = rep_CONS_VAL(rep_cons_freelist);
512 rep_cons_freelist = rep_CONS(cn);
513 rep_used_cons--;
514 }
515
516 static void
cons_sweep(void)517 cons_sweep(void)
518 {
519 rep_cons_block *cb;
520 rep_cons *tem_freelist = 0;
521 int tem_used = 0;
522 for (cb = rep_cons_block_chain; cb != 0; cb = cb->next.p)
523 {
524 register rep_cons *this = cb->cons;
525 rep_cons *last = cb->cons + rep_CONSBLK_SIZE;
526 while (this < last)
527 {
528 if (!rep_GC_CONS_MARKEDP (rep_CONS_VAL (this)))
529 {
530 this->cdr = rep_CONS_VAL (tem_freelist);
531 tem_freelist = rep_CONS (this);
532 }
533 else
534 {
535 rep_GC_CLR_CONS (rep_CONS_VAL (this));
536 tem_used++;
537 }
538 this++;
539 }
540 }
541 rep_cons_freelist = tem_freelist;
542 rep_used_cons = tem_used;
543 }
544
545 static int
cons_cmp(repv v1,repv v2)546 cons_cmp(repv v1, repv v2)
547 {
548 int rc = 1;
549 if(rep_TYPE(v1) == rep_TYPE(v2))
550 {
551 rc = rep_value_cmp(rep_CAR(v1), rep_CAR(v2));
552 if(!rc)
553 rc = rep_value_cmp(rep_CDR(v1), rep_CDR(v2));
554 }
555 return rc;
556 }
557
558 repv
rep_list_1(repv v1)559 rep_list_1(repv v1)
560 {
561 return rep_LIST_1(v1);
562 }
563
564 repv
rep_list_2(repv v1,repv v2)565 rep_list_2(repv v1, repv v2)
566 {
567 return rep_LIST_2(v1, v2);
568 }
569
570 repv
rep_list_3(repv v1,repv v2,repv v3)571 rep_list_3(repv v1, repv v2, repv v3)
572 {
573 return rep_LIST_3(v1, v2, v3);
574 }
575
576 repv
rep_list_4(repv v1,repv v2,repv v3,repv v4)577 rep_list_4(repv v1, repv v2, repv v3, repv v4)
578 {
579 return rep_LIST_4(v1, v2, v3, v4);
580 }
581
582 repv
rep_list_5(repv v1,repv v2,repv v3,repv v4,repv v5)583 rep_list_5(repv v1, repv v2, repv v3, repv v4, repv v5)
584 {
585 return rep_LIST_5(v1, v2, v3, v4, v5);
586 }
587
588
589 /* Vectors */
590
591 static rep_vector *vector_chain;
592 static int used_vector_slots;
593
594 repv
rep_make_vector(int size)595 rep_make_vector(int size)
596 {
597 int len = rep_VECT_SIZE(size);
598 rep_vector *v = rep_ALLOC_CELL(len);
599 if(v != NULL)
600 {
601 rep_SET_VECT_LEN(rep_VAL(v), size);
602 v->next = vector_chain;
603 vector_chain = v;
604 used_vector_slots += size;
605 rep_data_after_gc += len;
606 }
607 return rep_VAL(v);
608 }
609
610 static void
vector_sweep(void)611 vector_sweep(void)
612 {
613 rep_vector *this = vector_chain;
614 vector_chain = NULL;
615 used_vector_slots = 0;
616 while(this != NULL)
617 {
618 rep_vector *nxt = this->next;
619 if(!rep_GC_CELL_MARKEDP(rep_VAL(this)))
620 rep_FREE_CELL(this);
621 else
622 {
623 this->next = vector_chain;
624 vector_chain = this;
625 used_vector_slots += rep_VECT_LEN(this);
626 rep_GC_CLR_CELL(rep_VAL(this));
627 }
628 this = nxt;
629 }
630 }
631
632 static int
vector_cmp(repv v1,repv v2)633 vector_cmp(repv v1, repv v2)
634 {
635 int rc = 1;
636 if((rep_TYPE(v1) == rep_TYPE(v2)) && (rep_VECT_LEN(v1) == rep_VECT_LEN(v2)))
637 {
638 int i;
639 int len = rep_VECT_LEN(v1);
640 for(i = rc = 0; (i < len) && (rc == 0); i++)
641 rc = rep_value_cmp(rep_VECTI(v1, i), rep_VECTI(v2, i));
642 }
643 return rc;
644 }
645
646
647 /* Guardians */
648
649 static rep_guardian *guardians;
650
651 DEFUN("make-primitive-guardian", Fmake_primitive_guardian,
652 Smake_primitive_guardian, (void), rep_Subr0)
653 {
654 rep_guardian *g = rep_ALLOC_CELL (sizeof (rep_guardian));
655 rep_data_after_gc += sizeof (rep_guardian);
656 g->car = rep_guardian_type;
657 g->accessible = Qnil;
658 g->inaccessible = Qnil;
659 g->next = guardians;
660 guardians = g;
661 return rep_VAL(g);
662 }
663
664 DEFUN("primitive-guardian-push", Fprimitive_guardian_push,
665 Sprimitive_guardian_push, (repv g, repv obj), rep_Subr2)
666 {
667 rep_DECLARE1 (g, rep_GUARDIANP);
668 rep_GUARDIAN(g)->accessible = Fcons (obj, rep_GUARDIAN(g)->accessible);
669 return g;
670 }
671
672 DEFUN("primitive-guardian-pop", Fprimitive_guardian_pop,
673 Sprimitive_guardian_pop, (repv g), rep_Subr1)
674 {
675 rep_DECLARE1 (g, rep_GUARDIANP);
676 if (rep_GUARDIAN(g)->inaccessible != Qnil)
677 {
678 repv ret = rep_CAR (rep_GUARDIAN(g)->inaccessible);
679 rep_GUARDIAN(g)->inaccessible = rep_CDR (rep_GUARDIAN(g)->inaccessible);
680 return ret;
681 }
682 else
683 return Qnil;
684 }
685
686 static void
mark_guardian(repv g)687 mark_guardian (repv g)
688 {
689 /* accessible list is marked by run_guardians */
690 rep_MARKVAL (rep_GUARDIAN(g)->inaccessible);
691 }
692
693 static void
run_guardians(void)694 run_guardians (void)
695 {
696 struct saved {
697 struct saved *next;
698 repv obj;
699 } *changed = 0;
700
701 /* scan all guardians for unmarked objects that used to be accessible */
702 rep_guardian *g;
703 for (g = guardians; g != 0; g = g->next)
704 {
705 repv *ptr = &g->accessible;
706 /* cons cells store mark bit in CDR, so mask it out. */
707 while ((*ptr & ~rep_VALUE_CONS_MARK_BIT) != Qnil)
708 {
709 repv cell = *ptr & ~rep_VALUE_CONS_MARK_BIT;
710 if (!rep_GC_MARKEDP (rep_CAR (cell)))
711 {
712 /* move object to inaccessible list */
713 struct saved *new;
714 /* have to preserve the cons mark bit in *ptr */
715 *ptr = rep_GCDR (cell) | (*ptr & rep_VALUE_CONS_MARK_BIT);
716 rep_CDR (cell) = g->inaccessible;
717 g->inaccessible = cell;
718
719 /* note that we need to mark this object */
720 new = alloca (sizeof (struct saved));
721 new->obj = rep_CAR (cell);
722 new->next = changed;
723 changed = new;
724 }
725 else
726 ptr = rep_CDRLOC (cell);
727
728 /* mark the list infrastructure */
729 rep_GC_SET_CONS (cell);
730 }
731 }
732
733 /* mark any objects that changed state */
734 while (changed != 0)
735 {
736 rep_MARKVAL (changed->obj);
737 changed = changed->next;
738 }
739 }
740
741 static void
sweep_guardians(void)742 sweep_guardians (void)
743 {
744 rep_guardian *g = guardians;
745 guardians = 0;
746 while (g)
747 {
748 rep_guardian *next = g->next;
749 if (!rep_GC_CELL_MARKEDP (rep_VAL (g)))
750 rep_FREE_CELL (g);
751 else
752 {
753 rep_GC_CLR_CELL (rep_VAL (g));
754 g->next = guardians;
755 guardians = g;
756 }
757 g = next;
758 }
759 }
760
761 static void
print_guardian(repv stream,repv obj)762 print_guardian (repv stream, repv obj)
763 {
764 rep_stream_puts (stream, "#<guardian>", -1, rep_FALSE);
765 }
766
767
768 /* Garbage collection */
769
770 static repv **static_roots;
771 static int next_static_root, allocated_static_roots;
772
773 rep_GC_root *rep_gc_root_stack = 0;
774 rep_GC_n_roots *rep_gc_n_roots_stack = 0;
775
776 rep_bool rep_in_gc = rep_FALSE;
777
778 /* rep_data_after_gc = bytes of storage used since last gc
779 rep_gc_threshold = value that rep_data_after_gc should be before gc'ing
780 rep_idle_gc_threshold = value that DAGC should be before gc'ing in idle time */
781 int rep_data_after_gc, rep_gc_threshold = 200000, rep_idle_gc_threshold = 20000;
782
783 #ifdef GC_MONITOR_STK
784 static int *gc_stack_high_tide;
785 #endif
786
787 void
rep_mark_static(repv * obj)788 rep_mark_static(repv *obj)
789 {
790 if (next_static_root == allocated_static_roots)
791 {
792 int new_size = (allocated_static_roots
793 ? (allocated_static_roots * 2) : 256);
794 if (static_roots != 0)
795 static_roots = rep_realloc (static_roots,
796 new_size * sizeof (repv *));
797 else
798 static_roots = rep_alloc (new_size * sizeof (repv *));
799 assert (static_roots != 0);
800 allocated_static_roots = new_size;
801 }
802 static_roots[next_static_root++] = obj;
803 }
804
805 /* Mark a single Lisp object.
806 This attempts to eliminate as much tail-recursion as possible (by
807 changing the rep_VAL and jumping back to the `again' label).
808
809 Note that rep_VAL must not be NULL, and must not already have been
810 marked, (see the rep_MARKVAL macro in lisp.h) */
811 void
rep_mark_value(register repv val)812 rep_mark_value(register repv val)
813 {
814 #ifdef GC_MONITOR_STK
815 int dummy;
816 /* Assumes that the stack grows downwards (towards 0) */
817 if(&dummy < gc_stack_high_tide)
818 gc_stack_high_tide = &dummy;
819 #endif
820
821 again:
822 if(rep_INTP(val))
823 return;
824
825 /* must be a cell */
826 if(rep_CELL_CONS_P(val))
827 {
828 if(rep_CONS_WRITABLE_P(val))
829 {
830 /* A cons. Attempts to walk though whole lists at a time
831 (since Lisp lists mainly link from the cdr). */
832 rep_GC_SET_CONS(val);
833 if(rep_NILP(rep_GCDR(val)))
834 /* End of a list. We can safely
835 mark the car non-recursively. */
836 val = rep_CAR(val);
837 else
838 {
839 rep_MARKVAL(rep_CAR(val));
840 val = rep_GCDR(val);
841 }
842 if(val && !rep_INTP(val) && !rep_GC_MARKEDP(val))
843 goto again;
844 return;
845 }
846 else
847 {
848 /* A constant cons cell. */
849 return;
850 }
851 }
852
853 if (rep_CELL16P(val))
854 {
855 /* A user allocated type. */
856 rep_type *t = rep_get_data_type(rep_CELL16_TYPE(val));
857 rep_GC_SET_CELL(val);
858 if (t->mark != 0)
859 t->mark(val);
860 return;
861 }
862
863 /* So we know that it's a cell8 object */
864 switch(rep_CELL8_TYPE(val))
865 {
866 rep_type *t;
867
868 case rep_Vector:
869 case rep_Compiled:
870 if(rep_VECTOR_WRITABLE_P(val))
871 {
872 int i, len = rep_VECT_LEN(val);
873 rep_GC_SET_CELL(val);
874 for(i = 0; i < len; i++)
875 rep_MARKVAL(rep_VECTI(val, i));
876 }
877 break;
878
879 case rep_Symbol:
880 /* Dumped symbols are dumped read-write, so no worries.. */
881 rep_GC_SET_CELL(val);
882 rep_MARKVAL(rep_SYM(val)->name);
883 val = rep_SYM(val)->next;
884 if(val && !rep_INTP(val) && !rep_GC_MARKEDP(val))
885 goto again;
886 break;
887
888 case rep_String:
889 if(!rep_STRING_WRITABLE_P(val))
890 break;
891 rep_GC_SET_CELL(val);
892 break;
893
894 case rep_Number:
895 rep_GC_SET_CELL(val);
896 break;
897
898 case rep_Funarg:
899 if (!rep_FUNARG_WRITABLE_P(val))
900 break;
901 rep_GC_SET_CELL(val);
902 rep_MARKVAL(rep_FUNARG(val)->name);
903 rep_MARKVAL(rep_FUNARG(val)->env);
904 rep_MARKVAL(rep_FUNARG(val)->structure);
905 val = rep_FUNARG(val)->fun;
906 if (val && !rep_GC_MARKEDP(val))
907 goto again;
908 break;
909
910 case rep_Subr0:
911 case rep_Subr1:
912 case rep_Subr2:
913 case rep_Subr3:
914 case rep_Subr4:
915 case rep_Subr5:
916 case rep_SubrN:
917 case rep_SF:
918 break;
919
920 default:
921 t = rep_get_data_type(rep_CELL8_TYPE(val));
922 rep_GC_SET_CELL(val);
923 if (t->mark != 0)
924 t->mark(val);
925 }
926 }
927
928 DEFUN("garbage-threshold", Fgarbage_threshold, Sgarbage_threshold, (repv val), rep_Subr1) /*
929 ::doc:rep.data#garbage-threshold::
930 garbage-threshold [NEW-VALUE]
931
932 The number of bytes of storage which must be used before a garbage-
933 collection is triggered.
934 ::end:: */
935 {
936 return rep_handle_var_int(val, &rep_gc_threshold);
937 }
938
939 DEFUN("idle-garbage-threshold", Fidle_garbage_threshold, Sidle_garbage_threshold, (repv val), rep_Subr1) /*
940 ::doc:rep.data#idle-garbage-threshold::
941 idle-garbage-threshold [NEW-VALUE]
942
943 The number of bytes of storage which must be used before a garbage-
944 collection is triggered when the editor is idle.
945 ::end:: */
946 {
947 return rep_handle_var_int(val, &rep_idle_gc_threshold);
948 }
949
950 DEFUN_INT("garbage-collect", Fgarbage_collect, Sgarbage_collect, (repv stats), rep_Subr1, "") /*
951 ::doc:rep.data#garbage-collect::
952 garbage-collect
953
954 Scans all allocated storage for unusable data, and puts it onto the free-
955 list. This is done automatically when the amount of storage used since the
956 last garbage-collection is greater than `garbage-threshold'.
957 ::end:: */
958 {
959 int i;
960 rep_GC_root *rep_gc_root;
961 rep_GC_n_roots *rep_gc_n_roots;
962 struct rep_Call *lc;
963 #ifdef GC_MONITOR_STK
964 int dummy;
965 gc_stack_high_tide = &dummy;
966 #endif
967
968 rep_in_gc = rep_TRUE;
969
970 rep_macros_before_gc ();
971
972 /* mark static objects */
973 for(i = 0; i < next_static_root; i++)
974 rep_MARKVAL(*static_roots[i]);
975 /* mark stack based objects protected from GC */
976 for(rep_gc_root = rep_gc_root_stack;
977 rep_gc_root != 0; rep_gc_root = rep_gc_root->next)
978 {
979 rep_MARKVAL(*rep_gc_root->ptr);
980 }
981 for(rep_gc_n_roots = rep_gc_n_roots_stack; rep_gc_n_roots != 0;
982 rep_gc_n_roots = rep_gc_n_roots->next)
983 {
984 for(i = 0; i < rep_gc_n_roots->count; i++)
985 rep_MARKVAL(rep_gc_n_roots->first[i]);
986 }
987
988 /* Do data-type specific marking. */
989 for (i = 0; i < TYPE_HASH_SIZE; i++)
990 {
991 rep_type *t = data_types[i];
992 while (t != 0)
993 {
994 if (t->mark_type != 0)
995 t->mark_type();
996 t = t->next;
997 }
998 }
999
1000 rep_mark_regexp_data();
1001 rep_mark_origins ();
1002
1003 #ifdef HAVE_DYNAMIC_LOADING
1004 rep_mark_dl_data();
1005 #endif
1006
1007 /* have to mark the Lisp backtrace. */
1008 lc = rep_call_stack;
1009 while(lc)
1010 {
1011 rep_MARKVAL(lc->fun);
1012 rep_MARKVAL(lc->args);
1013 rep_MARKVAL(lc->current_form);
1014 rep_MARKVAL(lc->saved_env);
1015 rep_MARKVAL(lc->saved_structure);
1016 lc = lc->next;
1017 }
1018
1019 /* move and mark any guarded objects that became inaccessible */
1020 run_guardians ();
1021
1022 /* look for dead weak references */
1023 rep_scan_weak_refs ();
1024
1025 /* Finished marking, start sweeping. */
1026
1027 rep_sweep_tuples ();
1028 for(i = 0; i < TYPE_HASH_SIZE; i++)
1029 {
1030 rep_type *t = data_types[i];
1031 while (t != 0)
1032 {
1033 if (t->sweep != 0)
1034 t->sweep();
1035 t = t->next;
1036 }
1037 }
1038
1039 rep_data_after_gc = 0;
1040 rep_in_gc = rep_FALSE;
1041
1042 #ifdef GC_MONITOR_STK
1043 fprintf(stderr, "gc: stack usage = %d\n",
1044 ((int)&dummy) - (int)gc_stack_high_tide);
1045 #endif
1046
1047 Fcall_hook (Qafter_gc_hook, Qnil, Qnil);
1048
1049 if(stats != Qnil)
1050 {
1051 return rep_list_5(Fcons(rep_MAKE_INT(rep_used_cons),
1052 rep_MAKE_INT(rep_allocated_cons - rep_used_cons)),
1053 Fcons(rep_MAKE_INT(rep_used_tuples),
1054 rep_MAKE_INT(rep_allocated_tuples
1055 - rep_used_tuples)),
1056 rep_list_3(rep_MAKE_INT(used_strings),
1057 rep_MAKE_INT(allocated_strings),
1058 rep_MAKE_INT(allocated_string_bytes)),
1059 rep_MAKE_INT(used_vector_slots),
1060 Fcons(rep_MAKE_INT(rep_used_funargs),
1061 rep_MAKE_INT(rep_allocated_funargs
1062 - rep_used_funargs)));
1063 }
1064 else
1065 return Qt;
1066 }
1067
1068
1069 void
rep_pre_values_init(void)1070 rep_pre_values_init(void)
1071 {
1072 rep_register_type(rep_Cons, "cons", cons_cmp,
1073 rep_lisp_prin, rep_lisp_prin, cons_sweep, 0, 0, 0, 0, 0, 0, 0, 0);
1074 rep_register_type(rep_Vector, "vector", vector_cmp,
1075 rep_lisp_prin, rep_lisp_prin, vector_sweep, 0, 0, 0, 0, 0, 0, 0, 0);
1076 rep_register_type(rep_String, "string", string_cmp, rep_string_princ,
1077 rep_string_print, string_sweep, 0, 0, 0, 0, 0, 0, 0, 0);
1078 rep_register_type(rep_Compiled, "bytecode", vector_cmp,
1079 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1080 rep_register_type(rep_Void, "void", rep_type_cmp,
1081 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1082 rep_register_type(rep_SF, "special-form", rep_ptr_cmp,
1083 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1084 rep_register_type(rep_Subr0, "subr0", rep_ptr_cmp,
1085 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1086 rep_register_type(rep_Subr1, "subr1", rep_ptr_cmp,
1087 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1088 rep_register_type(rep_Subr2, "subr2", rep_ptr_cmp,
1089 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1090 rep_register_type(rep_Subr3, "subr3", rep_ptr_cmp,
1091 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1092 rep_register_type(rep_Subr4, "subr4", rep_ptr_cmp,
1093 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1094 rep_register_type(rep_Subr5, "subr5", rep_ptr_cmp,
1095 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1096 rep_register_type(rep_SubrN, "subrn", rep_ptr_cmp,
1097 rep_lisp_prin, rep_lisp_prin, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1098
1099 rep_guardian_type = rep_register_new_type ("guardian", rep_ptr_cmp,
1100 print_guardian, print_guardian,
1101 sweep_guardians, mark_guardian,
1102 0, 0, 0, 0, 0, 0, 0);
1103 }
1104
1105 void
rep_values_init(void)1106 rep_values_init(void)
1107 {
1108 repv tem = rep_push_structure ("rep.data");
1109 rep_ADD_SUBR(Scons);
1110 rep_ADD_SUBR(Sgarbage_threshold);
1111 rep_ADD_SUBR(Sidle_garbage_threshold);
1112 rep_ADD_SUBR_INT(Sgarbage_collect);
1113 rep_ADD_INTERNAL_SUBR(Smake_primitive_guardian);
1114 rep_ADD_INTERNAL_SUBR(Sprimitive_guardian_push);
1115 rep_ADD_INTERNAL_SUBR(Sprimitive_guardian_pop);
1116 rep_INTERN_SPECIAL(after_gc_hook);
1117 rep_pop_structure (tem);
1118 }
1119
1120 void
rep_values_kill(void)1121 rep_values_kill(void)
1122 {
1123 rep_cons_block *cb = rep_cons_block_chain;
1124 rep_vector *v = vector_chain;
1125 rep_string_block *s = string_block_chain;
1126 while(cb != NULL)
1127 {
1128 rep_cons_block *nxt = cb->next.p;
1129 rep_free(cb);
1130 cb = nxt;
1131 }
1132 while(v != NULL)
1133 {
1134 rep_vector *nxt = v->next;
1135 rep_FREE_CELL(v);
1136 v = nxt;
1137 }
1138 while(s != NULL)
1139 {
1140 int i;
1141 rep_string_block *nxt = s->next.p;
1142 for (i = 0; i < rep_STRINGBLK_SIZE; i++)
1143 {
1144 if (!rep_CELL_CONS_P (rep_VAL(s->data + i)))
1145 rep_free (s->data[i].data);
1146 }
1147 rep_free(s);
1148 s = nxt;
1149 }
1150 rep_cons_block_chain = NULL;
1151 vector_chain = NULL;
1152 string_block_chain = NULL;
1153 }
1154
1155
1156 /* Support for dumped Lisp code */
1157
1158 #ifdef ENABLE_BROKEN_DUMPING
1159 void
rep_dumped_init(char * file)1160 rep_dumped_init(char *file)
1161 {
1162 void *dl = rep_open_dl_library (rep_string_dup (file));
1163 if (dl == 0)
1164 fprintf (stderr, "warning: couldn't open dumped filed %s\n", file);
1165 else
1166 {
1167 /* Main function is to go through all dumped symbols, interning
1168 them, and changing rep_NULL values to be void. */
1169 rep_symbol *s;
1170
1171 /* But first, intern nil, it'll be filled in later. */
1172 Qnil = Fintern_symbol (rep_VAL(rep_dumped_symbols_end - 1),
1173 rep_void_value);
1174
1175 /* Stop one symbol too early, since we've already added it */
1176 for (s = rep_dumped_symbols_start; s < rep_dumped_symbols_end - 1; s++)
1177 {
1178 /* Second arg is [OBARRAY], but it's only checked against
1179 being a vector. */
1180 Fintern_symbol (rep_VAL(s), rep_void_value);
1181 if (s->value == rep_NULL)
1182 s->value = rep_void_value;
1183 }
1184 }
1185 }
1186 #endif
1187