1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
20
21 #include <config.h>
22 #include <stdio.h>
23 #include <limits.h>
24 #include <setjmp.h>
25
26 #ifdef STDC_HEADERS
27 #include <stddef.h>
28 #endif
29
30 #ifdef ALLOC_DEBUG
31 #undef INLINE
32 #endif
33
34 #include <signal.h>
35
36 #ifdef HAVE_GTK_AND_PTHREAD
37 #include <pthread.h>
38 #endif
39
40 41 42
43
44 #undef HIDE_LISP_IMPLEMENTATION
45 #include "lisp.h"
46 #include "process.h"
47 #include "intervals.h"
48 #include "puresize.h"
49 #include "buffer.h"
50 #include "window.h"
51 #include "keyboard.h"
52 #include "frame.h"
53 #include "blockinput.h"
54 #include "character.h"
55 #include "syssignal.h"
56 #include "termhooks.h"
57 #include <setjmp.h>
58
59 60
61
62 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
63 #undef GC_MALLOC_CHECK
64 #endif
65
66 #ifdef HAVE_UNISTD_H
67 #include <unistd.h>
68 #else
69 extern POINTER_TYPE *sbrk ();
70 #endif
71
72 #ifdef HAVE_FCNTL_H
73 #define INCLUDED_FCNTL
74 #include <fcntl.h>
75 #endif
76 #ifndef O_WRONLY
77 #define O_WRONLY 1
78 #endif
79
80 #ifdef WINDOWSNT
81 #include <fcntl.h>
82 #include "w32.h"
83 #endif
84
85 #ifdef DOUG_LEA_MALLOC
86
87 #include <malloc.h>
88
89 #ifndef __malloc_size_t
90 #define __malloc_size_t int
91 #endif
92
93 94
95
96 #define MMAP_MAX_AREAS 100000000
97
98 #else
99
100
101
102 #define __malloc_size_t size_t
103 extern __malloc_size_t _bytes_used;
104 extern __malloc_size_t __malloc_extra_blocks;
105
106 #endif
107
108 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
109
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
126
127 static pthread_mutex_t alloc_mutex;
128
129 #define BLOCK_INPUT_ALLOC \
130 do \
131 { \
132 if (pthread_equal (pthread_self (), main_thread)) \
133 BLOCK_INPUT; \
134 pthread_mutex_lock (&alloc_mutex); \
135 } \
136 while (0)
137 #define UNBLOCK_INPUT_ALLOC \
138 do \
139 { \
140 pthread_mutex_unlock (&alloc_mutex); \
141 if (pthread_equal (pthread_self (), main_thread)) \
142 UNBLOCK_INPUT; \
143 } \
144 while (0)
145
146 #else
147
148 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
149 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
150
151 #endif
152
153
154
155 static __malloc_size_t bytes_used_when_full;
156
157 static __malloc_size_t bytes_used_when_reconsidered;
158
159 160
161
162 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
163 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
164 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
165
166 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
167 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
168 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
169
170 171 172 173
174
175 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
176 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
177
178
179
180 int consing_since_gc;
181
182
183
184 EMACS_INT cons_cells_consed;
185 EMACS_INT floats_consed;
186 EMACS_INT vector_cells_consed;
187 EMACS_INT symbols_consed;
188 EMACS_INT string_chars_consed;
189 EMACS_INT misc_objects_consed;
190 EMACS_INT intervals_consed;
191 EMACS_INT strings_consed;
192
193
194
195 EMACS_INT gc_cons_threshold;
196
197
198
199 EMACS_INT gc_relative_threshold;
200
201 static Lisp_Object Vgc_cons_percentage;
202
203 204
205
206 EMACS_INT memory_full_cons_threshold;
207
208
209
210 int gc_in_progress;
211
212 213 214
215
216 int abort_on_gc;
217
218
219
220 int garbage_collection_messages;
221
222 #ifndef VIRT_ADDR_VARIES
223 extern
224 #endif
225 int malloc_sbrk_used;
226
227 #ifndef VIRT_ADDR_VARIES
228 extern
229 #endif
230 int malloc_sbrk_unused;
231
232
233
234 static int total_conses, total_markers, total_symbols, total_vector_size;
235 static int total_free_conses, total_free_markers, total_free_symbols;
236 static int total_free_floats, total_floats;
237
238 239 240
241
242 static char *spare_memory[7];
243
244
245
246 #define SPARE_MEMORY (1 << 14)
247
248
249
250 static int malloc_hysteresis;
251
252
253
254 Lisp_Object Vpurify_flag;
255
256
257
258 Lisp_Object Vmemory_full;
259
260 261 262 263 264
265
266 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
267 #define PUREBEG (char *) pure
268
269
270
271 static char *purebeg;
272 static size_t pure_size;
273
274 275
276
277 static size_t pure_bytes_used_before_overflow;
278
279
280
281 #define PURE_POINTER_P(P) \
282 (((PNTR_COMPARISON_TYPE) (P) \
283 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
284 && ((PNTR_COMPARISON_TYPE) (P) \
285 >= (PNTR_COMPARISON_TYPE) purebeg))
286
287
288
289 EMACS_INT pure_bytes_used;
290
291
292
293 static EMACS_INT pure_bytes_used_lisp;
294
295
296
297 static EMACS_INT pure_bytes_used_non_lisp;
298
299 300
301
302 char *pending_malloc_warning;
303
304
305
306 Lisp_Object Vmemory_signal_data;
307
308
309
310 #ifndef MAX_SAVE_STACK
311 #define MAX_SAVE_STACK 16000
312 #endif
313
314
315
316 static char *stack_copy;
317 static int stack_copy_size;
318
319 320
321
322 static int ignore_warnings;
323
324 Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
325
326
327
328 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
329
330 Lisp_Object Vgc_elapsed;
331 EMACS_INT gcs_done;
332
333 static void mark_buffer P_ ((Lisp_Object));
334 static void mark_terminals P_ ((void));
335 extern void mark_kboards P_ ((void));
336 extern void mark_ttys P_ ((void));
337 extern void mark_backtrace P_ ((void));
338 static void gc_sweep P_ ((void));
339 static void mark_glyph_matrix P_ ((struct glyph_matrix *));
340 static void mark_face_cache P_ ((struct face_cache *));
341
342 #ifdef HAVE_WINDOW_SYSTEM
343 extern void mark_fringe_data P_ ((void));
344 #endif
345
346 static struct Lisp_String *allocate_string P_ ((void));
347 static void compact_small_strings P_ ((void));
348 static void free_large_strings P_ ((void));
349 static void sweep_strings P_ ((void));
350
351 extern int message_enable_multibyte;
352
353 354 355
356
357 enum mem_type
358 {
359 MEM_TYPE_NON_LISP,
360 MEM_TYPE_BUFFER,
361 MEM_TYPE_CONS,
362 MEM_TYPE_STRING,
363 MEM_TYPE_MISC,
364 MEM_TYPE_SYMBOL,
365 MEM_TYPE_FLOAT,
366 367 368 369
370 MEM_TYPE_VECTORLIKE
371 };
372
373 static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
374 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
375 void refill_memory_reserve ();
376
377
378 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
379
380 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
381 #include <stdio.h>
382 #endif
383
384 385
386
387 static Lisp_Object Vdead;
388
389 #ifdef GC_MALLOC_CHECK
390
391 enum mem_type allocated_mem_type;
392 static int dont_register_blocks;
393
394 #endif
395
396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
419
420 struct mem_node
421 {
422 423
424 struct mem_node *left, *right;
425
426
427 struct mem_node *parent;
428
429
430 void *start, *end;
431
432
433 enum {MEM_BLACK, MEM_RED} color;
434
435
436 enum mem_type type;
437 };
438
439
440
441 Lisp_Object *stack_base;
442
443
444
445 static struct mem_node *mem_root;
446
447
448
449 static void *min_heap_address, *max_heap_address;
450
451
452
453 static struct mem_node mem_z;
454 #define MEM_NIL &mem_z
455
456 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
457 static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
458 static void lisp_free P_ ((POINTER_TYPE *));
459 static void mark_stack P_ ((void));
460 static int live_vector_p P_ ((struct mem_node *, void *));
461 static int live_buffer_p P_ ((struct mem_node *, void *));
462 static int live_string_p P_ ((struct mem_node *, void *));
463 static int live_cons_p P_ ((struct mem_node *, void *));
464 static int live_symbol_p P_ ((struct mem_node *, void *));
465 static int live_float_p P_ ((struct mem_node *, void *));
466 static int live_misc_p P_ ((struct mem_node *, void *));
467 static void mark_maybe_object P_ ((Lisp_Object));
468 static void mark_memory P_ ((void *, void *, int));
469 static void mem_init P_ ((void));
470 static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
471 static void mem_insert_fixup P_ ((struct mem_node *));
472 static void mem_rotate_left P_ ((struct mem_node *));
473 static void mem_rotate_right P_ ((struct mem_node *));
474 static void mem_delete P_ ((struct mem_node *));
475 static void mem_delete_fixup P_ ((struct mem_node *));
476 static INLINE struct mem_node *mem_find P_ ((void *));
477
478
479 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
480 static void check_gcpros P_ ((void));
481 #endif
482
483 #endif
484
485
486
487 struct gcpro *gcprolist;
488
489 490
491
492 #define NSTATICS 0x640
493 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
494
495
496
497 static int staticidx = 0;
498
499 static POINTER_TYPE *pure_alloc P_ ((size_t, int));
500
501
502 503
504
505 #define ALIGN(ptr, ALIGNMENT) \
506 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
507 & ~((ALIGNMENT) - 1)))
508
509
510
511 512 513
514
515
516
517 void
518 malloc_warning (str)
519 char *str;
520 {
521 pending_malloc_warning = str;
522 }
523
524
525
526
527 void
528 display_malloc_warning ()
529 {
530 call3 (intern ("display-warning"),
531 intern ("alloc"),
532 build_string (pending_malloc_warning),
533 intern ("emergency"));
534 pending_malloc_warning = 0;
535 }
536
537
538 #ifdef DOUG_LEA_MALLOC
539 # define BYTES_USED (mallinfo ().uordblks)
540 #else
541 # define BYTES_USED _bytes_used
542 #endif
543
544
545
546 void
547 buffer_memory_full ()
548 {
549 550 551 552 553 554
555
556 #ifndef REL_ALLOC
557 memory_full ();
558 #endif
559
560 561
562 xsignal (Qnil, Vmemory_signal_data);
563 }
564
565
566 #ifdef XMALLOC_OVERRUN_CHECK
567
568 569 570 571 572 573 574 575 576 577
578
579
580 #define XMALLOC_OVERRUN_CHECK_SIZE 16
581
582 static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
583 { 0x9a, 0x9b, 0xae, 0xaf,
584 0xbf, 0xbe, 0xce, 0xcf,
585 0xea, 0xeb, 0xec, 0xed };
586
587 static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
588 { 0xaa, 0xab, 0xac, 0xad,
589 0xba, 0xbb, 0xbc, 0xbd,
590 0xca, 0xcb, 0xcc, 0xcd,
591 0xda, 0xdb, 0xdc, 0xdd };
592
593
594
595 #define XMALLOC_PUT_SIZE(ptr, size) \
596 (ptr[-1] = (size & 0xff), \
597 ptr[-2] = ((size >> 8) & 0xff), \
598 ptr[-3] = ((size >> 16) & 0xff), \
599 ptr[-4] = ((size >> 24) & 0xff))
600
601 #define XMALLOC_GET_SIZE(ptr) \
602 (size_t)((unsigned)(ptr[-1]) | \
603 ((unsigned)(ptr[-2]) << 8) | \
604 ((unsigned)(ptr[-3]) << 16) | \
605 ((unsigned)(ptr[-4]) << 24))
606
607
608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
626
627 static int check_depth;
628
629
630
631 POINTER_TYPE *
632 overrun_check_malloc (size)
633 size_t size;
634 {
635 register unsigned char *val;
636 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
637
638 val = (unsigned char *) malloc (size + overhead);
639 if (val && check_depth == 1)
640 {
641 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
642 val += XMALLOC_OVERRUN_CHECK_SIZE;
643 XMALLOC_PUT_SIZE(val, size);
644 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
645 }
646 --check_depth;
647 return (POINTER_TYPE *)val;
648 }
649
650
651 652
653
654 POINTER_TYPE *
655 overrun_check_realloc (block, size)
656 POINTER_TYPE *block;
657 size_t size;
658 {
659 register unsigned char *val = (unsigned char *)block;
660 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
661
662 if (val
663 && check_depth == 1
664 && bcmp (xmalloc_overrun_check_header,
665 val - XMALLOC_OVERRUN_CHECK_SIZE,
666 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
667 {
668 size_t osize = XMALLOC_GET_SIZE (val);
669 if (bcmp (xmalloc_overrun_check_trailer,
670 val + osize,
671 XMALLOC_OVERRUN_CHECK_SIZE))
672 abort ();
673 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
674 val -= XMALLOC_OVERRUN_CHECK_SIZE;
675 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
676 }
677
678 val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
679
680 if (val && check_depth == 1)
681 {
682 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
683 val += XMALLOC_OVERRUN_CHECK_SIZE;
684 XMALLOC_PUT_SIZE(val, size);
685 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
686 }
687 --check_depth;
688 return (POINTER_TYPE *)val;
689 }
690
691
692
693 void
694 overrun_check_free (block)
695 POINTER_TYPE *block;
696 {
697 unsigned char *val = (unsigned char *)block;
698
699 ++check_depth;
700 if (val
701 && check_depth == 1
702 && bcmp (xmalloc_overrun_check_header,
703 val - XMALLOC_OVERRUN_CHECK_SIZE,
704 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
705 {
706 size_t osize = XMALLOC_GET_SIZE (val);
707 if (bcmp (xmalloc_overrun_check_trailer,
708 val + osize,
709 XMALLOC_OVERRUN_CHECK_SIZE))
710 abort ();
711 #ifdef XMALLOC_CLEAR_FREE_MEMORY
712 val -= XMALLOC_OVERRUN_CHECK_SIZE;
713 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
714 #else
715 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
716 val -= XMALLOC_OVERRUN_CHECK_SIZE;
717 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
718 #endif
719 }
720
721 free (val);
722 --check_depth;
723 }
724
725 #undef malloc
726 #undef realloc
727 #undef free
728 #define malloc overrun_check_malloc
729 #define realloc overrun_check_realloc
730 #define free overrun_check_free
731 #endif
732
733 #ifdef SYNC_INPUT
734 735
736 #define MALLOC_BLOCK_INPUT ((void)0)
737 #define MALLOC_UNBLOCK_INPUT ((void)0)
738 #else
739 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
740 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
741 #endif
742
743
744
745 POINTER_TYPE *
746 xmalloc (size)
747 size_t size;
748 {
749 register POINTER_TYPE *val;
750
751 MALLOC_BLOCK_INPUT;
752 val = (POINTER_TYPE *) malloc (size);
753 MALLOC_UNBLOCK_INPUT;
754
755 if (!val && size)
756 memory_full ();
757 return val;
758 }
759
760
761
762
763 POINTER_TYPE *
764 xrealloc (block, size)
765 POINTER_TYPE *block;
766 size_t size;
767 {
768 register POINTER_TYPE *val;
769
770 MALLOC_BLOCK_INPUT;
771 772
773 if (! block)
774 val = (POINTER_TYPE *) malloc (size);
775 else
776 val = (POINTER_TYPE *) realloc (block, size);
777 MALLOC_UNBLOCK_INPUT;
778
779 if (!val && size) memory_full ();
780 return val;
781 }
782
783
784
785
786 void
787 xfree (block)
788 POINTER_TYPE *block;
789 {
790 if (!block)
791 return;
792 MALLOC_BLOCK_INPUT;
793 free (block);
794 MALLOC_UNBLOCK_INPUT;
795 796 797
798 }
799
800
801
802
803 char *
804 xstrdup (s)
805 const char *s;
806 {
807 size_t len = strlen (s) + 1;
808 char *p = (char *) xmalloc (len);
809 bcopy (s, p, len);
810 return p;
811 }
812
813
814
815
816 Lisp_Object
817 safe_alloca_unwind (arg)
818 Lisp_Object arg;
819 {
820 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
821
822 p->dogc = 0;
823 xfree (p->pointer);
824 p->pointer = 0;
825 free_misc (arg);
826 return Qnil;
827 }
828
829
830 831 832
833
834 #ifndef USE_LSB_TAG
835 static void *lisp_malloc_loser;
836 #endif
837
838 static POINTER_TYPE *
839 lisp_malloc (nbytes, type)
840 size_t nbytes;
841 enum mem_type type;
842 {
843 register void *val;
844
845 MALLOC_BLOCK_INPUT;
846
847 #ifdef GC_MALLOC_CHECK
848 allocated_mem_type = type;
849 #endif
850
851 val = (void *) malloc (nbytes);
852
853 #ifndef USE_LSB_TAG
854 855 856
857 if (val && type != MEM_TYPE_NON_LISP)
858 {
859 Lisp_Object tem;
860 XSETCONS (tem, (char *) val + nbytes - 1);
861 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
862 {
863 lisp_malloc_loser = val;
864 free (val);
865 val = 0;
866 }
867 }
868 #endif
869
870 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
871 if (val && type != MEM_TYPE_NON_LISP)
872 mem_insert (val, (char *) val + nbytes, type);
873 #endif
874
875 MALLOC_UNBLOCK_INPUT;
876 if (!val && nbytes)
877 memory_full ();
878 return val;
879 }
880
881 882
883
884 static void
885 lisp_free (block)
886 POINTER_TYPE *block;
887 {
888 MALLOC_BLOCK_INPUT;
889 free (block);
890 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
891 mem_delete (mem_find (block));
892 #endif
893 MALLOC_UNBLOCK_INPUT;
894 }
895
896
897
898
899
900 901 902
903 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
904 #define USE_POSIX_MEMALIGN 1
905 #endif
906
907
908 #define BLOCK_ALIGN (1 << 10)
909
910 911 912 913 914 915 916 917 918 919
920 #define BLOCK_PADDING 0
921 #define BLOCK_BYTES \
922 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
923
924
925
926 #define ABLOCKS_SIZE 16
927
928
929 struct ablock
930 {
931 union
932 {
933 char payload[BLOCK_BYTES];
934 struct ablock *next_free;
935 } x;
936
937 938 939 940 941 942 943 944
945 struct ablocks *abase;
946 947
948 #if BLOCK_PADDING
949 char padding[BLOCK_PADDING];
950 #endif
951 };
952
953
954 struct ablocks
955 {
956 struct ablock blocks[ABLOCKS_SIZE];
957 };
958
959
960 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
961
962 #define ABLOCK_ABASE(block) \
963 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
964 ? (struct ablocks *)(block) \
965 : (block)->abase)
966
967
968 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
969
970
971 #ifdef USE_POSIX_MEMALIGN
972 #define ABLOCKS_BASE(abase) (abase)
973 #else
974 #define ABLOCKS_BASE(abase) \
975 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
976 #endif
977
978
979 static struct ablock *free_ablock;
980
981 982 983
984 static POINTER_TYPE *
985 lisp_align_malloc (nbytes, type)
986 size_t nbytes;
987 enum mem_type type;
988 {
989 void *base, *val;
990 struct ablocks *abase;
991
992 eassert (nbytes <= BLOCK_BYTES);
993
994 MALLOC_BLOCK_INPUT;
995
996 #ifdef GC_MALLOC_CHECK
997 allocated_mem_type = type;
998 #endif
999
1000 if (!free_ablock)
1001 {
1002 int i;
1003 EMACS_INT aligned;
1004
1005 #ifdef DOUG_LEA_MALLOC
1006 1007 1008
1009 mallopt (M_MMAP_MAX, 0);
1010 #endif
1011
1012 #ifdef USE_POSIX_MEMALIGN
1013 {
1014 int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
1015 if (err)
1016 base = NULL;
1017 abase = base;
1018 }
1019 #else
1020 base = malloc (ABLOCKS_BYTES);
1021 abase = ALIGN (base, BLOCK_ALIGN);
1022 #endif
1023
1024 if (base == 0)
1025 {
1026 MALLOC_UNBLOCK_INPUT;
1027 memory_full ();
1028 }
1029
1030 aligned = (base == abase);
1031 if (!aligned)
1032 ((void**)abase)[-1] = base;
1033
1034 #ifdef DOUG_LEA_MALLOC
1035
1036 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1037 #endif
1038
1039 #ifndef USE_LSB_TAG
1040 1041 1042
1043 if (type != MEM_TYPE_NON_LISP)
1044 {
1045 Lisp_Object tem;
1046 char *end = (char *) base + ABLOCKS_BYTES - 1;
1047 XSETCONS (tem, end);
1048 if ((char *) XCONS (tem) != end)
1049 {
1050 lisp_malloc_loser = base;
1051 free (base);
1052 MALLOC_UNBLOCK_INPUT;
1053 memory_full ();
1054 }
1055 }
1056 #endif
1057
1058 1059
1060 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1061 {
1062 abase->blocks[i].abase = abase;
1063 abase->blocks[i].x.next_free = free_ablock;
1064 free_ablock = &abase->blocks[i];
1065 }
1066 ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
1067
1068 eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
1069 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase);
1070 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1071 eassert (ABLOCKS_BASE (abase) == base);
1072 eassert (aligned == (long) ABLOCKS_BUSY (abase));
1073 }
1074
1075 abase = ABLOCK_ABASE (free_ablock);
1076 ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
1077 val = free_ablock;
1078 free_ablock = free_ablock->x.next_free;
1079
1080 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1081 if (val && type != MEM_TYPE_NON_LISP)
1082 mem_insert (val, (char *) val + nbytes, type);
1083 #endif
1084
1085 MALLOC_UNBLOCK_INPUT;
1086 if (!val && nbytes)
1087 memory_full ();
1088
1089 eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
1090 return val;
1091 }
1092
1093 static void
1094 lisp_align_free (block)
1095 POINTER_TYPE *block;
1096 {
1097 struct ablock *ablock = block;
1098 struct ablocks *abase = ABLOCK_ABASE (ablock);
1099
1100 MALLOC_BLOCK_INPUT;
1101 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1102 mem_delete (mem_find (block));
1103 #endif
1104
1105 ablock->x.next_free = free_ablock;
1106 free_ablock = ablock;
1107
1108 ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
1109
1110 if (2 > (long) ABLOCKS_BUSY (abase))
1111 {
1112 int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
1113 struct ablock **tem = &free_ablock;
1114 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1115
1116 while (*tem)
1117 {
1118 if (*tem >= (struct ablock *) abase && *tem < atop)
1119 {
1120 i++;
1121 *tem = (*tem)->x.next_free;
1122 }
1123 else
1124 tem = &(*tem)->x.next_free;
1125 }
1126 eassert ((aligned & 1) == aligned);
1127 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1128 #ifdef USE_POSIX_MEMALIGN
1129 eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1130 #endif
1131 free (ABLOCKS_BASE (abase));
1132 }
1133 MALLOC_UNBLOCK_INPUT;
1134 }
1135
1136 1137
1138
1139 struct buffer *
1140 allocate_buffer ()
1141 {
1142 struct buffer *b
1143 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1144 MEM_TYPE_BUFFER);
1145 b->size = sizeof (struct buffer) / sizeof (EMACS_INT);
1146 XSETPVECTYPE (b, PVEC_BUFFER);
1147 return b;
1148 }
1149
1150
1151 #ifndef SYSTEM_MALLOC
1152
1153 1154 1155 1156 1157 1158 1159 1160 1161
1162
1163 #ifndef SYNC_INPUT
1164 1165
1166
1167 #ifndef DOUG_LEA_MALLOC
1168 extern void * (*__malloc_hook) P_ ((size_t, const void *));
1169 extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
1170 extern void (*__free_hook) P_ ((void *, const void *));
1171
1172 #endif
1173 static void * (*old_malloc_hook) P_ ((size_t, const void *));
1174 static void * (*old_realloc_hook) P_ ((void *, size_t, const void*));
1175 static void (*old_free_hook) P_ ((void*, const void*));
1176
1177
1178
1179 static void
1180 emacs_blocked_free (ptr, ptr2)
1181 void *ptr;
1182 const void *ptr2;
1183 {
1184 BLOCK_INPUT_ALLOC;
1185
1186 #ifdef GC_MALLOC_CHECK
1187 if (ptr)
1188 {
1189 struct mem_node *m;
1190
1191 m = mem_find (ptr);
1192 if (m == MEM_NIL || m->start != ptr)
1193 {
1194 fprintf (stderr,
1195 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1196 abort ();
1197 }
1198 else
1199 {
1200
1201 mem_delete (m);
1202 }
1203 }
1204 #endif
1205
1206 __free_hook = old_free_hook;
1207 free (ptr);
1208
1209 1210 1211
1212 if (! NILP (Vmemory_full)
1213 1214 1215 1216
1217 && (bytes_used_when_full
1218 > ((bytes_used_when_reconsidered = BYTES_USED)
1219 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1220 refill_memory_reserve ();
1221
1222 __free_hook = emacs_blocked_free;
1223 UNBLOCK_INPUT_ALLOC;
1224 }
1225
1226
1227
1228
1229 static void *
1230 emacs_blocked_malloc (size, ptr)
1231 size_t size;
1232 const void *ptr;
1233 {
1234 void *value;
1235
1236 BLOCK_INPUT_ALLOC;
1237 __malloc_hook = old_malloc_hook;
1238 #ifdef DOUG_LEA_MALLOC
1239
1240
1241 #else
1242 __malloc_extra_blocks = malloc_hysteresis;
1243 #endif
1244
1245 value = (void *) malloc (size);
1246
1247 #ifdef GC_MALLOC_CHECK
1248 {
1249 struct mem_node *m = mem_find (value);
1250 if (m != MEM_NIL)
1251 {
1252 fprintf (stderr, "Malloc returned %p which is already in use\n",
1253 value);
1254 fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
1255 m->start, m->end, (char *) m->end - (char *) m->start,
1256 m->type);
1257 abort ();
1258 }
1259
1260 if (!dont_register_blocks)
1261 {
1262 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1263 allocated_mem_type = MEM_TYPE_NON_LISP;
1264 }
1265 }
1266 #endif
1267
1268 __malloc_hook = emacs_blocked_malloc;
1269 UNBLOCK_INPUT_ALLOC;
1270
1271
1272 return value;
1273 }
1274
1275
1276
1277
1278 static void *
1279 emacs_blocked_realloc (ptr, size, ptr2)
1280 void *ptr;
1281 size_t size;
1282 const void *ptr2;
1283 {
1284 void *value;
1285
1286 BLOCK_INPUT_ALLOC;
1287 __realloc_hook = old_realloc_hook;
1288
1289 #ifdef GC_MALLOC_CHECK
1290 if (ptr)
1291 {
1292 struct mem_node *m = mem_find (ptr);
1293 if (m == MEM_NIL || m->start != ptr)
1294 {
1295 fprintf (stderr,
1296 "Realloc of %p which wasn't allocated with malloc\n",
1297 ptr);
1298 abort ();
1299 }
1300
1301 mem_delete (m);
1302 }
1303
1304
1305
1306
1307 dont_register_blocks = 1;
1308 #endif
1309
1310 value = (void *) realloc (ptr, size);
1311
1312 #ifdef GC_MALLOC_CHECK
1313 dont_register_blocks = 0;
1314
1315 {
1316 struct mem_node *m = mem_find (value);
1317 if (m != MEM_NIL)
1318 {
1319 fprintf (stderr, "Realloc returns memory that is already in use\n");
1320 abort ();
1321 }
1322
1323
1324 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1325 }
1326
1327
1328 #endif
1329
1330 __realloc_hook = emacs_blocked_realloc;
1331 UNBLOCK_INPUT_ALLOC;
1332
1333 return value;
1334 }
1335
1336
1337 #ifdef HAVE_GTK_AND_PTHREAD
1338 1339 1340 1341
1342
1343 void
1344 reset_malloc_hooks ()
1345 {
1346 __free_hook = old_free_hook;
1347 __malloc_hook = old_malloc_hook;
1348 __realloc_hook = old_realloc_hook;
1349 }
1350 #endif
1351
1352
1353
1354
1355 void
1356 uninterrupt_malloc ()
1357 {
1358 #ifdef HAVE_GTK_AND_PTHREAD
1359 #ifdef DOUG_LEA_MALLOC
1360 pthread_mutexattr_t attr;
1361
1362 1363
1364 pthread_mutexattr_init (&attr);
1365 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1366 pthread_mutex_init (&alloc_mutex, &attr);
1367 #else
1368 1369
1370 pthread_mutex_init (&alloc_mutex, NULL);
1371 #endif
1372 #endif
1373
1374 if (__free_hook != emacs_blocked_free)
1375 old_free_hook = __free_hook;
1376 __free_hook = emacs_blocked_free;
1377
1378 if (__malloc_hook != emacs_blocked_malloc)
1379 old_malloc_hook = __malloc_hook;
1380 __malloc_hook = emacs_blocked_malloc;
1381
1382 if (__realloc_hook != emacs_blocked_realloc)
1383 old_realloc_hook = __realloc_hook;
1384 __realloc_hook = emacs_blocked_realloc;
1385 }
1386
1387 #endif
1388 #endif
1389
1390
1391
1392 1393 1394
1395
1396 1397
1398
1399 #define INTERVAL_BLOCK_SIZE \
1400 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1401
1402 1403
1404
1405 struct interval_block
1406 {
1407
1408 struct interval intervals[INTERVAL_BLOCK_SIZE];
1409 struct interval_block *next;
1410 };
1411
1412 1413
1414
1415 static struct interval_block *interval_block;
1416
1417 1418
1419
1420 static int interval_block_index;
1421
1422
1423
1424 static int total_free_intervals, total_intervals;
1425
1426
1427
1428 INTERVAL interval_free_list;
1429
1430
1431
1432 static int n_interval_blocks;
1433
1434
1435
1436
1437 static void
1438 init_intervals ()
1439 {
1440 interval_block = NULL;
1441 interval_block_index = INTERVAL_BLOCK_SIZE;
1442 interval_free_list = 0;
1443 n_interval_blocks = 0;
1444 }
1445
1446
1447
1448
1449 INTERVAL
1450 make_interval ()
1451 {
1452 INTERVAL val;
1453
1454
1455
1456 MALLOC_BLOCK_INPUT;
1457
1458 if (interval_free_list)
1459 {
1460 val = interval_free_list;
1461 interval_free_list = INTERVAL_PARENT (interval_free_list);
1462 }
1463 else
1464 {
1465 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1466 {
1467 register struct interval_block *newi;
1468
1469 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1470 MEM_TYPE_NON_LISP);
1471
1472 newi->next = interval_block;
1473 interval_block = newi;
1474 interval_block_index = 0;
1475 n_interval_blocks++;
1476 }
1477 val = &interval_block->intervals[interval_block_index++];
1478 }
1479
1480 MALLOC_UNBLOCK_INPUT;
1481
1482 consing_since_gc += sizeof (struct interval);
1483 intervals_consed++;
1484 RESET_INTERVAL (val);
1485 val->gcmarkbit = 0;
1486 return val;
1487 }
1488
1489
1490
1491
1492 static void
1493 mark_interval (i, dummy)
1494 register INTERVAL i;
1495 Lisp_Object dummy;
1496 {
1497 eassert (!i->gcmarkbit);
1498 i->gcmarkbit = 1;
1499 mark_object (i->plist);
1500 }
1501
1502
1503 1504
1505
1506 static void
1507 mark_interval_tree (tree)
1508 register INTERVAL tree;
1509 {
1510 1511 1512
1513
1514 traverse_intervals_noorder (tree, mark_interval, Qnil);
1515 }
1516
1517
1518
1519
1520 #define MARK_INTERVAL_TREE(i) \
1521 do { \
1522 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1523 mark_interval_tree (i); \
1524 } while (0)
1525
1526
1527 #define UNMARK_BALANCE_INTERVALS(i) \
1528 do { \
1529 if (! NULL_INTERVAL_P (i)) \
1530 (i) = balance_intervals (i); \
1531 } while (0)
1532
1533
1534 1535
1536 #ifndef make_number
1537 Lisp_Object
1538 make_number (n)
1539 EMACS_INT n;
1540 {
1541 Lisp_Object obj;
1542 obj.s.val = n;
1543 obj.s.type = Lisp_Int;
1544 return obj;
1545 }
1546 #endif
1547
1548 1549 1550
1551
1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573
1574
1575 1576
1577
1578 #define SBLOCK_SIZE 8188
1579
1580 1581
1582
1583 #define LARGE_STRING_BYTES 1024
1584
1585 1586
1587
1588 struct sdata
1589 {
1590 1591 1592 1593 1594 1595
1596 struct Lisp_String *string;
1597
1598 #ifdef GC_CHECK_STRING_BYTES
1599
1600 EMACS_INT nbytes;
1601 unsigned char data[1];
1602
1603 #define SDATA_NBYTES(S) (S)->nbytes
1604 #define SDATA_DATA(S) (S)->data
1605
1606 #else
1607
1608 union
1609 {
1610
1611 unsigned char data[1];
1612
1613
1614 EMACS_INT nbytes;
1615 } u;
1616
1617
1618 #define SDATA_NBYTES(S) (S)->u.nbytes
1619 #define SDATA_DATA(S) (S)->u.data
1620
1621 #endif
1622 };
1623
1624
1625 1626 1627 1628
1629
1630 struct sblock
1631 {
1632
1633 struct sblock *next;
1634
1635 1636
1637 struct sdata *next_free;
1638
1639
1640 struct sdata first_data;
1641 };
1642
1643 1644
1645
1646 #define STRING_BLOCK_SIZE \
1647 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1648
1649 1650
1651
1652 struct string_block
1653 {
1654
1655 struct Lisp_String strings[STRING_BLOCK_SIZE];
1656 struct string_block *next;
1657 };
1658
1659 1660 1661
1662
1663 static struct sblock *oldest_sblock, *current_sblock;
1664
1665
1666
1667 static struct sblock *large_sblocks;
1668
1669
1670
1671 static struct string_block *string_blocks;
1672 static int n_string_blocks;
1673
1674
1675
1676 static struct Lisp_String *string_free_list;
1677
1678
1679
1680 static int total_strings, total_free_strings;
1681
1682
1683
1684 static int total_string_size;
1685
1686 1687 1688
1689
1690 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1691
1692 1693 1694 1695
1696
1697 #ifdef GC_CHECK_STRING_BYTES
1698
1699 #define SDATA_OF_STRING(S) \
1700 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1701 - sizeof (EMACS_INT)))
1702
1703 #else
1704
1705 #define SDATA_OF_STRING(S) \
1706 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1707
1708 #endif
1709
1710
1711 #ifdef GC_CHECK_STRING_OVERRUN
1712
1713 1714 1715
1716
1717 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1718 static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1719 { 0xde, 0xad, 0xbe, 0xef };
1720
1721 #else
1722 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1723 #endif
1724
1725 1726 1727
1728
1729 #ifdef GC_CHECK_STRING_BYTES
1730
1731 #define SDATA_SIZE(NBYTES) \
1732 ((sizeof (struct Lisp_String *) \
1733 + (NBYTES) + 1 \
1734 + sizeof (EMACS_INT) \
1735 + sizeof (EMACS_INT) - 1) \
1736 & ~(sizeof (EMACS_INT) - 1))
1737
1738 #else
1739
1740 #define SDATA_SIZE(NBYTES) \
1741 ((sizeof (struct Lisp_String *) \
1742 + (NBYTES) + 1 \
1743 + sizeof (EMACS_INT) - 1) \
1744 & ~(sizeof (EMACS_INT) - 1))
1745
1746 #endif
1747
1748
1749
1750 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1751
1752
1753
1754 static void
1755 init_strings ()
1756 {
1757 total_strings = total_free_strings = total_string_size = 0;
1758 oldest_sblock = current_sblock = large_sblocks = NULL;
1759 string_blocks = NULL;
1760 n_string_blocks = 0;
1761 string_free_list = NULL;
1762 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1763 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1764 }
1765
1766
1767 #ifdef GC_CHECK_STRING_BYTES
1768
1769 static int check_string_bytes_count;
1770
1771 static void check_string_bytes P_ ((int));
1772 static void check_sblock P_ ((struct sblock *));
1773
1774 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1775
1776
1777
1778
1779 int
1780 string_bytes (s)
1781 struct Lisp_String *s;
1782 {
1783 int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1784 if (!PURE_POINTER_P (s)
1785 && s->data
1786 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1787 abort ();
1788 return nbytes;
1789 }
1790
1791
1792
1793 static void
1794 check_sblock (b)
1795 struct sblock *b;
1796 {
1797 struct sdata *from, *end, *from_end;
1798
1799 end = b->next_free;
1800
1801 for (from = &b->first_data; from < end; from = from_end)
1802 {
1803 1804
1805 int nbytes;
1806
1807 1808
1809 if (from->string)
1810 CHECK_STRING_BYTES (from->string);
1811
1812 if (from->string)
1813 nbytes = GC_STRING_BYTES (from->string);
1814 else
1815 nbytes = SDATA_NBYTES (from);
1816
1817 nbytes = SDATA_SIZE (nbytes);
1818 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1819 }
1820 }
1821
1822
1823 1824 1825
1826
1827 static void
1828 check_string_bytes (all_p)
1829 int all_p;
1830 {
1831 if (all_p)
1832 {
1833 struct sblock *b;
1834
1835 for (b = large_sblocks; b; b = b->next)
1836 {
1837 struct Lisp_String *s = b->first_data.string;
1838 if (s)
1839 CHECK_STRING_BYTES (s);
1840 }
1841
1842 for (b = oldest_sblock; b; b = b->next)
1843 check_sblock (b);
1844 }
1845 else
1846 check_sblock (current_sblock);
1847 }
1848
1849 #endif
1850
1851 #ifdef GC_CHECK_STRING_FREE_LIST
1852
1853 1854
1855
1856 static void
1857 check_string_free_list ()
1858 {
1859 struct Lisp_String *s;
1860
1861
1862 s = string_free_list;
1863 while (s != NULL)
1864 {
1865 if ((unsigned)s < 1024)
1866 abort();
1867 s = NEXT_FREE_LISP_STRING (s);
1868 }
1869 }
1870 #else
1871 #define check_string_free_list()
1872 #endif
1873
1874
1875
1876 static struct Lisp_String *
1877 allocate_string ()
1878 {
1879 struct Lisp_String *s;
1880
1881
1882
1883 MALLOC_BLOCK_INPUT;
1884
1885 1886
1887 if (string_free_list == NULL)
1888 {
1889 struct string_block *b;
1890 int i;
1891
1892 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1893 bzero (b, sizeof *b);
1894 b->next = string_blocks;
1895 string_blocks = b;
1896 ++n_string_blocks;
1897
1898 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1899 {
1900 s = b->strings + i;
1901 NEXT_FREE_LISP_STRING (s) = string_free_list;
1902 string_free_list = s;
1903 }
1904
1905 total_free_strings += STRING_BLOCK_SIZE;
1906 }
1907
1908 check_string_free_list ();
1909
1910
1911 s = string_free_list;
1912 string_free_list = NEXT_FREE_LISP_STRING (s);
1913
1914 MALLOC_UNBLOCK_INPUT;
1915
1916
1917 bzero (s, sizeof *s);
1918
1919 --total_free_strings;
1920 ++total_strings;
1921 ++strings_consed;
1922 consing_since_gc += sizeof *s;
1923
1924 #ifdef GC_CHECK_STRING_BYTES
1925 if (!noninteractive)
1926 {
1927 if (++check_string_bytes_count == 200)
1928 {
1929 check_string_bytes_count = 0;
1930 check_string_bytes (1);
1931 }
1932 else
1933 check_string_bytes (0);
1934 }
1935 #endif
1936
1937 return s;
1938 }
1939
1940
1941 1942 1943 1944 1945
1946
1947 void
1948 allocate_string_data (s, nchars, nbytes)
1949 struct Lisp_String *s;
1950 int nchars, nbytes;
1951 {
1952 struct sdata *data, *old_data;
1953 struct sblock *b;
1954 int needed, old_nbytes;
1955
1956 1957
1958 needed = SDATA_SIZE (nbytes);
1959 old_data = s->data ? SDATA_OF_STRING (s) : NULL;
1960 old_nbytes = GC_STRING_BYTES (s);
1961
1962 MALLOC_BLOCK_INPUT;
1963
1964 if (nbytes > LARGE_STRING_BYTES)
1965 {
1966 size_t size = sizeof *b - sizeof (struct sdata) + needed;
1967
1968 #ifdef DOUG_LEA_MALLOC
1969 1970 1971 1972 1973 1974 1975 1976 1977
1978 mallopt (M_MMAP_MAX, 0);
1979 #endif
1980
1981 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
1982
1983 #ifdef DOUG_LEA_MALLOC
1984
1985 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1986 #endif
1987
1988 b->next_free = &b->first_data;
1989 b->first_data.string = NULL;
1990 b->next = large_sblocks;
1991 large_sblocks = b;
1992 }
1993 else if (current_sblock == NULL
1994 || (((char *) current_sblock + SBLOCK_SIZE
1995 - (char *) current_sblock->next_free)
1996 < (needed + GC_STRING_EXTRA)))
1997 {
1998
1999 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2000 b->next_free = &b->first_data;
2001 b->first_data.string = NULL;
2002 b->next = NULL;
2003
2004 if (current_sblock)
2005 current_sblock->next = b;
2006 else
2007 oldest_sblock = b;
2008 current_sblock = b;
2009 }
2010 else
2011 b = current_sblock;
2012
2013 data = b->next_free;
2014 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2015
2016 MALLOC_UNBLOCK_INPUT;
2017
2018 data->string = s;
2019 s->data = SDATA_DATA (data);
2020 #ifdef GC_CHECK_STRING_BYTES
2021 SDATA_NBYTES (data) = nbytes;
2022 #endif
2023 s->size = nchars;
2024 s->size_byte = nbytes;
2025 s->data[nbytes] = '\0';
2026 #ifdef GC_CHECK_STRING_OVERRUN
2027 bcopy (string_overrun_cookie, (char *) data + needed,
2028 GC_STRING_OVERRUN_COOKIE_SIZE);
2029 #endif
2030
2031 2032 2033
2034 if (old_data)
2035 {
2036 SDATA_NBYTES (old_data) = old_nbytes;
2037 old_data->string = NULL;
2038 }
2039
2040 consing_since_gc += needed;
2041 }
2042
2043
2044
2045
2046 static void
2047 sweep_strings ()
2048 {
2049 struct string_block *b, *next;
2050 struct string_block *live_blocks = NULL;
2051
2052 string_free_list = NULL;
2053 total_strings = total_free_strings = 0;
2054 total_string_size = 0;
2055
2056
2057 for (b = string_blocks; b; b = next)
2058 {
2059 int i, nfree = 0;
2060 struct Lisp_String *free_list_before = string_free_list;
2061
2062 next = b->next;
2063
2064 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
2065 {
2066 struct Lisp_String *s = b->strings + i;
2067
2068 if (s->data)
2069 {
2070
2071 if (STRING_MARKED_P (s))
2072 {
2073
2074 UNMARK_STRING (s);
2075
2076 if (!NULL_INTERVAL_P (s->intervals))
2077 UNMARK_BALANCE_INTERVALS (s->intervals);
2078
2079 ++total_strings;
2080 total_string_size += STRING_BYTES (s);
2081 }
2082 else
2083 {
2084
2085 struct sdata *data = SDATA_OF_STRING (s);
2086
2087 2088 2089
2090 #ifdef GC_CHECK_STRING_BYTES
2091 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
2092 abort ();
2093 #else
2094 data->u.nbytes = GC_STRING_BYTES (s);
2095 #endif
2096 data->string = NULL;
2097
2098 2099
2100 s->data = NULL;
2101
2102
2103 NEXT_FREE_LISP_STRING (s) = string_free_list;
2104 string_free_list = s;
2105 ++nfree;
2106 }
2107 }
2108 else
2109 {
2110
2111 NEXT_FREE_LISP_STRING (s) = string_free_list;
2112 string_free_list = s;
2113 ++nfree;
2114 }
2115 }
2116
2117 2118
2119 if (nfree == STRING_BLOCK_SIZE
2120 && total_free_strings > STRING_BLOCK_SIZE)
2121 {
2122 lisp_free (b);
2123 --n_string_blocks;
2124 string_free_list = free_list_before;
2125 }
2126 else
2127 {
2128 total_free_strings += nfree;
2129 b->next = live_blocks;
2130 live_blocks = b;
2131 }
2132 }
2133
2134 check_string_free_list ();
2135
2136 string_blocks = live_blocks;
2137 free_large_strings ();
2138 compact_small_strings ();
2139
2140 check_string_free_list ();
2141 }
2142
2143
2144
2145
2146 static void
2147 free_large_strings ()
2148 {
2149 struct sblock *b, *next;
2150 struct sblock *live_blocks = NULL;
2151
2152 for (b = large_sblocks; b; b = next)
2153 {
2154 next = b->next;
2155
2156 if (b->first_data.string == NULL)
2157 lisp_free (b);
2158 else
2159 {
2160 b->next = live_blocks;
2161 live_blocks = b;
2162 }
2163 }
2164
2165 large_sblocks = live_blocks;
2166 }
2167
2168
2169 2170
2171
2172 static void
2173 compact_small_strings ()
2174 {
2175 struct sblock *b, *tb, *next;
2176 struct sdata *from, *to, *end, *tb_end;
2177 struct sdata *to_end, *from_end;
2178
2179 2180
2181 tb = oldest_sblock;
2182 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2183 to = &tb->first_data;
2184
2185 2186 2187
2188 for (b = oldest_sblock; b; b = b->next)
2189 {
2190 end = b->next_free;
2191 xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2192
2193 for (from = &b->first_data; from < end; from = from_end)
2194 {
2195 2196
2197 int nbytes;
2198
2199 #ifdef GC_CHECK_STRING_BYTES
2200 2201
2202 if (from->string
2203 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
2204 abort ();
2205 #endif
2206
2207 if (from->string)
2208 nbytes = GC_STRING_BYTES (from->string);
2209 else
2210 nbytes = SDATA_NBYTES (from);
2211
2212 if (nbytes > LARGE_STRING_BYTES)
2213 abort ();
2214
2215 nbytes = SDATA_SIZE (nbytes);
2216 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
2217
2218 #ifdef GC_CHECK_STRING_OVERRUN
2219 if (bcmp (string_overrun_cookie,
2220 ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
2221 GC_STRING_OVERRUN_COOKIE_SIZE))
2222 abort ();
2223 #endif
2224
2225
2226 if (from->string)
2227 {
2228
2229 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2230 if (to_end > tb_end)
2231 {
2232 tb->next_free = to;
2233 tb = tb->next;
2234 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2235 to = &tb->first_data;
2236 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2237 }
2238
2239
2240 if (from != to)
2241 {
2242 xassert (tb != b || to <= from);
2243 safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
2244 to->string->data = SDATA_DATA (to);
2245 }
2246
2247
2248 to = to_end;
2249 }
2250 }
2251 }
2252
2253 2254
2255 for (b = tb->next; b; b = next)
2256 {
2257 next = b->next;
2258 lisp_free (b);
2259 }
2260
2261 tb->next_free = to;
2262 tb->next = NULL;
2263 current_sblock = tb;
2264 }
2265
2266
2267 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
2268 doc: 2269 2270 )
2271 (length, init)
2272 Lisp_Object length, init;
2273 {
2274 register Lisp_Object val;
2275 register unsigned char *p, *end;
2276 int c, nbytes;
2277
2278 CHECK_NATNUM (length);
2279 CHECK_NUMBER (init);
2280
2281 c = XINT (init);
2282 if (ASCII_CHAR_P (c))
2283 {
2284 nbytes = XINT (length);
2285 val = make_uninit_string (nbytes);
2286 p = SDATA (val);
2287 end = p + SCHARS (val);
2288 while (p != end)
2289 *p++ = c;
2290 }
2291 else
2292 {
2293 unsigned char str[MAX_MULTIBYTE_LENGTH];
2294 int len = CHAR_STRING (c, str);
2295
2296 nbytes = len * XINT (length);
2297 val = make_uninit_multibyte_string (XINT (length), nbytes);
2298 p = SDATA (val);
2299 end = p + nbytes;
2300 while (p != end)
2301 {
2302 bcopy (str, p, len);
2303 p += len;
2304 }
2305 }
2306
2307 *p = 0;
2308 return val;
2309 }
2310
2311
2312 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2313 doc: 2314 )
2315 (length, init)
2316 Lisp_Object length, init;
2317 {
2318 register Lisp_Object val;
2319 struct Lisp_Bool_Vector *p;
2320 int real_init, i;
2321 int length_in_chars, length_in_elts, bits_per_value;
2322
2323 CHECK_NATNUM (length);
2324
2325 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2326
2327 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2328 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2329 / BOOL_VECTOR_BITS_PER_CHAR);
2330
2331 2332
2333 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2334
2335
2336 XVECTOR (val)->size = 0;
2337
2338 XSETPVECTYPE (XVECTOR (val), PVEC_BOOL_VECTOR);
2339
2340 p = XBOOL_VECTOR (val);
2341 p->size = XFASTINT (length);
2342
2343 real_init = (NILP (init) ? 0 : -1);
2344 for (i = 0; i < length_in_chars ; i++)
2345 p->data[i] = real_init;
2346
2347
2348 if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2349 p->data[length_in_chars - 1]
2350 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2351
2352 return val;
2353 }
2354
2355
2356 2357 2358
2359
2360 Lisp_Object
2361 make_string (contents, nbytes)
2362 const char *contents;
2363 int nbytes;
2364 {
2365 register Lisp_Object val;
2366 int nchars, multibyte_nbytes;
2367
2368 parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
2369 if (nbytes == nchars || nbytes != multibyte_nbytes)
2370 2371
2372 val = make_unibyte_string (contents, nbytes);
2373 else
2374 val = make_multibyte_string (contents, nchars, nbytes);
2375 return val;
2376 }
2377
2378
2379
2380
2381 Lisp_Object
2382 make_unibyte_string (contents, length)
2383 const char *contents;
2384 int length;
2385 {
2386 register Lisp_Object val;
2387 val = make_uninit_string (length);
2388 bcopy (contents, SDATA (val), length);
2389 STRING_SET_UNIBYTE (val);
2390 return val;
2391 }
2392
2393
2394 2395
2396
2397 Lisp_Object
2398 make_multibyte_string (contents, nchars, nbytes)
2399 const char *contents;
2400 int nchars, nbytes;
2401 {
2402 register Lisp_Object val;
2403 val = make_uninit_multibyte_string (nchars, nbytes);
2404 bcopy (contents, SDATA (val), nbytes);
2405 return val;
2406 }
2407
2408
2409 2410
2411
2412 Lisp_Object
2413 make_string_from_bytes (contents, nchars, nbytes)
2414 const char *contents;
2415 int nchars, nbytes;
2416 {
2417 register Lisp_Object val;
2418 val = make_uninit_multibyte_string (nchars, nbytes);
2419 bcopy (contents, SDATA (val), nbytes);
2420 if (SBYTES (val) == SCHARS (val))
2421 STRING_SET_UNIBYTE (val);
2422 return val;
2423 }
2424
2425
2426 2427 2428 2429
2430
2431 Lisp_Object
2432 make_specified_string (contents, nchars, nbytes, multibyte)
2433 const char *contents;
2434 int nchars, nbytes;
2435 int multibyte;
2436 {
2437 register Lisp_Object val;
2438
2439 if (nchars < 0)
2440 {
2441 if (multibyte)
2442 nchars = multibyte_chars_in_text (contents, nbytes);
2443 else
2444 nchars = nbytes;
2445 }
2446 val = make_uninit_multibyte_string (nchars, nbytes);
2447 bcopy (contents, SDATA (val), nbytes);
2448 if (!multibyte)
2449 STRING_SET_UNIBYTE (val);
2450 return val;
2451 }
2452
2453
2454 2455
2456
2457 Lisp_Object
2458 build_string (str)
2459 const char *str;
2460 {
2461 return make_string (str, strlen (str));
2462 }
2463
2464
2465 2466
2467
2468 Lisp_Object
2469 make_uninit_string (length)
2470 int length;
2471 {
2472 Lisp_Object val;
2473
2474 if (!length)
2475 return empty_unibyte_string;
2476 val = make_uninit_multibyte_string (length, length);
2477 STRING_SET_UNIBYTE (val);
2478 return val;
2479 }
2480
2481
2482 2483
2484
2485 Lisp_Object
2486 make_uninit_multibyte_string (nchars, nbytes)
2487 int nchars, nbytes;
2488 {
2489 Lisp_Object string;
2490 struct Lisp_String *s;
2491
2492 if (nchars < 0)
2493 abort ();
2494 if (!nbytes)
2495 return empty_multibyte_string;
2496
2497 s = allocate_string ();
2498 allocate_string_data (s, nchars, nbytes);
2499 XSETSTRING (string, s);
2500 string_chars_consed += nbytes;
2501 return string;
2502 }
2503
2504
2505
2506 2507 2508
2509
2510 2511 2512 2513
2514
2515 #define FLOAT_BLOCK_SIZE \
2516 (((BLOCK_BYTES - sizeof (struct float_block *) \
2517 \
2518 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2519 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2520
2521 #define GETMARKBIT(block,n) \
2522 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2523 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2524 & 1)
2525
2526 #define SETMARKBIT(block,n) \
2527 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2528 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2529
2530 #define UNSETMARKBIT(block,n) \
2531 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2532 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2533
2534 #define FLOAT_BLOCK(fptr) \
2535 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2536
2537 #define FLOAT_INDEX(fptr) \
2538 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2539
2540 struct float_block
2541 {
2542
2543 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2544 int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2545 struct float_block *next;
2546 };
2547
2548 #define FLOAT_MARKED_P(fptr) \
2549 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2550
2551 #define FLOAT_MARK(fptr) \
2552 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2553
2554 #define FLOAT_UNMARK(fptr) \
2555 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2556
2557
2558
2559 struct float_block *float_block;
2560
2561
2562
2563 int float_block_index;
2564
2565
2566
2567 int n_float_blocks;
2568
2569
2570
2571 struct Lisp_Float *float_free_list;
2572
2573
2574
2575
2576 static void
2577 init_float ()
2578 {
2579 float_block = NULL;
2580 float_block_index = FLOAT_BLOCK_SIZE;
2581 float_free_list = 0;
2582 n_float_blocks = 0;
2583 }
2584
2585
2586
2587
2588 static void
2589 free_float (ptr)
2590 struct Lisp_Float *ptr;
2591 {
2592 ptr->u.chain = float_free_list;
2593 float_free_list = ptr;
2594 }
2595
2596
2597
2598
2599 Lisp_Object
2600 make_float (float_value)
2601 double float_value;
2602 {
2603 register Lisp_Object val;
2604
2605
2606
2607 MALLOC_BLOCK_INPUT;
2608
2609 if (float_free_list)
2610 {
2611 2612
2613 XSETFLOAT (val, float_free_list);
2614 float_free_list = float_free_list->u.chain;
2615 }
2616 else
2617 {
2618 if (float_block_index == FLOAT_BLOCK_SIZE)
2619 {
2620 register struct float_block *new;
2621
2622 new = (struct float_block *) lisp_align_malloc (sizeof *new,
2623 MEM_TYPE_FLOAT);
2624 new->next = float_block;
2625 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2626 float_block = new;
2627 float_block_index = 0;
2628 n_float_blocks++;
2629 }
2630 XSETFLOAT (val, &float_block->floats[float_block_index]);
2631 float_block_index++;
2632 }
2633
2634 MALLOC_UNBLOCK_INPUT;
2635
2636 XFLOAT_INIT (val, float_value);
2637 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2638 consing_since_gc += sizeof (struct Lisp_Float);
2639 floats_consed++;
2640 return val;
2641 }
2642
2643
2644
2645 2646 2647
2648
2649 2650 2651 2652
2653
2654 #define CONS_BLOCK_SIZE \
2655 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2656 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2657
2658 #define CONS_BLOCK(fptr) \
2659 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2660
2661 #define CONS_INDEX(fptr) \
2662 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2663
2664 struct cons_block
2665 {
2666
2667 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2668 int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2669 struct cons_block *next;
2670 };
2671
2672 #define CONS_MARKED_P(fptr) \
2673 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2674
2675 #define CONS_MARK(fptr) \
2676 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2677
2678 #define CONS_UNMARK(fptr) \
2679 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2680
2681
2682
2683 struct cons_block *cons_block;
2684
2685
2686
2687 int cons_block_index;
2688
2689
2690
2691 struct Lisp_Cons *cons_free_list;
2692
2693
2694
2695 static int n_cons_blocks;
2696
2697
2698
2699
2700 static void
2701 init_cons ()
2702 {
2703 cons_block = NULL;
2704 cons_block_index = CONS_BLOCK_SIZE;
2705 cons_free_list = 0;
2706 n_cons_blocks = 0;
2707 }
2708
2709
2710
2711
2712 void
2713 free_cons (ptr)
2714 struct Lisp_Cons *ptr;
2715 {
2716 ptr->u.chain = cons_free_list;
2717 #if GC_MARK_STACK
2718 ptr->car = Vdead;
2719 #endif
2720 cons_free_list = ptr;
2721 }
2722
2723 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2724 doc: )
2725 (car, cdr)
2726 Lisp_Object car, cdr;
2727 {
2728 register Lisp_Object val;
2729
2730
2731
2732 MALLOC_BLOCK_INPUT;
2733
2734 if (cons_free_list)
2735 {
2736 2737
2738 XSETCONS (val, cons_free_list);
2739 cons_free_list = cons_free_list->u.chain;
2740 }
2741 else
2742 {
2743 if (cons_block_index == CONS_BLOCK_SIZE)
2744 {
2745 register struct cons_block *new;
2746 new = (struct cons_block *) lisp_align_malloc (sizeof *new,
2747 MEM_TYPE_CONS);
2748 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2749 new->next = cons_block;
2750 cons_block = new;
2751 cons_block_index = 0;
2752 n_cons_blocks++;
2753 }
2754 XSETCONS (val, &cons_block->conses[cons_block_index]);
2755 cons_block_index++;
2756 }
2757
2758 MALLOC_UNBLOCK_INPUT;
2759
2760 XSETCAR (val, car);
2761 XSETCDR (val, cdr);
2762 eassert (!CONS_MARKED_P (XCONS (val)));
2763 consing_since_gc += sizeof (struct Lisp_Cons);
2764 cons_cells_consed++;
2765 return val;
2766 }
2767
2768
2769 void
2770 check_cons_list ()
2771 {
2772 #ifdef GC_CHECK_CONS_LIST
2773 struct Lisp_Cons *tail = cons_free_list;
2774
2775 while (tail)
2776 tail = tail->u.chain;
2777 #endif
2778 }
2779
2780
2781
2782 Lisp_Object
2783 list1 (arg1)
2784 Lisp_Object arg1;
2785 {
2786 return Fcons (arg1, Qnil);
2787 }
2788
2789 Lisp_Object
2790 list2 (arg1, arg2)
2791 Lisp_Object arg1, arg2;
2792 {
2793 return Fcons (arg1, Fcons (arg2, Qnil));
2794 }
2795
2796
2797 Lisp_Object
2798 list3 (arg1, arg2, arg3)
2799 Lisp_Object arg1, arg2, arg3;
2800 {
2801 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2802 }
2803
2804
2805 Lisp_Object
2806 list4 (arg1, arg2, arg3, arg4)
2807 Lisp_Object arg1, arg2, arg3, arg4;
2808 {
2809 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2810 }
2811
2812
2813 Lisp_Object
2814 list5 (arg1, arg2, arg3, arg4, arg5)
2815 Lisp_Object arg1, arg2, arg3, arg4, arg5;
2816 {
2817 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2818 Fcons (arg5, Qnil)))));
2819 }
2820
2821
2822 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2823 doc: 2824 2825 )
2826 (nargs, args)
2827 int nargs;
2828 register Lisp_Object *args;
2829 {
2830 register Lisp_Object val;
2831 val = Qnil;
2832
2833 while (nargs > 0)
2834 {
2835 nargs--;
2836 val = Fcons (args[nargs], val);
2837 }
2838 return val;
2839 }
2840
2841
2842 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2843 doc: )
2844 (length, init)
2845 register Lisp_Object length, init;
2846 {
2847 register Lisp_Object val;
2848 register int size;
2849
2850 CHECK_NATNUM (length);
2851 size = XFASTINT (length);
2852
2853 val = Qnil;
2854 while (size > 0)
2855 {
2856 val = Fcons (init, val);
2857 --size;
2858
2859 if (size > 0)
2860 {
2861 val = Fcons (init, val);
2862 --size;
2863
2864 if (size > 0)
2865 {
2866 val = Fcons (init, val);
2867 --size;
2868
2869 if (size > 0)
2870 {
2871 val = Fcons (init, val);
2872 --size;
2873
2874 if (size > 0)
2875 {
2876 val = Fcons (init, val);
2877 --size;
2878 }
2879 }
2880 }
2881 }
2882
2883 QUIT;
2884 }
2885
2886 return val;
2887 }
2888
2889
2890
2891 2892 2893
2894
2895
2896
2897 static struct Lisp_Vector *all_vectors;
2898
2899
2900
2901 static int n_vectors;
2902
2903
2904 2905
2906
2907 static struct Lisp_Vector *
2908 allocate_vectorlike (len)
2909 EMACS_INT len;
2910 {
2911 struct Lisp_Vector *p;
2912 size_t nbytes;
2913
2914 MALLOC_BLOCK_INPUT;
2915
2916 #ifdef DOUG_LEA_MALLOC
2917 2918 2919
2920 mallopt (M_MMAP_MAX, 0);
2921 #endif
2922
2923
2924
2925
2926 nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
2927 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
2928
2929 #ifdef DOUG_LEA_MALLOC
2930
2931 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2932 #endif
2933
2934 consing_since_gc += nbytes;
2935 vector_cells_consed += len;
2936
2937 p->next = all_vectors;
2938 all_vectors = p;
2939
2940 MALLOC_UNBLOCK_INPUT;
2941
2942 ++n_vectors;
2943 return p;
2944 }
2945
2946
2947
2948
2949 struct Lisp_Vector *
2950 allocate_vector (nslots)
2951 EMACS_INT nslots;
2952 {
2953 struct Lisp_Vector *v = allocate_vectorlike (nslots);
2954 v->size = nslots;
2955 return v;
2956 }
2957
2958
2959
2960
2961 struct Lisp_Vector *
2962 allocate_pseudovector (memlen, lisplen, tag)
2963 int memlen, lisplen;
2964 EMACS_INT tag;
2965 {
2966 struct Lisp_Vector *v = allocate_vectorlike (memlen);
2967 EMACS_INT i;
2968
2969
2970 v->size = lisplen;
2971 for (i = 0; i < lisplen; ++i)
2972 v->contents[i] = Qnil;
2973
2974 XSETPVECTYPE (v, tag);
2975 return v;
2976 }
2977
2978 struct Lisp_Hash_Table *
2979 allocate_hash_table (void)
2980 {
2981 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
2982 }
2983
2984
2985 struct window *
2986 allocate_window ()
2987 {
2988 return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
2989 }
2990
2991
2992 struct terminal *
2993 allocate_terminal ()
2994 {
2995 struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
2996 next_terminal, PVEC_TERMINAL);
2997
2998 bzero (&(t->next_terminal),
2999 ((char*)(t+1)) - ((char*)&(t->next_terminal)));
3000
3001 return t;
3002 }
3003
3004 struct frame *
3005 allocate_frame ()
3006 {
3007 struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
3008 face_cache, PVEC_FRAME);
3009
3010 bzero (&(f->face_cache),
3011 ((char*)(f+1)) - ((char*)&(f->face_cache)));
3012 return f;
3013 }
3014
3015
3016 struct Lisp_Process *
3017 allocate_process ()
3018 {
3019 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3020 }
3021
3022
3023 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3024 doc: 3025 )
3026 (length, init)
3027 register Lisp_Object length, init;
3028 {
3029 Lisp_Object vector;
3030 register EMACS_INT sizei;
3031 register int index;
3032 register struct Lisp_Vector *p;
3033
3034 CHECK_NATNUM (length);
3035 sizei = XFASTINT (length);
3036
3037 p = allocate_vector (sizei);
3038 for (index = 0; index < sizei; index++)
3039 p->contents[index] = init;
3040
3041 XSETVECTOR (vector, p);
3042 return vector;
3043 }
3044
3045
3046 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3047 doc: 3048 3049 )
3050 (nargs, args)
3051 register int nargs;
3052 Lisp_Object *args;
3053 {
3054 register Lisp_Object len, val;
3055 register int index;
3056 register struct Lisp_Vector *p;
3057
3058 XSETFASTINT (len, nargs);
3059 val = Fmake_vector (len, Qnil);
3060 p = XVECTOR (val);
3061 for (index = 0; index < nargs; index++)
3062 p->contents[index] = args[index];
3063 return val;
3064 }
3065
3066
3067 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3068 doc: 3069 3070 3071 3072 3073 )
3074 (nargs, args)
3075 register int nargs;
3076 Lisp_Object *args;
3077 {
3078 register Lisp_Object len, val;
3079 register int index;
3080 register struct Lisp_Vector *p;
3081
3082 XSETFASTINT (len, nargs);
3083 if (!NILP (Vpurify_flag))
3084 val = make_pure_vector ((EMACS_INT) nargs);
3085 else
3086 val = Fmake_vector (len, Qnil);
3087
3088 if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
3089 3090 3091 3092 3093
3094 args[1] = Fstring_as_unibyte (args[1]);
3095
3096 p = XVECTOR (val);
3097 for (index = 0; index < nargs; index++)
3098 {
3099 if (!NILP (Vpurify_flag))
3100 args[index] = Fpurecopy (args[index]);
3101 p->contents[index] = args[index];
3102 }
3103 XSETPVECTYPE (p, PVEC_COMPILED);
3104 XSETCOMPILED (val, p);
3105 return val;
3106 }
3107
3108
3109
3110 3111 3112
3113
3114 3115 3116
3117
3118 #define SYMBOL_BLOCK_SIZE \
3119 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3120
3121 struct symbol_block
3122 {
3123
3124 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3125 struct symbol_block *next;
3126 };
3127
3128 3129
3130
3131 static struct symbol_block *symbol_block;
3132 static int symbol_block_index;
3133
3134
3135
3136 static struct Lisp_Symbol *symbol_free_list;
3137
3138
3139
3140 static int n_symbol_blocks;
3141
3142
3143
3144
3145 static void
3146 init_symbol ()
3147 {
3148 symbol_block = NULL;
3149 symbol_block_index = SYMBOL_BLOCK_SIZE;
3150 symbol_free_list = 0;
3151 n_symbol_blocks = 0;
3152 }
3153
3154
3155 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3156 doc: 3157 )
3158 (name)
3159 Lisp_Object name;
3160 {
3161 register Lisp_Object val;
3162 register struct Lisp_Symbol *p;
3163
3164 CHECK_STRING (name);
3165
3166
3167
3168 MALLOC_BLOCK_INPUT;
3169
3170 if (symbol_free_list)
3171 {
3172 XSETSYMBOL (val, symbol_free_list);
3173 symbol_free_list = symbol_free_list->next;
3174 }
3175 else
3176 {
3177 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3178 {
3179 struct symbol_block *new;
3180 new = (struct symbol_block *) lisp_malloc (sizeof *new,
3181 MEM_TYPE_SYMBOL);
3182 new->next = symbol_block;
3183 symbol_block = new;
3184 symbol_block_index = 0;
3185 n_symbol_blocks++;
3186 }
3187 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
3188 symbol_block_index++;
3189 }
3190
3191 MALLOC_UNBLOCK_INPUT;
3192
3193 p = XSYMBOL (val);
3194 p->xname = name;
3195 p->plist = Qnil;
3196 p->redirect = SYMBOL_PLAINVAL;
3197 SET_SYMBOL_VAL (p, Qunbound);
3198 p->function = Qunbound;
3199 p->next = NULL;
3200 p->gcmarkbit = 0;
3201 p->interned = SYMBOL_UNINTERNED;
3202 p->constant = 0;
3203 consing_since_gc += sizeof (struct Lisp_Symbol);
3204 symbols_consed++;
3205 return val;
3206 }
3207
3208
3209
3210 3211 3212
3213
3214 3215
3216
3217 #define MARKER_BLOCK_SIZE \
3218 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3219
3220 struct marker_block
3221 {
3222
3223 union Lisp_Misc markers[MARKER_BLOCK_SIZE];
3224 struct marker_block *next;
3225 };
3226
3227 static struct marker_block *marker_block;
3228 static int marker_block_index;
3229
3230 static union Lisp_Misc *marker_free_list;
3231
3232
3233
3234 static int n_marker_blocks;
3235
3236 static void
3237 init_marker ()
3238 {
3239 marker_block = NULL;
3240 marker_block_index = MARKER_BLOCK_SIZE;
3241 marker_free_list = 0;
3242 n_marker_blocks = 0;
3243 }
3244
3245
3246
3247 Lisp_Object
3248 allocate_misc ()
3249 {
3250 Lisp_Object val;
3251
3252
3253
3254 MALLOC_BLOCK_INPUT;
3255
3256 if (marker_free_list)
3257 {
3258 XSETMISC (val, marker_free_list);
3259 marker_free_list = marker_free_list->u_free.chain;
3260 }
3261 else
3262 {
3263 if (marker_block_index == MARKER_BLOCK_SIZE)
3264 {
3265 struct marker_block *new;
3266 new = (struct marker_block *) lisp_malloc (sizeof *new,
3267 MEM_TYPE_MISC);
3268 new->next = marker_block;
3269 marker_block = new;
3270 marker_block_index = 0;
3271 n_marker_blocks++;
3272 total_free_markers += MARKER_BLOCK_SIZE;
3273 }
3274 XSETMISC (val, &marker_block->markers[marker_block_index]);
3275 marker_block_index++;
3276 }
3277
3278 MALLOC_UNBLOCK_INPUT;
3279
3280 --total_free_markers;
3281 consing_since_gc += sizeof (union Lisp_Misc);
3282 misc_objects_consed++;
3283 XMISCANY (val)->gcmarkbit = 0;
3284 return val;
3285 }
3286
3287
3288
3289 void
3290 free_misc (misc)
3291 Lisp_Object misc;
3292 {
3293 XMISCTYPE (misc) = Lisp_Misc_Free;
3294 XMISC (misc)->u_free.chain = marker_free_list;
3295 marker_free_list = XMISC (misc);
3296
3297 total_free_markers++;
3298 }
3299
3300 3301 3302
3303
3304 Lisp_Object
3305 make_save_value (pointer, integer)
3306 void *pointer;
3307 int integer;
3308 {
3309 register Lisp_Object val;
3310 register struct Lisp_Save_Value *p;
3311
3312 val = allocate_misc ();
3313 XMISCTYPE (val) = Lisp_Misc_Save_Value;
3314 p = XSAVE_VALUE (val);
3315 p->pointer = pointer;
3316 p->integer = integer;
3317 p->dogc = 0;
3318 return val;
3319 }
3320
3321 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3322 doc: )
3323 ()
3324 {
3325 register Lisp_Object val;
3326 register struct Lisp_Marker *p;
3327
3328 val = allocate_misc ();
3329 XMISCTYPE (val) = Lisp_Misc_Marker;
3330 p = XMARKER (val);
3331 p->buffer = 0;
3332 p->bytepos = 0;
3333 p->charpos = 0;
3334 p->next = NULL;
3335 p->insertion_type = 0;
3336 return val;
3337 }
3338
3339
3340
3341 void
3342 free_marker (marker)
3343 Lisp_Object marker;
3344 {
3345 unchain_marker (XMARKER (marker));
3346 free_misc (marker);
3347 }
3348
3349
3350 3351 3352 3353 3354
3355
3356 Lisp_Object
3357 make_event_array (nargs, args)
3358 register int nargs;
3359 Lisp_Object *args;
3360 {
3361 int i;
3362
3363 for (i = 0; i < nargs; i++)
3364 3365 3366
3367 if (!INTEGERP (args[i])
3368 || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
3369 return Fvector (nargs, args);
3370
3371 3372
3373 {
3374 Lisp_Object result;
3375
3376 result = Fmake_string (make_number (nargs), make_number (0));
3377 for (i = 0; i < nargs; i++)
3378 {
3379 SSET (result, i, XINT (args[i]));
3380
3381 if (XINT (args[i]) & CHAR_META)
3382 SSET (result, i, SREF (result, i) | 0x80);
3383 }
3384
3385 return result;
3386 }
3387 }
3388
3389
3390
3391 3392 3393
3394
3395
3396
3397
3398 void
3399 memory_full ()
3400 {
3401 int i;
3402
3403 Vmemory_full = Qt;
3404
3405 memory_full_cons_threshold = sizeof (struct cons_block);
3406
3407
3408 for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
3409 if (spare_memory[i])
3410 {
3411 if (i == 0)
3412 free (spare_memory[i]);
3413 else if (i >= 1 && i <= 4)
3414 lisp_align_free (spare_memory[i]);
3415 else
3416 lisp_free (spare_memory[i]);
3417 spare_memory[i] = 0;
3418 }
3419
3420 3421
3422 #ifndef SYSTEM_MALLOC
3423 bytes_used_when_full = BYTES_USED;
3424 #endif
3425
3426 3427
3428 xsignal (Qnil, Vmemory_signal_data);
3429 }
3430
3431 3432 3433 3434 3435 3436
3437
3438 void
3439 refill_memory_reserve ()
3440 {
3441 #ifndef SYSTEM_MALLOC
3442 if (spare_memory[0] == 0)
3443 spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
3444 if (spare_memory[1] == 0)
3445 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3446 MEM_TYPE_CONS);
3447 if (spare_memory[2] == 0)
3448 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3449 MEM_TYPE_CONS);
3450 if (spare_memory[3] == 0)
3451 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3452 MEM_TYPE_CONS);
3453 if (spare_memory[4] == 0)
3454 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3455 MEM_TYPE_CONS);
3456 if (spare_memory[5] == 0)
3457 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
3458 MEM_TYPE_STRING);
3459 if (spare_memory[6] == 0)
3460 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
3461 MEM_TYPE_STRING);
3462 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3463 Vmemory_full = Qnil;
3464 #endif
3465 }
3466
3467 3468 3469
3470
3471 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3472
3473 3474 3475 3476 3477 3478 3479 3480 3481 3482
3483
3484
3485
3486 static void
3487 mem_init ()
3488 {
3489 mem_z.left = mem_z.right = MEM_NIL;
3490 mem_z.parent = NULL;
3491 mem_z.color = MEM_BLACK;
3492 mem_z.start = mem_z.end = NULL;
3493 mem_root = MEM_NIL;
3494 }
3495
3496
3497 3498
3499
3500 static INLINE struct mem_node *
3501 mem_find (start)
3502 void *start;
3503 {
3504 struct mem_node *p;
3505
3506 if (start < min_heap_address || start > max_heap_address)
3507 return MEM_NIL;
3508
3509
3510 mem_z.start = start;
3511 mem_z.end = (char *) start + 1;
3512
3513 p = mem_root;
3514 while (start < p->start || start >= p->end)
3515 p = start < p->start ? p->left : p->right;
3516 return p;
3517 }
3518
3519
3520 3521 3522
3523
3524 static struct mem_node *
3525 mem_insert (start, end, type)
3526 void *start, *end;
3527 enum mem_type type;
3528 {
3529 struct mem_node *c, *parent, *x;
3530
3531 if (min_heap_address == NULL || start < min_heap_address)
3532 min_heap_address = start;
3533 if (max_heap_address == NULL || end > max_heap_address)
3534 max_heap_address = end;
3535
3536 3537 3538
3539 c = mem_root;
3540 parent = NULL;
3541
3542 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3543
3544 while (c != MEM_NIL)
3545 {
3546 if (start >= c->start && start < c->end)
3547 abort ();
3548 parent = c;
3549 c = start < c->start ? c->left : c->right;
3550 }
3551
3552 #else
3553
3554 while (c != MEM_NIL)
3555 {
3556 parent = c;
3557 c = start < c->start ? c->left : c->right;
3558 }
3559
3560 #endif
3561
3562
3563 #ifdef GC_MALLOC_CHECK
3564 x = (struct mem_node *) _malloc_internal (sizeof *x);
3565 if (x == NULL)
3566 abort ();
3567 #else
3568 x = (struct mem_node *) xmalloc (sizeof *x);
3569 #endif
3570 x->start = start;
3571 x->end = end;
3572 x->type = type;
3573 x->parent = parent;
3574 x->left = x->right = MEM_NIL;
3575 x->color = MEM_RED;
3576
3577
3578 if (parent)
3579 {
3580 if (start < parent->start)
3581 parent->left = x;
3582 else
3583 parent->right = x;
3584 }
3585 else
3586 mem_root = x;
3587
3588
3589 mem_insert_fixup (x);
3590
3591 return x;
3592 }
3593
3594
3595 3596
3597
3598 static void
3599 mem_insert_fixup (x)
3600 struct mem_node *x;
3601 {
3602 while (x != mem_root && x->parent->color == MEM_RED)
3603 {
3604 3605
3606
3607 if (x->parent == x->parent->parent->left)
3608 {
3609 3610
3611 struct mem_node *y = x->parent->parent->right;
3612
3613 if (y->color == MEM_RED)
3614 {
3615 3616 3617
3618 x->parent->color = MEM_BLACK;
3619 y->color = MEM_BLACK;
3620 x->parent->parent->color = MEM_RED;
3621 x = x->parent->parent;
3622 }
3623 else
3624 {
3625 3626
3627 if (x == x->parent->right)
3628 {
3629 x = x->parent;
3630 mem_rotate_left (x);
3631 }
3632
3633 x->parent->color = MEM_BLACK;
3634 x->parent->parent->color = MEM_RED;
3635 mem_rotate_right (x->parent->parent);
3636 }
3637 }
3638 else
3639 {
3640
3641 struct mem_node *y = x->parent->parent->left;
3642
3643 if (y->color == MEM_RED)
3644 {
3645 x->parent->color = MEM_BLACK;
3646 y->color = MEM_BLACK;
3647 x->parent->parent->color = MEM_RED;
3648 x = x->parent->parent;
3649 }
3650 else
3651 {
3652 if (x == x->parent->left)
3653 {
3654 x = x->parent;
3655 mem_rotate_right (x);
3656 }
3657
3658 x->parent->color = MEM_BLACK;
3659 x->parent->parent->color = MEM_RED;
3660 mem_rotate_left (x->parent->parent);
3661 }
3662 }
3663 }
3664
3665 3666
3667 mem_root->color = MEM_BLACK;
3668 }
3669
3670
3671 3672 3673 3674 3675
3676
3677 static void
3678 mem_rotate_left (x)
3679 struct mem_node *x;
3680 {
3681 struct mem_node *y;
3682
3683
3684 y = x->right;
3685 x->right = y->left;
3686 if (y->left != MEM_NIL)
3687 y->left->parent = x;
3688
3689
3690 if (y != MEM_NIL)
3691 y->parent = x->parent;
3692
3693
3694 if (x->parent)
3695 {
3696 if (x == x->parent->left)
3697 x->parent->left = y;
3698 else
3699 x->parent->right = y;
3700 }
3701 else
3702 mem_root = y;
3703
3704
3705 y->left = x;
3706 if (x != MEM_NIL)
3707 x->parent = y;
3708 }
3709
3710
3711 3712 3713 3714 3715
3716
3717 static void
3718 mem_rotate_right (x)
3719 struct mem_node *x;
3720 {
3721 struct mem_node *y = x->left;
3722
3723 x->left = y->right;
3724 if (y->right != MEM_NIL)
3725 y->right->parent = x;
3726
3727 if (y != MEM_NIL)
3728 y->parent = x->parent;
3729 if (x->parent)
3730 {
3731 if (x == x->parent->right)
3732 x->parent->right = y;
3733 else
3734 x->parent->left = y;
3735 }
3736 else
3737 mem_root = y;
3738
3739 y->right = x;
3740 if (x != MEM_NIL)
3741 x->parent = y;
3742 }
3743
3744
3745
3746
3747 static void
3748 mem_delete (z)
3749 struct mem_node *z;
3750 {
3751 struct mem_node *x, *y;
3752
3753 if (!z || z == MEM_NIL)
3754 return;
3755
3756 if (z->left == MEM_NIL || z->right == MEM_NIL)
3757 y = z;
3758 else
3759 {
3760 y = z->right;
3761 while (y->left != MEM_NIL)
3762 y = y->left;
3763 }
3764
3765 if (y->left != MEM_NIL)
3766 x = y->left;
3767 else
3768 x = y->right;
3769
3770 x->parent = y->parent;
3771 if (y->parent)
3772 {
3773 if (y == y->parent->left)
3774 y->parent->left = x;
3775 else
3776 y->parent->right = x;
3777 }
3778 else
3779 mem_root = x;
3780
3781 if (y != z)
3782 {
3783 z->start = y->start;
3784 z->end = y->end;
3785 z->type = y->type;
3786 }
3787
3788 if (y->color == MEM_BLACK)
3789 mem_delete_fixup (x);
3790
3791 #ifdef GC_MALLOC_CHECK
3792 _free_internal (y);
3793 #else
3794 xfree (y);
3795 #endif
3796 }
3797
3798
3799 3800
3801
3802 static void
3803 mem_delete_fixup (x)
3804 struct mem_node *x;
3805 {
3806 while (x != mem_root && x->color == MEM_BLACK)
3807 {
3808 if (x == x->parent->left)
3809 {
3810 struct mem_node *w = x->parent->right;
3811
3812 if (w->color == MEM_RED)
3813 {
3814 w->color = MEM_BLACK;
3815 x->parent->color = MEM_RED;
3816 mem_rotate_left (x->parent);
3817 w = x->parent->right;
3818 }
3819
3820 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
3821 {
3822 w->color = MEM_RED;
3823 x = x->parent;
3824 }
3825 else
3826 {
3827 if (w->right->color == MEM_BLACK)
3828 {
3829 w->left->color = MEM_BLACK;
3830 w->color = MEM_RED;
3831 mem_rotate_right (w);
3832 w = x->parent->right;
3833 }
3834 w->color = x->parent->color;
3835 x->parent->color = MEM_BLACK;
3836 w->right->color = MEM_BLACK;
3837 mem_rotate_left (x->parent);
3838 x = mem_root;
3839 }
3840 }
3841 else
3842 {
3843 struct mem_node *w = x->parent->left;
3844
3845 if (w->color == MEM_RED)
3846 {
3847 w->color = MEM_BLACK;
3848 x->parent->color = MEM_RED;
3849 mem_rotate_right (x->parent);
3850 w = x->parent->left;
3851 }
3852
3853 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
3854 {
3855 w->color = MEM_RED;
3856 x = x->parent;
3857 }
3858 else
3859 {
3860 if (w->left->color == MEM_BLACK)
3861 {
3862 w->right->color = MEM_BLACK;
3863 w->color = MEM_RED;
3864 mem_rotate_left (w);
3865 w = x->parent->left;
3866 }
3867
3868 w->color = x->parent->color;
3869 x->parent->color = MEM_BLACK;
3870 w->left->color = MEM_BLACK;
3871 mem_rotate_right (x->parent);
3872 x = mem_root;
3873 }
3874 }
3875 }
3876
3877 x->color = MEM_BLACK;
3878 }
3879
3880
3881 3882
3883
3884 static INLINE int
3885 live_string_p (m, p)
3886 struct mem_node *m;
3887 void *p;
3888 {
3889 if (m->type == MEM_TYPE_STRING)
3890 {
3891 struct string_block *b = (struct string_block *) m->start;
3892 int offset = (char *) p - (char *) &b->strings[0];
3893
3894 3895
3896 return (offset >= 0
3897 && offset % sizeof b->strings[0] == 0
3898 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
3899 && ((struct Lisp_String *) p)->data != NULL);
3900 }
3901 else
3902 return 0;
3903 }
3904
3905
3906 3907
3908
3909 static INLINE int
3910 live_cons_p (m, p)
3911 struct mem_node *m;
3912 void *p;
3913 {
3914 if (m->type == MEM_TYPE_CONS)
3915 {
3916 struct cons_block *b = (struct cons_block *) m->start;
3917 int offset = (char *) p - (char *) &b->conses[0];
3918
3919 3920 3921
3922 return (offset >= 0
3923 && offset % sizeof b->conses[0] == 0
3924 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
3925 && (b != cons_block
3926 || offset / sizeof b->conses[0] < cons_block_index)
3927 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
3928 }
3929 else
3930 return 0;
3931 }
3932
3933
3934 3935
3936
3937 static INLINE int
3938 live_symbol_p (m, p)
3939 struct mem_node *m;
3940 void *p;
3941 {
3942 if (m->type == MEM_TYPE_SYMBOL)
3943 {
3944 struct symbol_block *b = (struct symbol_block *) m->start;
3945 int offset = (char *) p - (char *) &b->symbols[0];
3946
3947 3948 3949
3950 return (offset >= 0
3951 && offset % sizeof b->symbols[0] == 0
3952 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3953 && (b != symbol_block
3954 || offset / sizeof b->symbols[0] < symbol_block_index)
3955 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
3956 }
3957 else
3958 return 0;
3959 }
3960
3961
3962 3963
3964
3965 static INLINE int
3966 live_float_p (m, p)
3967 struct mem_node *m;
3968 void *p;
3969 {
3970 if (m->type == MEM_TYPE_FLOAT)
3971 {
3972 struct float_block *b = (struct float_block *) m->start;
3973 int offset = (char *) p - (char *) &b->floats[0];
3974
3975 3976
3977 return (offset >= 0
3978 && offset % sizeof b->floats[0] == 0
3979 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
3980 && (b != float_block
3981 || offset / sizeof b->floats[0] < float_block_index));
3982 }
3983 else
3984 return 0;
3985 }
3986
3987
3988 3989
3990
3991 static INLINE int
3992 live_misc_p (m, p)
3993 struct mem_node *m;
3994 void *p;
3995 {
3996 if (m->type == MEM_TYPE_MISC)
3997 {
3998 struct marker_block *b = (struct marker_block *) m->start;
3999 int offset = (char *) p - (char *) &b->markers[0];
4000
4001 4002 4003
4004 return (offset >= 0
4005 && offset % sizeof b->markers[0] == 0
4006 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4007 && (b != marker_block
4008 || offset / sizeof b->markers[0] < marker_block_index)
4009 && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4010 }
4011 else
4012 return 0;
4013 }
4014
4015
4016 4017
4018
4019 static INLINE int
4020 live_vector_p (m, p)
4021 struct mem_node *m;
4022 void *p;
4023 {
4024 return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
4025 }
4026
4027
4028 4029
4030
4031 static INLINE int
4032 live_buffer_p (m, p)
4033 struct mem_node *m;
4034 void *p;
4035 {
4036 4037
4038 return (m->type == MEM_TYPE_BUFFER
4039 && p == m->start
4040 && !NILP (((struct buffer *) p)->name));
4041 }
4042
4043 #endif
4044
4045 #if GC_MARK_STACK
4046
4047 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4048
4049 4050
4051
4052 #define MAX_ZOMBIES 10
4053 static Lisp_Object zombies[MAX_ZOMBIES];
4054
4055
4056
4057 static int nzombies;
4058
4059
4060
4061 static int ngcs;
4062
4063
4064
4065 static double avg_zombies;
4066
4067
4068
4069 static int max_live, max_zombies;
4070
4071
4072
4073 static double avg_live;
4074
4075 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4076 doc: )
4077 ()
4078 {
4079 Lisp_Object args[8], zombie_list = Qnil;
4080 int i;
4081 for (i = 0; i < nzombies; i++)
4082 zombie_list = Fcons (zombies[i], zombie_list);
4083 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4084 args[1] = make_number (ngcs);
4085 args[2] = make_float (avg_live);
4086 args[3] = make_float (avg_zombies);
4087 args[4] = make_float (avg_zombies / avg_live / 100);
4088 args[5] = make_number (max_live);
4089 args[6] = make_number (max_zombies);
4090 args[7] = zombie_list;
4091 return Fmessage (8, args);
4092 }
4093
4094 #endif
4095
4096
4097
4098
4099 static INLINE void
4100 mark_maybe_object (obj)
4101 Lisp_Object obj;
4102 {
4103 void *po = (void *) XPNTR (obj);
4104 struct mem_node *m = mem_find (po);
4105
4106 if (m != MEM_NIL)
4107 {
4108 int mark_p = 0;
4109
4110 switch (XTYPE (obj))
4111 {
4112 case Lisp_String:
4113 mark_p = (live_string_p (m, po)
4114 && !STRING_MARKED_P ((struct Lisp_String *) po));
4115 break;
4116
4117 case Lisp_Cons:
4118 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4119 break;
4120
4121 case Lisp_Symbol:
4122 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4123 break;
4124
4125 case Lisp_Float:
4126 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4127 break;
4128
4129 case Lisp_Vectorlike:
4130 4131 4132
4133 if (live_vector_p (m, po))
4134 mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4135 else if (live_buffer_p (m, po))
4136 mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4137 break;
4138
4139 case Lisp_Misc:
4140 mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4141 break;
4142
4143 default:
4144 break;
4145 }
4146
4147 if (mark_p)
4148 {
4149 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4150 if (nzombies < MAX_ZOMBIES)
4151 zombies[nzombies] = obj;
4152 ++nzombies;
4153 #endif
4154 mark_object (obj);
4155 }
4156 }
4157 }
4158
4159
4160 4161
4162
4163 static INLINE void
4164 mark_maybe_pointer (p)
4165 void *p;
4166 {
4167 struct mem_node *m;
4168
4169
4170 if ((EMACS_INT) p %
4171 #ifdef USE_LSB_TAG
4172 8
4173 #else
4174 2
4175 #endif
4176 )
4177 return;
4178
4179 m = mem_find (p);
4180 if (m != MEM_NIL)
4181 {
4182 Lisp_Object obj = Qnil;
4183
4184 switch (m->type)
4185 {
4186 case MEM_TYPE_NON_LISP:
4187
4188 break;
4189
4190 case MEM_TYPE_BUFFER:
4191 if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
4192 XSETVECTOR (obj, p);
4193 break;
4194
4195 case MEM_TYPE_CONS:
4196 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4197 XSETCONS (obj, p);
4198 break;
4199
4200 case MEM_TYPE_STRING:
4201 if (live_string_p (m, p)
4202 && !STRING_MARKED_P ((struct Lisp_String *) p))
4203 XSETSTRING (obj, p);
4204 break;
4205
4206 case MEM_TYPE_MISC:
4207 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4208 XSETMISC (obj, p);
4209 break;
4210
4211 case MEM_TYPE_SYMBOL:
4212 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4213 XSETSYMBOL (obj, p);
4214 break;
4215
4216 case MEM_TYPE_FLOAT:
4217 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4218 XSETFLOAT (obj, p);
4219 break;
4220
4221 case MEM_TYPE_VECTORLIKE:
4222 if (live_vector_p (m, p))
4223 {
4224 Lisp_Object tem;
4225 XSETVECTOR (tem, p);
4226 if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4227 obj = tem;
4228 }
4229 break;
4230
4231 default:
4232 abort ();
4233 }
4234
4235 if (!NILP (obj))
4236 mark_object (obj);
4237 }
4238 }
4239
4240
4241 4242
4243
4244 static void
4245 mark_memory (start, end, offset)
4246 void *start, *end;
4247 int offset;
4248 {
4249 Lisp_Object *p;
4250 void **pp;
4251
4252 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4253 nzombies = 0;
4254 #endif
4255
4256 4257
4258 if (end < start)
4259 {
4260 void *tem = start;
4261 start = end;
4262 end = tem;
4263 }
4264
4265
4266 for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
4267 mark_maybe_object (*p);
4268
4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285
4286
4287 for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
4288 mark_maybe_pointer (*pp);
4289 }
4290
4291 4292 4293 4294
4295
4296 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4297
4298 static int setjmp_tested_p, longjmps_done;
4299
4300 #define SETJMP_WILL_LIKELY_WORK "\
4301 \n\
4302 Emacs garbage collector has been changed to use conservative stack\n\
4303 marking. Emacs has determined that the method it uses to do the\n\
4304 marking will likely work on your system, but this isn't sure.\n\
4305 \n\
4306 If you are a system-programmer, or can get the help of a local wizard\n\
4307 who is, please take a look at the function mark_stack in alloc.c, and\n\
4308 verify that the methods used are appropriate for your system.\n\
4309 \n\
4310 Please mail the result to <emacs-devel@gnu.org>.\n\
4311 "
4312
4313 #define SETJMP_WILL_NOT_WORK "\
4314 \n\
4315 Emacs garbage collector has been changed to use conservative stack\n\
4316 marking. Emacs has determined that the default method it uses to do the\n\
4317 marking will not work on your system. We will need a system-dependent\n\
4318 solution for your system.\n\
4319 \n\
4320 Please take a look at the function mark_stack in alloc.c, and\n\
4321 try to find a way to make it work on your system.\n\
4322 \n\
4323 Note that you may get false negatives, depending on the compiler.\n\
4324 In particular, you need to use -O with GCC for this test.\n\
4325 \n\
4326 Please mail the result to <emacs-devel@gnu.org>.\n\
4327 "
4328
4329
4330 4331 4332 4333 4334
4335
4336 static void
4337 test_setjmp ()
4338 {
4339 char buf[10];
4340 register int x;
4341 jmp_buf jbuf;
4342 int result = 0;
4343
4344
4345 sprintf (buf, "1");
4346 x = strlen (buf);
4347 x = 2 * x - 1;
4348
4349 setjmp (jbuf);
4350 if (longjmps_done == 1)
4351 {
4352 4353 4354 4355 4356 4357 4358 4359 4360
4361
4362 if (x == 1)
4363 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
4364 else
4365 {
4366 fprintf (stderr, SETJMP_WILL_NOT_WORK);
4367 exit (1);
4368 }
4369 }
4370
4371 ++longjmps_done;
4372 x = 2;
4373 if (longjmps_done == 1)
4374 longjmp (jbuf, 1);
4375 }
4376
4377 #endif
4378
4379
4380 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4381
4382
4383
4384 static void
4385 check_gcpros ()
4386 {
4387 struct gcpro *p;
4388 int i;
4389
4390 for (p = gcprolist; p; p = p->next)
4391 for (i = 0; i < p->nvars; ++i)
4392 if (!survives_gc_p (p->var[i]))
4393 4394
4395 abort ();
4396 }
4397
4398 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4399
4400 static void
4401 dump_zombies ()
4402 {
4403 int i;
4404
4405 fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
4406 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
4407 {
4408 fprintf (stderr, " %d = ", i);
4409 debug_print (zombies[i]);
4410 }
4411 }
4412
4413 #endif
4414
4415
4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460
4461
4462 static void
4463 mark_stack ()
4464 {
4465 int i;
4466
4467 union aligned_jmpbuf {
4468 Lisp_Object o;
4469 jmp_buf j;
4470 } j;
4471 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
4472 void *end;
4473
4474 4475
4476 4477 4478
4479 #ifdef __sparc__
4480 #if defined (__sparc64__) && defined (__FreeBSD__)
4481
4482 asm ("flushw");
4483 #else
4484 asm ("ta 3");
4485 #endif
4486 #endif
4487
4488 4489 4490
4491 #ifdef GC_SAVE_REGISTERS_ON_STACK
4492 GC_SAVE_REGISTERS_ON_STACK (end);
4493 #else
4494
4495 #ifndef GC_SETJMP_WORKS 4496 4497 4498
4499 if (!setjmp_tested_p)
4500 {
4501 setjmp_tested_p = 1;
4502 test_setjmp ();
4503 }
4504 #endif
4505
4506 setjmp (j.j);
4507 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4508 #endif
4509
4510 4511 4512
4513 #ifndef GC_LISP_OBJECT_ALIGNMENT
4514 #ifdef __GNUC__
4515 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4516 #else
4517 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4518 #endif
4519 #endif
4520 for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
4521 mark_memory (stack_base, end, i);
4522 4523
4524 #ifdef GC_MARK_SECONDARY_STACK
4525 GC_MARK_SECONDARY_STACK ();
4526 #endif
4527
4528 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4529 check_gcpros ();
4530 #endif
4531 }
4532
4533 #endif
4534
4535
4536
4537 static int
4538 valid_pointer_p (p)
4539 void *p;
4540 {
4541 #ifdef WINDOWSNT
4542 return w32_valid_pointer_p (p, 16);
4543 #else
4544 int fd;
4545
4546 4547 4548 4549
4550
4551 if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
4552 {
4553 int valid = (emacs_write (fd, (char *)p, 16) == 16);
4554 emacs_close (fd);
4555 unlink ("__Valid__Lisp__Object__");
4556 return valid;
4557 }
4558
4559 return -1;
4560 #endif
4561 }
4562
4563 4564 4565 4566 4567
4568
4569 int
4570 valid_lisp_object_p (obj)
4571 Lisp_Object obj;
4572 {
4573 void *p;
4574 #if GC_MARK_STACK
4575 struct mem_node *m;
4576 #endif
4577
4578 if (INTEGERP (obj))
4579 return 1;
4580
4581 p = (void *) XPNTR (obj);
4582 if (PURE_POINTER_P (p))
4583 return 1;
4584
4585 #if !GC_MARK_STACK
4586 return valid_pointer_p (p);
4587 #else
4588
4589 m = mem_find (p);
4590
4591 if (m == MEM_NIL)
4592 {
4593 int valid = valid_pointer_p (p);
4594 if (valid <= 0)
4595 return valid;
4596
4597 if (SUBRP (obj))
4598 return 1;
4599
4600 return 0;
4601 }
4602
4603 switch (m->type)
4604 {
4605 case MEM_TYPE_NON_LISP:
4606 return 0;
4607
4608 case MEM_TYPE_BUFFER:
4609 return live_buffer_p (m, p);
4610
4611 case MEM_TYPE_CONS:
4612 return live_cons_p (m, p);
4613
4614 case MEM_TYPE_STRING:
4615 return live_string_p (m, p);
4616
4617 case MEM_TYPE_MISC:
4618 return live_misc_p (m, p);
4619
4620 case MEM_TYPE_SYMBOL:
4621 return live_symbol_p (m, p);
4622
4623 case MEM_TYPE_FLOAT:
4624 return live_float_p (m, p);
4625
4626 case MEM_TYPE_VECTORLIKE:
4627 return live_vector_p (m, p);
4628
4629 default:
4630 break;
4631 }
4632
4633 return 0;
4634 #endif
4635 }
4636
4637
4638
4639
4640 4641 4642
4643
4644 4645 4646
4647
4648 static POINTER_TYPE *
4649 pure_alloc (size, type)
4650 size_t size;
4651 int type;
4652 {
4653 POINTER_TYPE *result;
4654 #ifdef USE_LSB_TAG
4655 size_t alignment = (1 << GCTYPEBITS);
4656 #else
4657 size_t alignment = sizeof (EMACS_INT);
4658
4659
4660 if (type == Lisp_Float)
4661 {
4662 #if defined __GNUC__ && __GNUC__ >= 2
4663 alignment = __alignof (struct Lisp_Float);
4664 #else
4665 alignment = sizeof (struct Lisp_Float);
4666 #endif
4667 }
4668 #endif
4669
4670 again:
4671 if (type >= 0)
4672 {
4673 4674
4675 result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
4676 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
4677 }
4678 else
4679 {
4680 4681
4682 pure_bytes_used_non_lisp += size;
4683 result = purebeg + pure_size - pure_bytes_used_non_lisp;
4684 }
4685 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
4686
4687 if (pure_bytes_used <= pure_size)
4688 return result;
4689
4690 4691 4692
4693 purebeg = (char *) xmalloc (10000);
4694 pure_size = 10000;
4695 pure_bytes_used_before_overflow += pure_bytes_used - size;
4696 pure_bytes_used = 0;
4697 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
4698 goto again;
4699 }
4700
4701
4702
4703
4704 void
4705 check_pure_size ()
4706 {
4707 if (pure_bytes_used_before_overflow)
4708 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4709 (int) (pure_bytes_used + pure_bytes_used_before_overflow));
4710 }
4711
4712
4713 4714 4715
4716
4717 static char *
4718 find_string_data_in_pure (data, nbytes)
4719 const char *data;
4720 int nbytes;
4721 {
4722 int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4723 const unsigned char *p;
4724 char *non_lisp_beg;
4725
4726 if (pure_bytes_used_non_lisp < nbytes + 1)
4727 return NULL;
4728
4729
4730 skip = nbytes + 1;
4731 for (i = 0; i < 256; i++)
4732 bm_skip[i] = skip;
4733
4734 p = (const unsigned char *) data;
4735 while (--skip > 0)
4736 bm_skip[*p++] = skip;
4737
4738 last_char_skip = bm_skip['\0'];
4739
4740 non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
4741 start_max = pure_bytes_used_non_lisp - (nbytes + 1);
4742
4743 4744
4745 infinity = pure_bytes_used_non_lisp + 1;
4746 bm_skip['\0'] = infinity;
4747
4748 p = (const unsigned char *) non_lisp_beg + nbytes;
4749 start = 0;
4750 do
4751 {
4752
4753 do
4754 {
4755 start += bm_skip[*(p + start)];
4756 }
4757 while (start <= start_max);
4758
4759 if (start < infinity)
4760
4761 return NULL;
4762
4763 4764
4765 start -= infinity;
4766
4767
4768 if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
4769
4770 return non_lisp_beg + start;
4771
4772 start += last_char_skip;
4773 }
4774 while (start <= start_max);
4775
4776 return NULL;
4777 }
4778
4779
4780 4781 4782 4783 4784 4785 4786
4787
4788 Lisp_Object
4789 make_pure_string (data, nchars, nbytes, multibyte)
4790 const char *data;
4791 int nchars, nbytes;
4792 int multibyte;
4793 {
4794 Lisp_Object string;
4795 struct Lisp_String *s;
4796
4797 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4798 s->data = find_string_data_in_pure (data, nbytes);
4799 if (s->data == NULL)
4800 {
4801 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
4802 bcopy (data, s->data, nbytes);
4803 s->data[nbytes] = '\0';
4804 }
4805 s->size = nchars;
4806 s->size_byte = multibyte ? nbytes : -1;
4807 s->intervals = NULL_INTERVAL;
4808 XSETSTRING (string, s);
4809 return string;
4810 }
4811
4812 4813
4814
4815 Lisp_Object
4816 make_pure_c_string (const char *data)
4817 {
4818 Lisp_Object string;
4819 struct Lisp_String *s;
4820 int nchars = strlen (data);
4821
4822 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4823 s->size = nchars;
4824 s->size_byte = -1;
4825 s->data = (unsigned char *) data;
4826 s->intervals = NULL_INTERVAL;
4827 XSETSTRING (string, s);
4828 return string;
4829 }
4830
4831 4832
4833
4834 Lisp_Object
4835 pure_cons (car, cdr)
4836 Lisp_Object car, cdr;
4837 {
4838 register Lisp_Object new;
4839 struct Lisp_Cons *p;
4840
4841 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4842 XSETCONS (new, p);
4843 XSETCAR (new, Fpurecopy (car));
4844 XSETCDR (new, Fpurecopy (cdr));
4845 return new;
4846 }
4847
4848
4849
4850
4851 static Lisp_Object
4852 make_pure_float (num)
4853 double num;
4854 {
4855 register Lisp_Object new;
4856 struct Lisp_Float *p;
4857
4858 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4859 XSETFLOAT (new, p);
4860 XFLOAT_INIT (new, num);
4861 return new;
4862 }
4863
4864
4865 4866
4867
4868 Lisp_Object
4869 make_pure_vector (len)
4870 EMACS_INT len;
4871 {
4872 Lisp_Object new;
4873 struct Lisp_Vector *p;
4874 size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
4875
4876 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4877 XSETVECTOR (new, p);
4878 XVECTOR (new)->size = len;
4879 return new;
4880 }
4881
4882
4883 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
4884 doc: 4885 4886 )
4887 (obj)
4888 register Lisp_Object obj;
4889 {
4890 if (NILP (Vpurify_flag))
4891 return obj;
4892
4893 if (PURE_POINTER_P (XPNTR (obj)))
4894 return obj;
4895
4896 if (HASH_TABLE_P (Vpurify_flag))
4897 {
4898 Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
4899 if (!NILP (tmp))
4900 return tmp;
4901 }
4902
4903 if (CONSP (obj))
4904 obj = pure_cons (XCAR (obj), XCDR (obj));
4905 else if (FLOATP (obj))
4906 obj = make_pure_float (XFLOAT_DATA (obj));
4907 else if (STRINGP (obj))
4908 obj = make_pure_string (SDATA (obj), SCHARS (obj),
4909 SBYTES (obj),
4910 STRING_MULTIBYTE (obj));
4911 else if (COMPILEDP (obj) || VECTORP (obj))
4912 {
4913 register struct Lisp_Vector *vec;
4914 register int i;
4915 EMACS_INT size;
4916
4917 size = XVECTOR (obj)->size;
4918 if (size & PSEUDOVECTOR_FLAG)
4919 size &= PSEUDOVECTOR_SIZE_MASK;
4920 vec = XVECTOR (make_pure_vector (size));
4921 for (i = 0; i < size; i++)
4922 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
4923 if (COMPILEDP (obj))
4924 {
4925 XSETPVECTYPE (vec, PVEC_COMPILED);
4926 XSETCOMPILED (obj, vec);
4927 }
4928 else
4929 XSETVECTOR (obj, vec);
4930 }
4931 else if (MARKERP (obj))
4932 error ("Attempt to copy a marker to pure storage");
4933 else
4934
4935 return obj;
4936
4937 if (HASH_TABLE_P (Vpurify_flag))
4938 Fputhash (obj, obj, Vpurify_flag);
4939
4940 return obj;
4941 }
4942
4943
4944
4945 4946 4947
4948
4949 4950
4951
4952 void
4953 staticpro (varaddress)
4954 Lisp_Object *varaddress;
4955 {
4956 staticvec[staticidx++] = varaddress;
4957 if (staticidx >= NSTATICS)
4958 abort ();
4959 }
4960
4961
4962 4963 4964
4965
4966
4967
4968 int
4969 inhibit_garbage_collection ()
4970 {
4971 int count = SPECPDL_INDEX ();
4972 int nbits = min (VALBITS, BITS_PER_INT);
4973
4974 specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
4975 return count;
4976 }
4977
4978
4979 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
4980 doc: 4981 4982 4983 4984 4985 4986 4987 4988 4989 )
4990 ()
4991 {
4992 register struct specbinding *bind;
4993 struct catchtag *catch;
4994 struct handler *handler;
4995 char stack_top_variable;
4996 register int i;
4997 int message_p;
4998 Lisp_Object total[8];
4999 int count = SPECPDL_INDEX ();
5000 EMACS_TIME t1, t2, t3;
5001
5002 if (abort_on_gc)
5003 abort ();
5004
5005 5006
5007 if (pure_bytes_used_before_overflow)
5008 return Qnil;
5009
5010 CHECK_CONS_LIST ();
5011
5012 5013
5014 {
5015 register struct buffer *nextb = all_buffers;
5016
5017 while (nextb)
5018 {
5019 5020 5021 5022
5023 if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
5024 truncate_undo_list (nextb);
5025
5026
5027 if (nextb->base_buffer == 0 && !NILP (nextb->name)
5028 && ! nextb->text->inhibit_shrinking)
5029 {
5030 5031 5032
5033 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5034
5035 if (nextb->text->gap_size > size)
5036 {
5037 struct buffer *save_current = current_buffer;
5038 current_buffer = nextb;
5039 make_gap (-(nextb->text->gap_size - size));
5040 current_buffer = save_current;
5041 }
5042 }
5043
5044 nextb = nextb->next;
5045 }
5046 }
5047
5048 EMACS_GET_TIME (t1);
5049
5050 5051
5052 consing_since_gc = 0;
5053
5054
5055 message_p = push_message ();
5056 record_unwind_protect (pop_message_unwind, Qnil);
5057
5058
5059 #if MAX_SAVE_STACK > 0
5060 if (NILP (Vpurify_flag))
5061 {
5062 i = &stack_top_variable - stack_bottom;
5063 if (i < 0) i = -i;
5064 if (i < MAX_SAVE_STACK)
5065 {
5066 if (stack_copy == 0)
5067 stack_copy = (char *) xmalloc (stack_copy_size = i);
5068 else if (stack_copy_size < i)
5069 stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
5070 if (stack_copy)
5071 {
5072 if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
5073 bcopy (stack_bottom, stack_copy, i);
5074 else
5075 bcopy (&stack_top_variable, stack_copy, i);
5076 }
5077 }
5078 }
5079 #endif
5080
5081 if (garbage_collection_messages)
5082 message1_nolog ("Garbage collecting...");
5083
5084 BLOCK_INPUT;
5085
5086 shrink_regexp_cache ();
5087
5088 gc_in_progress = 1;
5089
5090
5091
5092
5093
5094 for (i = 0; i < staticidx; i++)
5095 mark_object (*staticvec[i]);
5096
5097 for (bind = specpdl; bind != specpdl_ptr; bind++)
5098 {
5099 mark_object (bind->symbol);
5100 mark_object (bind->old_value);
5101 }
5102 mark_terminals ();
5103 mark_kboards ();
5104 mark_ttys ();
5105
5106 #ifdef USE_GTK
5107 {
5108 extern void xg_mark_data ();
5109 xg_mark_data ();
5110 }
5111 #endif
5112
5113 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5114 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5115 mark_stack ();
5116 #else
5117 {
5118 register struct gcpro *tail;
5119 for (tail = gcprolist; tail; tail = tail->next)
5120 for (i = 0; i < tail->nvars; i++)
5121 mark_object (tail->var[i]);
5122 }
5123 #endif
5124
5125 mark_byte_stack ();
5126 for (catch = catchlist; catch; catch = catch->next)
5127 {
5128 mark_object (catch->tag);
5129 mark_object (catch->val);
5130 }
5131 for (handler = handlerlist; handler; handler = handler->next)
5132 {
5133 mark_object (handler->handler);
5134 mark_object (handler->var);
5135 }
5136 mark_backtrace ();
5137
5138 #ifdef HAVE_WINDOW_SYSTEM
5139 mark_fringe_data ();
5140 #endif
5141
5142 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5143 mark_stack ();
5144 #endif
5145
5146 5147 5148 5149 5150
5151 {
5152 register struct buffer *nextb = all_buffers;
5153
5154 while (nextb)
5155 {
5156 5157 5158 5159
5160 if (! EQ (nextb->undo_list, Qt))
5161 {
5162 Lisp_Object tail, prev;
5163 tail = nextb->undo_list;
5164 prev = Qnil;
5165 while (CONSP (tail))
5166 {
5167 if (CONSP (XCAR (tail))
5168 && MARKERP (XCAR (XCAR (tail)))
5169 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5170 {
5171 if (NILP (prev))
5172 nextb->undo_list = tail = XCDR (tail);
5173 else
5174 {
5175 tail = XCDR (tail);
5176 XSETCDR (prev, tail);
5177 }
5178 }
5179 else
5180 {
5181 prev = tail;
5182 tail = XCDR (tail);
5183 }
5184 }
5185 }
5186 5187
5188 mark_object (nextb->undo_list);
5189
5190 nextb = nextb->next;
5191 }
5192 }
5193
5194 gc_sweep ();
5195
5196
5197
5198 unmark_byte_stack ();
5199 VECTOR_UNMARK (&buffer_defaults);
5200 VECTOR_UNMARK (&buffer_local_symbols);
5201
5202 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5203 dump_zombies ();
5204 #endif
5205
5206 UNBLOCK_INPUT;
5207
5208 CHECK_CONS_LIST ();
5209
5210
5211 gc_in_progress = 0;
5212
5213 consing_since_gc = 0;
5214 if (gc_cons_threshold < 10000)
5215 gc_cons_threshold = 10000;
5216
5217 if (FLOATP (Vgc_cons_percentage))
5218 {
5219 EMACS_INT total = 0;
5220
5221 total += total_conses * sizeof (struct Lisp_Cons);
5222 total += total_symbols * sizeof (struct Lisp_Symbol);
5223 total += total_markers * sizeof (union Lisp_Misc);
5224 total += total_string_size;
5225 total += total_vector_size * sizeof (Lisp_Object);
5226 total += total_floats * sizeof (struct Lisp_Float);
5227 total += total_intervals * sizeof (struct interval);
5228 total += total_strings * sizeof (struct Lisp_String);
5229
5230 gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
5231 }
5232 else
5233 gc_relative_threshold = 0;
5234
5235 if (garbage_collection_messages)
5236 {
5237 if (message_p || minibuf_level > 0)
5238 restore_message ();
5239 else
5240 message1_nolog ("Garbage collecting...done");
5241 }
5242
5243 unbind_to (count, Qnil);
5244
5245 total[0] = Fcons (make_number (total_conses),
5246 make_number (total_free_conses));
5247 total[1] = Fcons (make_number (total_symbols),
5248 make_number (total_free_symbols));
5249 total[2] = Fcons (make_number (total_markers),
5250 make_number (total_free_markers));
5251 total[3] = make_number (total_string_size);
5252 total[4] = make_number (total_vector_size);
5253 total[5] = Fcons (make_number (total_floats),
5254 make_number (total_free_floats));
5255 total[6] = Fcons (make_number (total_intervals),
5256 make_number (total_free_intervals));
5257 total[7] = Fcons (make_number (total_strings),
5258 make_number (total_free_strings));
5259
5260 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5261 {
5262
5263 double nlive = 0;
5264
5265 for (i = 0; i < 7; ++i)
5266 if (CONSP (total[i]))
5267 nlive += XFASTINT (XCAR (total[i]));
5268
5269 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5270 max_live = max (nlive, max_live);
5271 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5272 max_zombies = max (nzombies, max_zombies);
5273 ++ngcs;
5274 }
5275 #endif
5276
5277 if (!NILP (Vpost_gc_hook))
5278 {
5279 int count = inhibit_garbage_collection ();
5280 safe_run_hooks (Qpost_gc_hook);
5281 unbind_to (count, Qnil);
5282 }
5283
5284
5285 EMACS_GET_TIME (t2);
5286 EMACS_SUB_TIME (t3, t2, t1);
5287 if (FLOATP (Vgc_elapsed))
5288 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
5289 EMACS_SECS (t3) +
5290 EMACS_USECS (t3) * 1.0e-6);
5291 gcs_done++;
5292
5293 return Flist (sizeof total / sizeof *total, total);
5294 }
5295
5296
5297 5298
5299
5300 static void
5301 mark_glyph_matrix (matrix)
5302 struct glyph_matrix *matrix;
5303 {
5304 struct glyph_row *row = matrix->rows;
5305 struct glyph_row *end = row + matrix->nrows;
5306
5307 for (; row < end; ++row)
5308 if (row->enabled_p)
5309 {
5310 int area;
5311 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
5312 {
5313 struct glyph *glyph = row->glyphs[area];
5314 struct glyph *end_glyph = glyph + row->used[area];
5315
5316 for (; glyph < end_glyph; ++glyph)
5317 if (STRINGP (glyph->object)
5318 && !STRING_MARKED_P (XSTRING (glyph->object)))
5319 mark_object (glyph->object);
5320 }
5321 }
5322 }
5323
5324
5325
5326
5327 static void
5328 mark_face_cache (c)
5329 struct face_cache *c;
5330 {
5331 if (c)
5332 {
5333 int i, j;
5334 for (i = 0; i < c->used; ++i)
5335 {
5336 struct face *face = FACE_FROM_ID (c->f, i);
5337
5338 if (face)
5339 {
5340 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
5341 mark_object (face->lface[j]);
5342 }
5343 }
5344 }
5345 }
5346
5347
5348
5349 5350 5351
5352
5353 #define LAST_MARKED_SIZE 500
5354 static Lisp_Object last_marked[LAST_MARKED_SIZE];
5355 int last_marked_index;
5356
5357 5358 5359 5360
5361 static int mark_object_loop_halt;
5362
5363 static void
5364 mark_vectorlike (ptr)
5365 struct Lisp_Vector *ptr;
5366 {
5367 register EMACS_INT size = ptr->size;
5368 register int i;
5369
5370 eassert (!VECTOR_MARKED_P (ptr));
5371 VECTOR_MARK (ptr);
5372 if (size & PSEUDOVECTOR_FLAG)
5373 size &= PSEUDOVECTOR_SIZE_MASK;
5374
5375 5376 5377 5378
5379 for (i = 0; i < size; i++)
5380 mark_object (ptr->contents[i]);
5381 }
5382
5383 5384 5385
5386
5387 static void
5388 mark_char_table (ptr)
5389 struct Lisp_Vector *ptr;
5390 {
5391 register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
5392 register int i;
5393
5394 eassert (!VECTOR_MARKED_P (ptr));
5395 VECTOR_MARK (ptr);
5396 for (i = 0; i < size; i++)
5397 {
5398 Lisp_Object val = ptr->contents[i];
5399
5400 if (INTEGERP (val) || SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)
5401 continue;
5402 if (SUB_CHAR_TABLE_P (val))
5403 {
5404 if (! VECTOR_MARKED_P (XVECTOR (val)))
5405 mark_char_table (XVECTOR (val));
5406 }
5407 else
5408 mark_object (val);
5409 }
5410 }
5411
5412 void
5413 mark_object (arg)
5414 Lisp_Object arg;
5415 {
5416 register Lisp_Object obj = arg;
5417 #ifdef GC_CHECK_MARKED_OBJECTS
5418 void *po;
5419 struct mem_node *m;
5420 #endif
5421 int cdr_count = 0;
5422
5423 loop:
5424
5425 if (PURE_POINTER_P (XPNTR (obj)))
5426 return;
5427
5428 last_marked[last_marked_index++] = obj;
5429 if (last_marked_index == LAST_MARKED_SIZE)
5430 last_marked_index = 0;
5431
5432 5433 5434
5435 #ifdef GC_CHECK_MARKED_OBJECTS
5436
5437 po = (void *) XPNTR (obj);
5438
5439 5440
5441 #define CHECK_ALLOCATED() \
5442 do { \
5443 m = mem_find (po); \
5444 if (m == MEM_NIL) \
5445 abort (); \
5446 } while (0)
5447
5448 5449
5450 #define CHECK_LIVE(LIVEP) \
5451 do { \
5452 if (!LIVEP (m, po)) \
5453 abort (); \
5454 } while (0)
5455
5456
5457 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5458 do { \
5459 CHECK_ALLOCATED (); \
5460 CHECK_LIVE (LIVEP); \
5461 } while (0) \
5462
5463 #else
5464
5465 #define CHECK_ALLOCATED() (void) 0
5466 #define CHECK_LIVE(LIVEP) (void) 0
5467 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5468
5469 #endif
5470
5471 switch (SWITCH_ENUM_CAST (XTYPE (obj)))
5472 {
5473 case Lisp_String:
5474 {
5475 register struct Lisp_String *ptr = XSTRING (obj);
5476 if (STRING_MARKED_P (ptr))
5477 break;
5478 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5479 MARK_INTERVAL_TREE (ptr->intervals);
5480 MARK_STRING (ptr);
5481 #ifdef GC_CHECK_STRING_BYTES
5482 5483
5484 CHECK_STRING_BYTES (ptr);
5485 #endif
5486 }
5487 break;
5488
5489 case Lisp_Vectorlike:
5490 if (VECTOR_MARKED_P (XVECTOR (obj)))
5491 break;
5492 #ifdef GC_CHECK_MARKED_OBJECTS
5493 m = mem_find (po);
5494 if (m == MEM_NIL && !SUBRP (obj)
5495 && po != &buffer_defaults
5496 && po != &buffer_local_symbols)
5497 abort ();
5498 #endif
5499
5500 if (BUFFERP (obj))
5501 {
5502 #ifdef GC_CHECK_MARKED_OBJECTS
5503 if (po != &buffer_defaults && po != &buffer_local_symbols)
5504 {
5505 struct buffer *b;
5506 for (b = all_buffers; b && b != po; b = b->next)
5507 ;
5508 if (b == NULL)
5509 abort ();
5510 }
5511 #endif
5512 mark_buffer (obj);
5513 }
5514 else if (SUBRP (obj))
5515 break;
5516 else if (COMPILEDP (obj))
5517 5518 5519
5520 {
5521 register struct Lisp_Vector *ptr = XVECTOR (obj);
5522 register EMACS_INT size = ptr->size;
5523 register int i;
5524
5525 CHECK_LIVE (live_vector_p);
5526 VECTOR_MARK (ptr);
5527 size &= PSEUDOVECTOR_SIZE_MASK;
5528 for (i = 0; i < size; i++)
5529 {
5530 if (i != COMPILED_CONSTANTS)
5531 mark_object (ptr->contents[i]);
5532 }
5533 obj = ptr->contents[COMPILED_CONSTANTS];
5534 goto loop;
5535 }
5536 else if (FRAMEP (obj))
5537 {
5538 register struct frame *ptr = XFRAME (obj);
5539 mark_vectorlike (XVECTOR (obj));
5540 mark_face_cache (ptr->face_cache);
5541 }
5542 else if (WINDOWP (obj))
5543 {
5544 register struct Lisp_Vector *ptr = XVECTOR (obj);
5545 struct window *w = XWINDOW (obj);
5546 mark_vectorlike (ptr);
5547 5548 5549
5550 if (NILP (w->hchild)
5551 && NILP (w->vchild)
5552 && w->current_matrix)
5553 {
5554 mark_glyph_matrix (w->current_matrix);
5555 mark_glyph_matrix (w->desired_matrix);
5556 }
5557 }
5558 else if (HASH_TABLE_P (obj))
5559 {
5560 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
5561 mark_vectorlike ((struct Lisp_Vector *)h);
5562 5563
5564 if (NILP (h->weak))
5565 mark_object (h->key_and_value);
5566 else
5567 VECTOR_MARK (XVECTOR (h->key_and_value));
5568 }
5569 else if (CHAR_TABLE_P (obj))
5570 mark_char_table (XVECTOR (obj));
5571 else
5572 mark_vectorlike (XVECTOR (obj));
5573 break;
5574
5575 case Lisp_Symbol:
5576 {
5577 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
5578 struct Lisp_Symbol *ptrx;
5579
5580 if (ptr->gcmarkbit)
5581 break;
5582 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
5583 ptr->gcmarkbit = 1;
5584 mark_object (ptr->function);
5585 mark_object (ptr->plist);
5586 switch (ptr->redirect)
5587 {
5588 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
5589 case SYMBOL_VARALIAS:
5590 {
5591 Lisp_Object tem;
5592 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
5593 mark_object (tem);
5594 break;
5595 }
5596 case SYMBOL_LOCALIZED:
5597 {
5598 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5599 5600 5601 5602
5603 mark_object (blv->where);
5604 mark_object (blv->valcell);
5605 mark_object (blv->defcell);
5606 break;
5607 }
5608 case SYMBOL_FORWARDED:
5609 5610 5611 5612
5613 break;
5614 default: abort ();
5615 }
5616 if (!PURE_POINTER_P (XSTRING (ptr->xname)))
5617 MARK_STRING (XSTRING (ptr->xname));
5618 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
5619
5620 ptr = ptr->next;
5621 if (ptr)
5622 {
5623 ptrx = ptr;
5624 XSETSYMBOL (obj, ptrx);
5625 goto loop;
5626 }
5627 }
5628 break;
5629
5630 case Lisp_Misc:
5631 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5632 if (XMISCANY (obj)->gcmarkbit)
5633 break;
5634 XMISCANY (obj)->gcmarkbit = 1;
5635
5636 switch (XMISCTYPE (obj))
5637 {
5638
5639 case Lisp_Misc_Marker:
5640 5641 5642
5643 break;
5644
5645 case Lisp_Misc_Save_Value:
5646 #if GC_MARK_STACK
5647 {
5648 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5649 5650
5651 if (ptr->dogc)
5652 {
5653 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
5654 int nelt;
5655 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
5656 mark_maybe_object (*p);
5657 }
5658 }
5659 #endif
5660 break;
5661
5662 case Lisp_Misc_Overlay:
5663 {
5664 struct Lisp_Overlay *ptr = XOVERLAY (obj);
5665 mark_object (ptr->start);
5666 mark_object (ptr->end);
5667 mark_object (ptr->plist);
5668 if (ptr->next)
5669 {
5670 XSETMISC (obj, ptr->next);
5671 goto loop;
5672 }
5673 }
5674 break;
5675
5676 default:
5677 abort ();
5678 }
5679 break;
5680
5681 case Lisp_Cons:
5682 {
5683 register struct Lisp_Cons *ptr = XCONS (obj);
5684 if (CONS_MARKED_P (ptr))
5685 break;
5686 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
5687 CONS_MARK (ptr);
5688
5689 if (EQ (ptr->u.cdr, Qnil))
5690 {
5691 obj = ptr->car;
5692 cdr_count = 0;
5693 goto loop;
5694 }
5695 mark_object (ptr->car);
5696 obj = ptr->u.cdr;
5697 cdr_count++;
5698 if (cdr_count == mark_object_loop_halt)
5699 abort ();
5700 goto loop;
5701 }
5702
5703 case Lisp_Float:
5704 CHECK_ALLOCATED_AND_LIVE (live_float_p);
5705 FLOAT_MARK (XFLOAT (obj));
5706 break;
5707
5708 case_Lisp_Int:
5709 break;
5710
5711 default:
5712 abort ();
5713 }
5714
5715 #undef CHECK_LIVE
5716 #undef CHECK_ALLOCATED
5717 #undef CHECK_ALLOCATED_AND_LIVE
5718 }
5719
5720
5721
5722 static void
5723 mark_buffer (buf)
5724 Lisp_Object buf;
5725 {
5726 register struct buffer *buffer = XBUFFER (buf);
5727 register Lisp_Object *ptr, tmp;
5728 Lisp_Object base_buffer;
5729
5730 eassert (!VECTOR_MARKED_P (buffer));
5731 VECTOR_MARK (buffer);
5732
5733 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5734
5735 5736 5737
5738
5739 if (buffer->overlays_before)
5740 {
5741 XSETMISC (tmp, buffer->overlays_before);
5742 mark_object (tmp);
5743 }
5744 if (buffer->overlays_after)
5745 {
5746 XSETMISC (tmp, buffer->overlays_after);
5747 mark_object (tmp);
5748 }
5749
5750 5751
5752 for (ptr = &buffer->name;
5753 (char *)ptr < (char *)buffer + sizeof (struct buffer);
5754 ptr++)
5755 mark_object (*ptr);
5756
5757
5758 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5759 {
5760 XSETBUFFER (base_buffer, buffer->base_buffer);
5761 mark_buffer (base_buffer);
5762 }
5763 }
5764
5765 5766
5767
5768 static void
5769 mark_terminals (void)
5770 {
5771 struct terminal *t;
5772 for (t = terminal_list; t; t = t->next_terminal)
5773 {
5774 eassert (t->name != NULL);
5775 if (!VECTOR_MARKED_P (t))
5776 {
5777 #ifdef HAVE_WINDOW_SYSTEM
5778 mark_image_cache (t->image_cache);
5779 #endif
5780 mark_vectorlike ((struct Lisp_Vector *)t);
5781 }
5782 }
5783 }
5784
5785
5786
5787 5788
5789
5790 int
5791 survives_gc_p (obj)
5792 Lisp_Object obj;
5793 {
5794 int survives_p;
5795
5796 switch (XTYPE (obj))
5797 {
5798 case_Lisp_Int:
5799 survives_p = 1;
5800 break;
5801
5802 case Lisp_Symbol:
5803 survives_p = XSYMBOL (obj)->gcmarkbit;
5804 break;
5805
5806 case Lisp_Misc:
5807 survives_p = XMISCANY (obj)->gcmarkbit;
5808 break;
5809
5810 case Lisp_String:
5811 survives_p = STRING_MARKED_P (XSTRING (obj));
5812 break;
5813
5814 case Lisp_Vectorlike:
5815 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
5816 break;
5817
5818 case Lisp_Cons:
5819 survives_p = CONS_MARKED_P (XCONS (obj));
5820 break;
5821
5822 case Lisp_Float:
5823 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
5824 break;
5825
5826 default:
5827 abort ();
5828 }
5829
5830 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
5831 }
5832
5833
5834
5835
5836
5837 static void
5838 gc_sweep ()
5839 {
5840 5841
5842 sweep_weak_hash_tables ();
5843
5844 sweep_strings ();
5845 #ifdef GC_CHECK_STRING_BYTES
5846 if (!noninteractive)
5847 check_string_bytes (1);
5848 #endif
5849
5850
5851 {
5852 register struct cons_block *cblk;
5853 struct cons_block **cprev = &cons_block;
5854 register int lim = cons_block_index;
5855 register int num_free = 0, num_used = 0;
5856
5857 cons_free_list = 0;
5858
5859 for (cblk = cons_block; cblk; cblk = *cprev)
5860 {
5861 register int i = 0;
5862 int this_free = 0;
5863 int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
5864
5865
5866 for (i = 0; i <= ilim; i++)
5867 {
5868 if (cblk->gcmarkbits[i] == -1)
5869 {
5870
5871 cblk->gcmarkbits[i] = 0;
5872 num_used += BITS_PER_INT;
5873 }
5874 else
5875 {
5876 5877
5878 int start, pos, stop;
5879
5880 start = i * BITS_PER_INT;
5881 stop = lim - start;
5882 if (stop > BITS_PER_INT)
5883 stop = BITS_PER_INT;
5884 stop += start;
5885
5886 for (pos = start; pos < stop; pos++)
5887 {
5888 if (!CONS_MARKED_P (&cblk->conses[pos]))
5889 {
5890 this_free++;
5891 cblk->conses[pos].u.chain = cons_free_list;
5892 cons_free_list = &cblk->conses[pos];
5893 #if GC_MARK_STACK
5894 cons_free_list->car = Vdead;
5895 #endif
5896 }
5897 else
5898 {
5899 num_used++;
5900 CONS_UNMARK (&cblk->conses[pos]);
5901 }
5902 }
5903 }
5904 }
5905
5906 lim = CONS_BLOCK_SIZE;
5907 5908 5909
5910 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
5911 {
5912 *cprev = cblk->next;
5913
5914 cons_free_list = cblk->conses[0].u.chain;
5915 lisp_align_free (cblk);
5916 n_cons_blocks--;
5917 }
5918 else
5919 {
5920 num_free += this_free;
5921 cprev = &cblk->next;
5922 }
5923 }
5924 total_conses = num_used;
5925 total_free_conses = num_free;
5926 }
5927
5928
5929 {
5930 register struct float_block *fblk;
5931 struct float_block **fprev = &float_block;
5932 register int lim = float_block_index;
5933 register int num_free = 0, num_used = 0;
5934
5935 float_free_list = 0;
5936
5937 for (fblk = float_block; fblk; fblk = *fprev)
5938 {
5939 register int i;
5940 int this_free = 0;
5941 for (i = 0; i < lim; i++)
5942 if (!FLOAT_MARKED_P (&fblk->floats[i]))
5943 {
5944 this_free++;
5945 fblk->floats[i].u.chain = float_free_list;
5946 float_free_list = &fblk->floats[i];
5947 }
5948 else
5949 {
5950 num_used++;
5951 FLOAT_UNMARK (&fblk->floats[i]);
5952 }
5953 lim = FLOAT_BLOCK_SIZE;
5954 5955 5956
5957 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
5958 {
5959 *fprev = fblk->next;
5960
5961 float_free_list = fblk->floats[0].u.chain;
5962 lisp_align_free (fblk);
5963 n_float_blocks--;
5964 }
5965 else
5966 {
5967 num_free += this_free;
5968 fprev = &fblk->next;
5969 }
5970 }
5971 total_floats = num_used;
5972 total_free_floats = num_free;
5973 }
5974
5975
5976 {
5977 register struct interval_block *iblk;
5978 struct interval_block **iprev = &interval_block;
5979 register int lim = interval_block_index;
5980 register int num_free = 0, num_used = 0;
5981
5982 interval_free_list = 0;
5983
5984 for (iblk = interval_block; iblk; iblk = *iprev)
5985 {
5986 register int i;
5987 int this_free = 0;
5988
5989 for (i = 0; i < lim; i++)
5990 {
5991 if (!iblk->intervals[i].gcmarkbit)
5992 {
5993 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
5994 interval_free_list = &iblk->intervals[i];
5995 this_free++;
5996 }
5997 else
5998 {
5999 num_used++;
6000 iblk->intervals[i].gcmarkbit = 0;
6001 }
6002 }
6003 lim = INTERVAL_BLOCK_SIZE;
6004 6005 6006
6007 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6008 {
6009 *iprev = iblk->next;
6010
6011 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
6012 lisp_free (iblk);
6013 n_interval_blocks--;
6014 }
6015 else
6016 {
6017 num_free += this_free;
6018 iprev = &iblk->next;
6019 }
6020 }
6021 total_intervals = num_used;
6022 total_free_intervals = num_free;
6023 }
6024
6025
6026 {
6027 register struct symbol_block *sblk;
6028 struct symbol_block **sprev = &symbol_block;
6029 register int lim = symbol_block_index;
6030 register int num_free = 0, num_used = 0;
6031
6032 symbol_free_list = NULL;
6033
6034 for (sblk = symbol_block; sblk; sblk = *sprev)
6035 {
6036 int this_free = 0;
6037 struct Lisp_Symbol *sym = sblk->symbols;
6038 struct Lisp_Symbol *end = sym + lim;
6039
6040 for (; sym < end; ++sym)
6041 {
6042 6043 6044
6045 int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
6046
6047 if (!sym->gcmarkbit && !pure_p)
6048 {
6049 if (sym->redirect == SYMBOL_LOCALIZED)
6050 xfree (SYMBOL_BLV (sym));
6051 sym->next = symbol_free_list;
6052 symbol_free_list = sym;
6053 #if GC_MARK_STACK
6054 symbol_free_list->function = Vdead;
6055 #endif
6056 ++this_free;
6057 }
6058 else
6059 {
6060 ++num_used;
6061 if (!pure_p)
6062 UNMARK_STRING (XSTRING (sym->xname));
6063 sym->gcmarkbit = 0;
6064 }
6065 }
6066
6067 lim = SYMBOL_BLOCK_SIZE;
6068 6069 6070
6071 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6072 {
6073 *sprev = sblk->next;
6074
6075 symbol_free_list = sblk->symbols[0].next;
6076 lisp_free (sblk);
6077 n_symbol_blocks--;
6078 }
6079 else
6080 {
6081 num_free += this_free;
6082 sprev = &sblk->next;
6083 }
6084 }
6085 total_symbols = num_used;
6086 total_free_symbols = num_free;
6087 }
6088
6089 6090
6091 {
6092 register struct marker_block *mblk;
6093 struct marker_block **mprev = &marker_block;
6094 register int lim = marker_block_index;
6095 register int num_free = 0, num_used = 0;
6096
6097 marker_free_list = 0;
6098
6099 for (mblk = marker_block; mblk; mblk = *mprev)
6100 {
6101 register int i;
6102 int this_free = 0;
6103
6104 for (i = 0; i < lim; i++)
6105 {
6106 if (!mblk->markers[i].u_any.gcmarkbit)
6107 {
6108 if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
6109 unchain_marker (&mblk->markers[i].u_marker);
6110 6111 6112
6113 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
6114 mblk->markers[i].u_free.chain = marker_free_list;
6115 marker_free_list = &mblk->markers[i];
6116 this_free++;
6117 }
6118 else
6119 {
6120 num_used++;
6121 mblk->markers[i].u_any.gcmarkbit = 0;
6122 }
6123 }
6124 lim = MARKER_BLOCK_SIZE;
6125 6126 6127
6128 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6129 {
6130 *mprev = mblk->next;
6131
6132 marker_free_list = mblk->markers[0].u_free.chain;
6133 lisp_free (mblk);
6134 n_marker_blocks--;
6135 }
6136 else
6137 {
6138 num_free += this_free;
6139 mprev = &mblk->next;
6140 }
6141 }
6142
6143 total_markers = num_used;
6144 total_free_markers = num_free;
6145 }
6146
6147
6148 {
6149 register struct buffer *buffer = all_buffers, *prev = 0, *next;
6150
6151 while (buffer)
6152 if (!VECTOR_MARKED_P (buffer))
6153 {
6154 if (prev)
6155 prev->next = buffer->next;
6156 else
6157 all_buffers = buffer->next;
6158 next = buffer->next;
6159 lisp_free (buffer);
6160 buffer = next;
6161 }
6162 else
6163 {
6164 VECTOR_UNMARK (buffer);
6165 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
6166 prev = buffer, buffer = buffer->next;
6167 }
6168 }
6169
6170
6171 {
6172 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6173 total_vector_size = 0;
6174
6175 while (vector)
6176 if (!VECTOR_MARKED_P (vector))
6177 {
6178 if (prev)
6179 prev->next = vector->next;
6180 else
6181 all_vectors = vector->next;
6182 next = vector->next;
6183 lisp_free (vector);
6184 n_vectors--;
6185 vector = next;
6186
6187 }
6188 else
6189 {
6190 VECTOR_UNMARK (vector);
6191 if (vector->size & PSEUDOVECTOR_FLAG)
6192 total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
6193 else
6194 total_vector_size += vector->size;
6195 prev = vector, vector = vector->next;
6196 }
6197 }
6198
6199 #ifdef GC_CHECK_STRING_BYTES
6200 if (!noninteractive)
6201 check_string_bytes (1);
6202 #endif
6203 }
6204
6205
6206
6207
6208
6209
6210 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
6211 doc: 6212 6213 )
6214 ()
6215 {
6216 Lisp_Object end;
6217
6218 XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
6219
6220 return end;
6221 }
6222
6223 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
6224 doc: 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 )
6236 ()
6237 {
6238 Lisp_Object consed[8];
6239
6240 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
6241 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
6242 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
6243 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
6244 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
6245 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
6246 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
6247 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6248
6249 return Flist (8, consed);
6250 }
6251
6252 int suppress_checking;
6253
6254 void
6255 die (msg, file, line)
6256 const char *msg;
6257 const char *file;
6258 int line;
6259 {
6260 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6261 file, line, msg);
6262 abort ();
6263 }
6264
6265
6266
6267 void
6268 init_alloc_once ()
6269 {
6270
6271 purebeg = PUREBEG;
6272 pure_size = PURESIZE;
6273 pure_bytes_used = 0;
6274 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6275 pure_bytes_used_before_overflow = 0;
6276
6277
6278 free_ablock = NULL;
6279
6280 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6281 mem_init ();
6282 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6283 #endif
6284
6285 all_vectors = 0;
6286 ignore_warnings = 1;
6287 #ifdef DOUG_LEA_MALLOC
6288 mallopt (M_TRIM_THRESHOLD, 128*1024);
6289 mallopt (M_MMAP_THRESHOLD, 64*1024);
6290 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
6291 #endif
6292 init_strings ();
6293 init_cons ();
6294 init_symbol ();
6295 init_marker ();
6296 init_float ();
6297 init_intervals ();
6298 init_weak_hash_tables ();
6299
6300 #ifdef REL_ALLOC
6301 malloc_hysteresis = 32;
6302 #else
6303 malloc_hysteresis = 0;
6304 #endif
6305
6306 refill_memory_reserve ();
6307
6308 ignore_warnings = 0;
6309 gcprolist = 0;
6310 byte_stack_list = 0;
6311 staticidx = 0;
6312 consing_since_gc = 0;
6313 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6314 gc_relative_threshold = 0;
6315
6316 #ifdef VIRT_ADDR_VARIES
6317 malloc_sbrk_unused = 1<<22;
6318 malloc_sbrk_used = 100000;
6319 #endif
6320 }
6321
6322 void
6323 init_alloc ()
6324 {
6325 gcprolist = 0;
6326 byte_stack_list = 0;
6327 #if GC_MARK_STACK
6328 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6329 setjmp_tested_p = longjmps_done = 0;
6330 #endif
6331 #endif
6332 Vgc_elapsed = make_float (0.0);
6333 gcs_done = 0;
6334 }
6335
6336 void
6337 syms_of_alloc ()
6338 {
6339 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
6340 doc: 6341 6342 6343 6344 6345 6346 6347 6348 );
6349
6350 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
6351 doc: 6352 6353 6354 );
6355 Vgc_cons_percentage = make_float (0.1);
6356
6357 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
6358 doc: );
6359
6360 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
6361 doc: );
6362
6363 DEFVAR_INT ("floats-consed", &floats_consed,
6364 doc: );
6365
6366 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
6367 doc: );
6368
6369 DEFVAR_INT ("symbols-consed", &symbols_consed,
6370 doc: );
6371
6372 DEFVAR_INT ("string-chars-consed", &string_chars_consed,
6373 doc: );
6374
6375 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
6376 doc: );
6377
6378 DEFVAR_INT ("intervals-consed", &intervals_consed,
6379 doc: );
6380
6381 DEFVAR_INT ("strings-consed", &strings_consed,
6382 doc: );
6383
6384 DEFVAR_LISP ("purify-flag", &Vpurify_flag,
6385 doc: 6386 6387 6388 );
6389
6390 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
6391 doc: );
6392 garbage_collection_messages = 0;
6393
6394 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
6395 doc: );
6396 Vpost_gc_hook = Qnil;
6397 Qpost_gc_hook = intern_c_string ("post-gc-hook");
6398 staticpro (&Qpost_gc_hook);
6399
6400 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
6401 doc: );
6402 6403
6404 Vmemory_signal_data
6405 = pure_cons (Qerror,
6406 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
6407
6408 DEFVAR_LISP ("memory-full", &Vmemory_full,
6409 doc: );
6410 Vmemory_full = Qnil;
6411
6412 staticpro (&Qgc_cons_threshold);
6413 Qgc_cons_threshold = intern_c_string ("gc-cons-threshold");
6414
6415 staticpro (&Qchar_table_extra_slots);
6416 Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
6417
6418 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
6419 doc: 6420 );
6421 DEFVAR_INT ("gcs-done", &gcs_done,
6422 doc: );
6423
6424 defsubr (&Scons);
6425 defsubr (&Slist);
6426 defsubr (&Svector);
6427 defsubr (&Smake_byte_code);
6428 defsubr (&Smake_list);
6429 defsubr (&Smake_vector);
6430 defsubr (&Smake_string);
6431 defsubr (&Smake_bool_vector);
6432 defsubr (&Smake_symbol);
6433 defsubr (&Smake_marker);
6434 defsubr (&Spurecopy);
6435 defsubr (&Sgarbage_collect);
6436 defsubr (&Smemory_limit);
6437 defsubr (&Smemory_use_counts);
6438
6439 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6440 defsubr (&Sgc_status);
6441 #endif
6442 }
6443
6444 6445