Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents a300bb07d72d
children 064ab7fed2e0
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
49 #include "elhash.h" 49 #include "elhash.h"
50 #include "events.h" 50 #include "events.h"
51 #include "extents.h" 51 #include "extents.h"
52 #include "frame.h" 52 #include "frame.h"
53 #include "glyphs.h" 53 #include "glyphs.h"
54 #include "opaque.h"
54 #include "redisplay.h" 55 #include "redisplay.h"
55 #include "specifier.h" 56 #include "specifier.h"
56 #include "sysfile.h" 57 #include "sysfile.h"
57 #include "window.h" 58 #include "window.h"
58 59
72 #endif 73 #endif
73 #endif 74 #endif
74 75
75 /* Define this to see where all that space is going... */ 76 /* Define this to see where all that space is going... */
76 /* But the length of the printout is obnoxious, so limit it to testers */ 77 /* But the length of the printout is obnoxious, so limit it to testers */
77 /* If somebody wants to see this they can ask for it. 78 #ifdef MEMORY_USAGE_STATS
78 #ifdef DEBUG_XEMACS
79 #define PURESTAT 79 #define PURESTAT
80 #endif 80 #endif
81 */
82 81
83 /* Define this to use malloc/free with no freelist for all datatypes, 82 /* Define this to use malloc/free with no freelist for all datatypes,
84 the hope being that some debugging tools may help detect 83 the hope being that some debugging tools may help detect
85 freed memory references */ 84 freed memory references */
86 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ 85 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
89 #endif 88 #endif
90 89
91 #include "puresize.h" 90 #include "puresize.h"
92 91
93 #ifdef DEBUG_XEMACS 92 #ifdef DEBUG_XEMACS
94 int debug_allocation; 93 static int debug_allocation;
95 94 static int debug_allocation_backtrace_length;
96 int debug_allocation_backtrace_length;
97 #endif 95 #endif
98 96
99 /* Number of bytes of consing done since the last gc */ 97 /* Number of bytes of consing done since the last gc */
100 EMACS_INT consing_since_gc; 98 EMACS_INT consing_since_gc;
101 #ifdef EMACS_BTL
102 extern void cadillac_record_backtrace ();
103 #define INCREMENT_CONS_COUNTER_1(size) \
104 do { \
105 EMACS_INT __sz__ = ((EMACS_INT) (size)); \
106 consing_since_gc += __sz__; \
107 cadillac_record_backtrace (2, __sz__); \
108 } while (0)
109 #else
110 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size)) 99 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
111 #endif /* EMACS_BTL */
112 100
113 #define debug_allocation_backtrace() \ 101 #define debug_allocation_backtrace() \
114 do { \ 102 do { \
115 if (debug_allocation_backtrace_length > 0) \ 103 if (debug_allocation_backtrace_length > 0) \
116 debug_short_backtrace (debug_allocation_backtrace_length); \ 104 debug_short_backtrace (debug_allocation_backtrace_length); \
139 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) 127 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
140 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ 128 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
141 INCREMENT_CONS_COUNTER_1 (size) 129 INCREMENT_CONS_COUNTER_1 (size)
142 #endif 130 #endif
143 131
144 #define DECREMENT_CONS_COUNTER(size) \ 132 #define DECREMENT_CONS_COUNTER(size) do { \
145 do { \ 133 consing_since_gc -= (size); \
146 EMACS_INT __sz__ = ((EMACS_INT) (size)); \ 134 if (consing_since_gc < 0) \
147 if (consing_since_gc >= __sz__) \ 135 consing_since_gc = 0; \
148 consing_since_gc -= __sz__; \ 136 } while (0)
149 else \
150 consing_since_gc = 0; \
151 } while (0)
152 137
153 /* Number of bytes of consing since gc before another gc should be done. */ 138 /* Number of bytes of consing since gc before another gc should be done. */
154 EMACS_INT gc_cons_threshold; 139 EMACS_INT gc_cons_threshold;
155 140
156 /* Nonzero during gc */ 141 /* Nonzero during gc */
193 178
194 #ifdef HEAP_IN_DATA 179 #ifdef HEAP_IN_DATA
195 extern void sheap_adjust_h(); 180 extern void sheap_adjust_h();
196 #endif 181 #endif
197 182
183 /* Force linker to put it into data space! */
184 EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
185
198 #define PUREBEG ((char *) pure) 186 #define PUREBEG ((char *) pure)
199 187
200 #if 0 /* This is breathing_space in XEmacs */ 188 #if 0 /* This is breathing_space in XEmacs */
201 /* Points to memory space allocated as "spare", 189 /* Points to memory space allocated as "spare",
202 to be freed if we run out of memory. */ 190 to be freed if we run out of memory. */
211 199
212 #define PURIFIED(ptr) \ 200 #define PURIFIED(ptr) \
213 ((char *) (ptr) >= PUREBEG && \ 201 ((char *) (ptr) >= PUREBEG && \
214 (char *) (ptr) < PUREBEG + get_PURESIZE()) 202 (char *) (ptr) < PUREBEG + get_PURESIZE())
215 203
216 /* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */ 204 /* Non-zero if pure_bytes_used > get_PURESIZE();
205 accounts for excess purespace needs. */
217 static size_t pure_lossage; 206 static size_t pure_lossage;
218 207
219 #ifdef ERROR_CHECK_TYPECHECK 208 #ifdef ERROR_CHECK_TYPECHECK
220 209
221 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN; 210 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
260 249
261 #define bump_purestat(p,b) DO_NOTHING 250 #define bump_purestat(p,b) DO_NOTHING
262 251
263 #else /* PURESTAT */ 252 #else /* PURESTAT */
264 253
265 static int purecopying_for_bytecode; 254 static int purecopying_function_constants;
266 255
267 static size_t pure_sizeof (Lisp_Object /*, int recurse */); 256 static size_t pure_sizeof (Lisp_Object);
268 257
269 /* Keep statistics on how much of what is in purespace */ 258 /* Keep statistics on how much of what is in purespace */
270 static struct purestat 259 static struct purestat
271 { 260 {
272 int nobjects; 261 int nobjects;
274 CONST char *name; 263 CONST char *name;
275 } 264 }
276 purestat_cons = {0, 0, "cons cells"}, 265 purestat_cons = {0, 0, "cons cells"},
277 purestat_float = {0, 0, "float objects"}, 266 purestat_float = {0, 0, "float objects"},
278 purestat_string_pname = {0, 0, "symbol-name strings"}, 267 purestat_string_pname = {0, 0, "symbol-name strings"},
279 purestat_bytecode = {0, 0, "compiled-function objects"}, 268 purestat_function = {0, 0, "compiled-function objects"},
280 purestat_string_bytecodes = {0, 0, "byte-code strings"}, 269 purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
281 purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"}, 270 purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
282 purestat_string_interactive = {0, 0, "interactive strings"}, 271 purestat_string_interactive = {0, 0, "interactive strings"},
283 #ifdef I18N3 272 #ifdef I18N3
284 purestat_string_domain = {0, 0, "domain strings"}, 273 purestat_string_domain = {0, 0, "domain strings"},
285 #endif 274 #endif
286 purestat_string_documentation = {0, 0, "documentation strings"}, 275 purestat_string_documentation = {0, 0, "documentation strings"},
288 purestat_vector_other = {0, 0, "other vectors"}, 277 purestat_vector_other = {0, 0, "other vectors"},
289 purestat_string_other = {0, 0, "other strings"}, 278 purestat_string_other = {0, 0, "other strings"},
290 purestat_string_all = {0, 0, "all strings"}, 279 purestat_string_all = {0, 0, "all strings"},
291 purestat_vector_all = {0, 0, "all vectors"}; 280 purestat_vector_all = {0, 0, "all vectors"};
292 281
293 static struct purestat *purestats[] =
294 {
295 &purestat_cons,
296 &purestat_float,
297 &purestat_string_pname,
298 &purestat_bytecode,
299 &purestat_string_bytecodes,
300 &purestat_vector_bytecode_constants,
301 &purestat_string_interactive,
302 #ifdef I18N3
303 &purestat_string_domain,
304 #endif
305 &purestat_string_documentation,
306 &purestat_string_other_function,
307 &purestat_vector_other,
308 &purestat_string_other,
309 0,
310 &purestat_string_all,
311 &purestat_vector_all
312 };
313
314 static void 282 static void
315 bump_purestat (struct purestat *purestat, size_t nbytes) 283 bump_purestat (struct purestat *purestat, size_t nbytes)
316 { 284 {
317 if (pure_lossage) return; 285 if (pure_lossage) return;
318 purestat->nobjects += 1; 286 purestat->nobjects += 1;
319 purestat->nbytes += nbytes; 287 purestat->nbytes += nbytes;
320 } 288 }
289
290 static void
291 print_purestat (struct purestat *purestat)
292 {
293 char buf [100];
294 sprintf(buf, "%s:", purestat->name);
295 message (" %-36s %5d %7d %2d%%",
296 buf,
297 purestat->nobjects,
298 purestat->nbytes,
299 (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
300 }
321 #endif /* PURESTAT */ 301 #endif /* PURESTAT */
322 302
323 303
324 /* Maximum amount of C stack to save when a GC happens. */ 304 /* Maximum amount of C stack to save when a GC happens. */
325 305
326 #ifndef MAX_SAVE_STACK 306 #ifndef MAX_SAVE_STACK
327 #define MAX_SAVE_STACK 16000 307 #define MAX_SAVE_STACK 0 /* 16000 */
328 #endif 308 #endif
329 309
330 /* Non-zero means ignore malloc warnings. Set during initialization. */ 310 /* Non-zero means ignore malloc warnings. Set during initialization. */
331 int ignore_malloc_warnings; 311 int ignore_malloc_warnings;
332 312
393 373
394 if (!val && (size != 0)) memory_full (); 374 if (!val && (size != 0)) memory_full ();
395 return val; 375 return val;
396 } 376 }
397 377
378 static void *
379 xcalloc (size_t nelem, size_t elsize)
380 {
381 void *val = (void *) calloc (nelem, elsize);
382
383 if (!val && (nelem != 0)) memory_full ();
384 return val;
385 }
386
398 void * 387 void *
399 xmalloc_and_zero (size_t size) 388 xmalloc_and_zero (size_t size)
400 { 389 {
401 void *val = xmalloc (size); 390 return xcalloc (size, sizeof (char));
402 memset (val, 0, size);
403 return val;
404 } 391 }
405 392
406 #ifdef xrealloc 393 #ifdef xrealloc
407 #undef xrealloc 394 #undef xrealloc
408 #endif 395 #endif
517 void * 504 void *
518 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation) 505 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
519 { 506 {
520 struct lcrecord_header *lcheader; 507 struct lcrecord_header *lcheader;
521 508
522 if (size <= 0) abort (); 509 #ifdef ERROR_CHECK_GC
523 if (implementation->static_size == 0) 510 if (implementation->static_size == 0)
524 { 511 assert (implementation->size_in_bytes_method);
525 if (!implementation->size_in_bytes_method) 512 else
526 abort (); 513 assert (implementation->static_size == size);
527 } 514 #endif
528 else if (implementation->static_size != size)
529 abort ();
530 515
531 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); 516 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
532 set_lheader_implementation(&(lcheader->lheader), implementation); 517 set_lheader_implementation (&(lcheader->lheader), implementation);
533 lcheader->next = all_lcrecords; 518 lcheader->next = all_lcrecords;
534 #if 1 /* mly prefers to see small ID numbers */ 519 #if 1 /* mly prefers to see small ID numbers */
535 lcheader->uid = lrecord_uid_counter++; 520 lcheader->uid = lrecord_uid_counter++;
536 #else /* jwz prefers to see real addrs */ 521 #else /* jwz prefers to see real addrs */
537 lcheader->uid = (int) &lcheader; 522 lcheader->uid = (int) &lcheader;
572 else 557 else
573 header = next; 558 header = next;
574 } 559 }
575 } 560 }
576 if (lrecord->implementation->finalizer) 561 if (lrecord->implementation->finalizer)
577 ((lrecord->implementation->finalizer) (lrecord, 0)); 562 lrecord->implementation->finalizer (lrecord, 0);
578 xfree (lrecord); 563 xfree (lrecord);
579 return; 564 return;
580 } 565 }
581 #endif /* Unused */ 566 #endif /* Unused */
582 567
634 return imp == type || imp == type + 1; 619 return imp == type || imp == type + 1;
635 #endif 620 #endif
636 } 621 }
637 622
638 623
639 /**********************************************************************/ 624 /************************************************************************/
640 /* Debugger support */ 625 /* Debugger support */
641 /**********************************************************************/ 626 /************************************************************************/
642 /* Give gdb/dbx enough information to decode Lisp Objects. 627 /* Give gdb/dbx enough information to decode Lisp Objects.
643 We make sure certain symbols are defined, so gdb doesn't complain 628 We make sure certain symbols are defined, so gdb doesn't complain
644 about expressions in src/gdbinit. Values are randomly chosen. 629 about expressions in src/gdbinit. Values are randomly chosen.
645 See src/gdbinit or src/dbxrc to see how this is used. */ 630 See src/gdbinit or src/dbxrc to see how this is used. */
646 631
655 dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1), 640 dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
656 dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)), 641 dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
657 dbg_USE_MINIMAL_TAGBITS = 0, 642 dbg_USE_MINIMAL_TAGBITS = 0,
658 dbg_Lisp_Type_Int = Lisp_Type_Int, 643 dbg_Lisp_Type_Int = Lisp_Type_Int,
659 #endif /* ! USE_MIMIMAL_TAGBITS */ 644 #endif /* ! USE_MIMIMAL_TAGBITS */
645
646 #ifdef USE_UNION_TYPE
647 dbg_USE_UNION_TYPE = 1,
648 #else
649 dbg_USE_UNION_TYPE = 0,
650 #endif
651
660 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 652 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
661 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1, 653 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
662 #else 654 #else
663 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0, 655 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
664 #endif 656 #endif
657
665 dbg_Lisp_Type_Char = Lisp_Type_Char, 658 dbg_Lisp_Type_Char = Lisp_Type_Char,
666 dbg_Lisp_Type_Record = Lisp_Type_Record, 659 dbg_Lisp_Type_Record = Lisp_Type_Record,
667 #ifdef LRECORD_CONS 660 #ifdef LRECORD_CONS
668 dbg_Lisp_Type_Cons = 101, 661 dbg_Lisp_Type_Cons = 101,
669 #else 662 #else
707 dbg_gctypebits = GCTYPEBITS 700 dbg_gctypebits = GCTYPEBITS
708 /* If we don't have an actual object of this enum, pgcc (and perhaps 701 /* If we don't have an actual object of this enum, pgcc (and perhaps
709 other compilers) might optimize away the entire type declaration :-( */ 702 other compilers) might optimize away the entire type declaration :-( */
710 } dbg_dummy; 703 } dbg_dummy;
711 704
705 /* A few macros turned into functions for ease of debugging.
706 Debuggers don't know about macros! */
707 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
708 int
709 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
710 {
711 return EQ (obj1, obj2);
712 }
713
712 714
713 /**********************************************************************/ 715 /************************************************************************/
714 /* Fixed-size type macros */ 716 /* Fixed-size type macros */
715 /**********************************************************************/ 717 /************************************************************************/
716 718
717 /* For fixed-size types that are commonly used, we malloc() large blocks 719 /* For fixed-size types that are commonly used, we malloc() large blocks
718 of memory at a time and subdivide them into chunks of the correct 720 of memory at a time and subdivide them into chunks of the correct
719 size for an object of that type. This is more efficient than 721 size for an object of that type. This is more efficient than
720 malloc()ing each object separately because we save on malloc() time 722 malloc()ing each object separately because we save on malloc() time
892 # define TYPE_ALLOC_SIZE(type, structtype) \ 894 # define TYPE_ALLOC_SIZE(type, structtype) \
893 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ 895 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
894 / sizeof (structtype)) 896 / sizeof (structtype))
895 #endif /* ALLOC_NO_POOLS */ 897 #endif /* ALLOC_NO_POOLS */
896 898
897 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ 899 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
898 \ 900 \
899 struct type##_block \ 901 struct type##_block \
900 { \ 902 { \
901 struct type##_block *prev; \ 903 struct type##_block *prev; \
902 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ 904 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
903 }; \ 905 }; \
904 \ 906 \
905 static struct type##_block *current_##type##_block; \ 907 static struct type##_block *current_##type##_block; \
906 static int current_##type##_block_index; \ 908 static int current_##type##_block_index; \
907 \ 909 \
908 static structtype *type##_free_list; \ 910 static structtype *type##_free_list; \
909 static structtype *type##_free_list_tail; \ 911 static structtype *type##_free_list_tail; \
910 \ 912 \
911 static void \ 913 static void \
912 init_##type##_alloc (void) \ 914 init_##type##_alloc (void) \
913 { \ 915 { \
914 current_##type##_block = 0; \ 916 current_##type##_block = 0; \
915 current_##type##_block_index = countof (current_##type##_block->block); \ 917 current_##type##_block_index = \
916 type##_free_list = 0; \ 918 countof (current_##type##_block->block); \
917 type##_free_list_tail = 0; \ 919 type##_free_list = 0; \
918 } \ 920 type##_free_list_tail = 0; \
919 \ 921 } \
920 static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist 922 \
921 923 static int gc_count_num_##type##_in_use; \
922 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \ 924 static int gc_count_num_##type##_freelist
923 do { \ 925
924 if (current_##type##_block_index \ 926 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
925 == countof (current_##type##_block->block)) \ 927 if (current_##type##_block_index \
928 == countof (current_##type##_block->block)) \
926 { \ 929 { \
927 struct type##_block *__new__ = (struct type##_block *) \ 930 struct type##_block *AFTFB_new = (struct type##_block *) \
928 allocate_lisp_storage (sizeof (struct type##_block)); \ 931 allocate_lisp_storage (sizeof (struct type##_block)); \
929 __new__->prev = current_##type##_block; \ 932 AFTFB_new->prev = current_##type##_block; \
930 current_##type##_block = __new__; \ 933 current_##type##_block = AFTFB_new; \
931 current_##type##_block_index = 0; \ 934 current_##type##_block_index = 0; \
932 } \ 935 } \
933 (result) = \ 936 (result) = \
934 &(current_##type##_block->block[current_##type##_block_index++]); \ 937 &(current_##type##_block->block[current_##type##_block_index++]); \
935 } while (0) 938 } while (0)
936 939
937 /* Allocate an instance of a type that is stored in blocks. 940 /* Allocate an instance of a type that is stored in blocks.
938 TYPE is the "name" of the type, STRUCTTYPE is the corresponding 941 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
939 structure type. */ 942 structure type. */
940 943
1046 } while (0) 1049 } while (0)
1047 1050
1048 #else /* !ERROR_CHECK_GC */ 1051 #else /* !ERROR_CHECK_GC */
1049 1052
1050 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \ 1053 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1051 do { * (structtype **) ((char *) ptr + sizeof (void *)) = \ 1054 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
1052 type##_free_list; \ 1055 type##_free_list; \
1053 type##_free_list = ptr; \ 1056 type##_free_list = (ptr); \
1054 } while (0) 1057 } while (0)
1055 1058
1056 #endif /* !ERROR_CHECK_GC */ 1059 #endif /* !ERROR_CHECK_GC */
1057 1060
1058 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ 1061 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1059 1062
1060 #define FREE_FIXED_TYPE(type, structtype, ptr) \ 1063 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
1061 do { structtype *_weird_ = (ptr); \ 1064 structtype *FFT_ptr = (ptr); \
1062 ADDITIONAL_FREE_##type (_weird_); \ 1065 ADDITIONAL_FREE_##type (FFT_ptr); \
1063 deadbeef_memory (ptr, sizeof (structtype)); \ 1066 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
1064 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr); \ 1067 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
1065 MARK_STRUCT_AS_FREE (_weird_); \ 1068 MARK_STRUCT_AS_FREE (FFT_ptr); \
1066 } while (0) 1069 } while (0)
1067 1070
1068 /* Like FREE_FIXED_TYPE() but used when we are explicitly 1071 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1069 freeing a structure through free_cons(), free_marker(), etc. 1072 freeing a structure through free_cons(), free_marker(), etc.
1070 rather than through the normal process of sweeping. 1073 rather than through the normal process of sweeping.
1071 We attempt to undo the changes made to the allocation counters 1074 We attempt to undo the changes made to the allocation counters
1081 gc_count_num_##type##_freelist++; \ 1084 gc_count_num_##type##_freelist++; \
1082 } while (0) 1085 } while (0)
1083 1086
1084 1087
1085 1088
1086 /**********************************************************************/ 1089 /************************************************************************/
1087 /* Cons allocation */ 1090 /* Cons allocation */
1088 /**********************************************************************/ 1091 /************************************************************************/
1089 1092
1090 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); 1093 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1091 /* conses are used and freed so often that we set this really high */ 1094 /* conses are used and freed so often that we set this really high */
1092 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ 1095 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1093 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 1096 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1094 1097
1095 #ifdef LRECORD_CONS 1098 #ifdef LRECORD_CONS
1096 static Lisp_Object 1099 static Lisp_Object
1097 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1100 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1098 { 1101 {
1099 if (NILP (XCDR (obj))) 1102 if (GC_NILP (XCDR (obj)))
1100 return XCAR (obj); 1103 return XCAR (obj);
1101 1104
1102 (markobj) (XCAR (obj)); 1105 markobj (XCAR (obj));
1103 return XCDR (obj); 1106 return XCDR (obj);
1104 } 1107 }
1105 1108
1106 static int 1109 static int
1107 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) 1110 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1173 (int nargs, Lisp_Object *args)) 1176 (int nargs, Lisp_Object *args))
1174 { 1177 {
1175 Lisp_Object val = Qnil; 1178 Lisp_Object val = Qnil;
1176 Lisp_Object *argp = args + nargs; 1179 Lisp_Object *argp = args + nargs;
1177 1180
1178 while (nargs-- > 0) 1181 while (argp > args)
1179 val = Fcons (*--argp, val); 1182 val = Fcons (*--argp, val);
1180 return val; 1183 return val;
1181 } 1184 }
1182 1185
1183 Lisp_Object 1186 Lisp_Object
1253 return val; 1256 return val;
1254 } 1257 }
1255 } 1258 }
1256 1259
1257 1260
1258 /**********************************************************************/ 1261 /************************************************************************/
1259 /* Float allocation */ 1262 /* Float allocation */
1260 /**********************************************************************/ 1263 /************************************************************************/
1261 1264
1262 #ifdef LISP_FLOAT_TYPE 1265 #ifdef LISP_FLOAT_TYPE
1263 1266
1264 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float); 1267 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1265 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 1268 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1278 } 1281 }
1279 1282
1280 #endif /* LISP_FLOAT_TYPE */ 1283 #endif /* LISP_FLOAT_TYPE */
1281 1284
1282 1285
1283 /**********************************************************************/ 1286 /************************************************************************/
1284 /* Vector allocation */ 1287 /* Vector allocation */
1285 /**********************************************************************/ 1288 /************************************************************************/
1286 1289
1287 #ifdef LRECORD_VECTOR 1290 #ifdef LRECORD_VECTOR
1288 static Lisp_Object 1291 static Lisp_Object
1289 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1292 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1290 { 1293 {
1291 struct Lisp_Vector *ptr = XVECTOR (obj); 1294 Lisp_Vector *ptr = XVECTOR (obj);
1292 int len = vector_length (ptr); 1295 int len = vector_length (ptr);
1293 int i; 1296 int i;
1294 1297
1295 for (i = 0; i < len - 1; i++) 1298 for (i = 0; i < len - 1; i++)
1296 (markobj) (ptr->contents[i]); 1299 markobj (ptr->contents[i]);
1297 return (len > 0) ? ptr->contents[len - 1] : Qnil; 1300 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1298 } 1301 }
1299 1302
1300 static size_t 1303 static size_t
1301 size_vector (CONST void *lheader) 1304 size_vector (CONST void *lheader)
1302 { 1305 {
1303 /* * -1 because struct Lisp_Vector includes 1 slot */ 1306 return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
1304 return sizeof (struct Lisp_Vector) +
1305 ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object));
1306 } 1307 }
1307 1308
1308 static int 1309 static int
1309 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) 1310 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1310 { 1311 {
1311 int indice; 1312 int indice;
1312 int len = XVECTOR_LENGTH (o1); 1313 int len = XVECTOR_LENGTH (obj1);
1313 if (len != XVECTOR_LENGTH (o2)) 1314 if (len != XVECTOR_LENGTH (obj2))
1314 return 0; 1315 return 0;
1315 for (indice = 0; indice < len; indice++) 1316 for (indice = 0; indice < len; indice++)
1316 { 1317 {
1317 if (!internal_equal (XVECTOR_DATA (o1) [indice], 1318 if (!internal_equal (XVECTOR_DATA (obj1) [indice],
1318 XVECTOR_DATA (o2) [indice], 1319 XVECTOR_DATA (obj2) [indice],
1319 depth + 1)) 1320 depth + 1))
1320 return 0; 1321 return 0;
1321 } 1322 }
1322 return 1; 1323 return 1;
1323 } 1324 }
1329 * No `hash' method needed for 1330 * No `hash' method needed for
1330 * vectors. internal_hash 1331 * vectors. internal_hash
1331 * knows how to handle vectors. 1332 * knows how to handle vectors.
1332 */ 1333 */
1333 0, 1334 0,
1334 size_vector, struct Lisp_Vector); 1335 size_vector, Lisp_Vector);
1335 1336
1336 /* #### should allocate `small' vectors from a frob-block */ 1337 /* #### should allocate `small' vectors from a frob-block */
1337 static struct Lisp_Vector * 1338 static Lisp_Vector *
1338 make_vector_internal (size_t sizei) 1339 make_vector_internal (size_t sizei)
1339 { 1340 {
1340 size_t sizem = (sizeof (struct Lisp_Vector) 1341 /* no vector_next */
1341 /* -1 because struct Lisp_Vector includes 1 slot */ 1342 size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
1342 + (sizei - 1) * sizeof (Lisp_Object)); 1343 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1343 struct Lisp_Vector *p =
1344 (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1345 1344
1346 p->size = sizei; 1345 p->size = sizei;
1347 return p; 1346 return p;
1348 } 1347 }
1349 1348
1350 #else /* ! LRECORD_VECTOR */ 1349 #else /* ! LRECORD_VECTOR */
1351 1350
1352 static Lisp_Object all_vectors; 1351 static Lisp_Object all_vectors;
1353 1352
1354 /* #### should allocate `small' vectors from a frob-block */ 1353 /* #### should allocate `small' vectors from a frob-block */
1355 static struct Lisp_Vector * 1354 static Lisp_Vector *
1356 make_vector_internal (size_t sizei) 1355 make_vector_internal (size_t sizei)
1357 { 1356 {
1358 size_t sizem = (sizeof (struct Lisp_Vector) 1357 /* + 1 to account for vector_next */
1359 /* -1 because struct Lisp_Vector includes 1 slot, 1358 size_t sizem = offsetof (Lisp_Vector, contents[sizei+1]);
1360 * +1 to account for vector_next */ 1359 Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
1361 + (sizei - 1 + 1) * sizeof (Lisp_Object));
1362 struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem);
1363 1360
1364 INCREMENT_CONS_COUNTER (sizem, "vector"); 1361 INCREMENT_CONS_COUNTER (sizem, "vector");
1365 1362
1366 p->size = sizei; 1363 p->size = sizei;
1367 vector_next (p) = all_vectors; 1364 vector_next (p) = all_vectors;
1374 Lisp_Object 1371 Lisp_Object
1375 make_vector (EMACS_INT length, Lisp_Object init) 1372 make_vector (EMACS_INT length, Lisp_Object init)
1376 { 1373 {
1377 int elt; 1374 int elt;
1378 Lisp_Object vector; 1375 Lisp_Object vector;
1379 struct Lisp_Vector *p; 1376 Lisp_Vector *p;
1380 1377
1381 if (length < 0) 1378 if (length < 0)
1382 length = XINT (wrong_type_argument (Qnatnump, make_int (length))); 1379 length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1383 1380
1384 p = make_vector_internal (length); 1381 p = make_vector_internal (length);
1420 */ 1417 */
1421 (int nargs, Lisp_Object *args)) 1418 (int nargs, Lisp_Object *args))
1422 { 1419 {
1423 Lisp_Object vector; 1420 Lisp_Object vector;
1424 int elt; 1421 int elt;
1425 struct Lisp_Vector *p = make_vector_internal (nargs); 1422 Lisp_Vector *p = make_vector_internal (nargs);
1426 1423
1427 for (elt = 0; elt < nargs; elt++) 1424 for (elt = 0; elt < nargs; elt++)
1428 vector_data(p)[elt] = args[elt]; 1425 vector_data(p)[elt] = args[elt];
1429 1426
1430 XSETVECTOR (vector, p); 1427 XSETVECTOR (vector, p);
1529 args[7] = obj7; 1526 args[7] = obj7;
1530 return Fvector (8, args); 1527 return Fvector (8, args);
1531 } 1528 }
1532 #endif /* unused */ 1529 #endif /* unused */
1533 1530
1534 /**********************************************************************/ 1531 /************************************************************************/
1535 /* Bit Vector allocation */ 1532 /* Bit Vector allocation */
1536 /**********************************************************************/ 1533 /************************************************************************/
1537 1534
1538 static Lisp_Object all_bit_vectors; 1535 static Lisp_Object all_bit_vectors;
1539 1536
1540 /* #### should allocate `small' bit vectors from a frob-block */ 1537 /* #### should allocate `small' bit vectors from a frob-block */
1541 static struct Lisp_Bit_Vector * 1538 static struct Lisp_Bit_Vector *
1542 make_bit_vector_internal (size_t sizei) 1539 make_bit_vector_internal (size_t sizei)
1543 { 1540 {
1544 size_t sizem = sizeof (struct Lisp_Bit_Vector) + 1541 size_t sizem =
1545 /* -1 because struct Lisp_Bit_Vector includes 1 slot */ 1542 offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (sizei)]);
1546 sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1); 1543 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1547 struct Lisp_Bit_Vector *p =
1548 (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1549 set_lheader_implementation (&(p->lheader), lrecord_bit_vector); 1544 set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1550 1545
1551 INCREMENT_CONS_COUNTER (sizem, "bit-vector"); 1546 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1552 1547
1553 bit_vector_length (p) = sizei; 1548 bit_vector_length (p) = sizei;
1554 bit_vector_next (p) = all_bit_vectors; 1549 bit_vector_next (p) = all_bit_vectors;
1555 /* make sure the extra bits in the last long are 0; the calling 1550 /* make sure the extra bits in the last long are 0; the calling
1556 functions might not set them. */ 1551 functions might not set them. */
1557 p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0; 1552 p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0;
1558 XSETBIT_VECTOR (all_bit_vectors, p); 1553 XSETBIT_VECTOR (all_bit_vectors, p);
1559 return p; 1554 return p;
1638 XSETBIT_VECTOR (bit_vector, p); 1633 XSETBIT_VECTOR (bit_vector, p);
1639 return bit_vector; 1634 return bit_vector;
1640 } 1635 }
1641 1636
1642 1637
1643 /**********************************************************************/ 1638 /************************************************************************/
1644 /* Compiled-function allocation */ 1639 /* Compiled-function allocation */
1645 /**********************************************************************/ 1640 /************************************************************************/
1646 1641
1647 DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function); 1642 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 1643 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1649 1644
1650 static Lisp_Object 1645 static Lisp_Object
1651 make_compiled_function (int make_pure) 1646 make_compiled_function (int make_pure)
1652 { 1647 {
1653 struct Lisp_Compiled_Function *b; 1648 Lisp_Compiled_Function *f;
1654 Lisp_Object new; 1649 Lisp_Object fun;
1655 size_t size = sizeof (struct Lisp_Compiled_Function); 1650 size_t size = sizeof (Lisp_Compiled_Function);
1656 1651
1657 if (make_pure && check_purespace (size)) 1652 if (make_pure && check_purespace (size))
1658 { 1653 {
1659 b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used); 1654 f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1660 set_lheader_implementation (&(b->lheader), lrecord_compiled_function); 1655 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1661 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 1656 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1662 b->lheader.pure = 1; 1657 f->lheader.pure = 1;
1663 #endif 1658 #endif
1664 pure_bytes_used += size; 1659 pure_bytes_used += size;
1665 bump_purestat (&purestat_bytecode, size); 1660 bump_purestat (&purestat_function, size);
1666 } 1661 }
1667 else 1662 else
1668 { 1663 {
1669 ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function, 1664 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1670 b); 1665 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1671 set_lheader_implementation (&(b->lheader), lrecord_compiled_function); 1666 }
1672 } 1667 f->stack_depth = 0;
1673 b->maxdepth = 0; 1668 f->specpdl_depth = 0;
1674 b->flags.documentationp = 0; 1669 f->flags.documentationp = 0;
1675 b->flags.interactivep = 0; 1670 f->flags.interactivep = 0;
1676 b->flags.domainp = 0; /* I18N3 */ 1671 f->flags.domainp = 0; /* I18N3 */
1677 b->bytecodes = Qzero; 1672 f->instructions = Qzero;
1678 b->constants = Qzero; 1673 f->constants = Qzero;
1679 b->arglist = Qnil; 1674 f->arglist = Qnil;
1680 b->doc_and_interactive = Qnil; 1675 f->doc_and_interactive = Qnil;
1681 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1676 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1682 b->annotated = Qnil; 1677 f->annotated = Qnil;
1683 #endif 1678 #endif
1684 XSETCOMPILED_FUNCTION (new, b); 1679 XSETCOMPILED_FUNCTION (fun, f);
1685 return new; 1680 return fun;
1686 } 1681 }
1687 1682
1688 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* 1683 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1689 Return a new compiled-function object. 1684 Return a new compiled-function object.
1690 Usage: (arglist instructions constants stack-size 1685 Usage: (arglist instructions constants stack-depth
1691 &optional doc-string interactive-spec) 1686 &optional doc-string interactive)
1692 Note that, unlike all other emacs-lisp functions, calling this with five 1687 Note that, unlike all other emacs-lisp functions, calling this with five
1693 arguments is NOT the same as calling it with six arguments, the last of 1688 arguments is NOT the same as calling it with six arguments, the last of
1694 which is nil. If the INTERACTIVE arg is specified as nil, then that means 1689 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1695 that this function was defined with `(interactive)'. If the arg is not 1690 that this function was defined with `(interactive)'. If the arg is not
1696 specified, then that means the function is not interactive. 1691 specified, then that means the function is not interactive.
1697 This is terrible behavior which is retained for compatibility with old 1692 This is terrible behavior which is retained for compatibility with old
1698 `.elc' files which expected these semantics. 1693 `.elc' files which expect these semantics.
1699 */ 1694 */
1700 (int nargs, Lisp_Object *args)) 1695 (int nargs, Lisp_Object *args))
1701 { 1696 {
1702 /* In a non-insane world this function would have this arglist... 1697 /* In a non-insane world this function would have this arglist...
1703 (arglist, instructions, constants, stack_size, doc_string, interactive) 1698 (arglist instructions constants stack_depth &optional doc_string interactive)
1704 Lisp_Object arglist, instructions, constants, stack_size, doc_string,
1705 interactive;
1706 */ 1699 */
1700 Lisp_Object fun = make_compiled_function (purify_flag);
1701 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1702
1707 Lisp_Object arglist = args[0]; 1703 Lisp_Object arglist = args[0];
1708 Lisp_Object instructions = args[1]; 1704 Lisp_Object instructions = args[1];
1709 Lisp_Object constants = args[2]; 1705 Lisp_Object constants = args[2];
1710 Lisp_Object stack_size = args[3]; 1706 Lisp_Object stack_depth = args[3];
1711 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; 1707 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1712 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; 1708 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1709
1713 /* Don't purecopy the doc references in instructions because it's 1710 /* Don't purecopy the doc references in instructions because it's
1714 wasteful; they will get fixed up later. 1711 wasteful; they will get fixed up later.
1715 1712
1716 #### If something goes wrong and they don't get fixed up, 1713 #### If something goes wrong and they don't get fixed up,
1717 we're screwed, because pure stuff isn't marked and thus the 1714 we're screwed, because pure stuff isn't marked and thus the
1718 cons references won't be marked and will get reused. 1715 cons references won't be marked and will get reused.
1719 1716
1720 Note: there will be a window after the byte code is created and 1717 Note: there will be a window after the byte code is created and
1721 before the doc references are fixed up in which there will be 1718 before the doc references are fixed up in which there will be
1722 impure objects inside a pure object, which apparently won't 1719 impure objects inside a pure object, which apparently won't
1723 get marked, leading the trouble. But during that entire window, 1720 get marked, leading to trouble. But during that entire window,
1724 the objects are sitting on Vload_force_doc_string_list, which 1721 the objects are sitting on Vload_force_doc_string_list, which
1725 is staticpro'd, so we're OK. */ 1722 is staticpro'd, so we're OK. */
1726 int purecopy_instructions = 1; 1723 Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
1727 1724 = purify_flag ? pure_cons : Fcons;
1728 if (nargs > 6) 1725
1726 if (nargs < 4 || nargs > 6)
1729 return Fsignal (Qwrong_number_of_arguments, 1727 return Fsignal (Qwrong_number_of_arguments,
1730 list2 (intern ("make-byte-code"), make_int (nargs))); 1728 list2 (intern ("make-byte-code"), make_int (nargs)));
1731 1729
1732 CHECK_LIST (arglist); 1730 /* Check for valid formal parameter list now, to allow us to use
1733 /* instructions is a string or a cons (string . int) for a 1731 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1732 {
1733 Lisp_Object symbol, tail;
1734 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1735 {
1736 CHECK_SYMBOL (symbol);
1737 if (EQ (symbol, Qt) ||
1738 EQ (symbol, Qnil) ||
1739 SYMBOL_IS_KEYWORD (symbol))
1740 signal_simple_error_2
1741 ("Invalid constant symbol in formal parameter list",
1742 symbol, arglist);
1743 }
1744 }
1745 f->arglist = arglist;
1746
1747 /* `instructions' is a string or a cons (string . int) for a
1734 lazy-loaded function. */ 1748 lazy-loaded function. */
1735 if (CONSP (instructions)) 1749 if (CONSP (instructions))
1736 { 1750 {
1737 CHECK_STRING (XCAR (instructions)); 1751 CHECK_STRING (XCAR (instructions));
1738 CHECK_INT (XCDR (instructions)); 1752 CHECK_INT (XCDR (instructions));
1739 if (!NILP (constants))
1740 CHECK_VECTOR (constants);
1741 purecopy_instructions = 0;
1742 } 1753 }
1743 else 1754 else
1744 { 1755 {
1745 CHECK_STRING (instructions); 1756 CHECK_STRING (instructions);
1746 CHECK_VECTOR (constants); 1757 }
1747 } 1758 f->instructions = instructions;
1748 CHECK_NATNUM (stack_size); 1759
1749 /* doc_string may be nil, string, int, or a cons (string . int). */ 1760 if (!NILP (constants))
1750 1761 CHECK_VECTOR (constants);
1751 /* interactive may be list or string (or unbound). */ 1762 f->constants = constants;
1763
1764 CHECK_NATNUM (stack_depth);
1765 f->stack_depth = XINT (stack_depth);
1766
1767 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1768 if (!NILP (Vcurrent_compiled_function_annotation))
1769 f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1770 else if (!NILP (Vload_file_name_internal_the_purecopy))
1771 f->annotated = Vload_file_name_internal_the_purecopy;
1772 else if (!NILP (Vload_file_name_internal))
1773 {
1774 struct gcpro gcpro1;
1775 GCPRO1 (fun); /* don't let fun get reaped */
1776 Vload_file_name_internal_the_purecopy =
1777 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1778 f->annotated = Vload_file_name_internal_the_purecopy;
1779 UNGCPRO;
1780 }
1781 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1782
1783 /* doc_string may be nil, string, int, or a cons (string . int).
1784 interactive may be list or string (or unbound). */
1785 f->doc_and_interactive = Qunbound;
1786 #ifdef I18N3
1787 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1788 f->doc_and_interactive = Vfile_domain;
1789 #endif
1790 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1791 {
1792 if (purify_flag)
1793 {
1794 interactive = Fpurecopy (interactive);
1795 if (STRINGP (interactive))
1796 bump_purestat (&purestat_string_interactive,
1797 pure_sizeof (interactive));
1798 }
1799 f->doc_and_interactive
1800 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1801 cons (interactive, f->doc_and_interactive));
1802 }
1803 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1804 {
1805 if (purify_flag)
1806 {
1807 doc_string = Fpurecopy (doc_string);
1808 if (STRINGP (doc_string))
1809 /* These should have been snagged by make-docfile... */
1810 bump_purestat (&purestat_string_documentation,
1811 pure_sizeof (doc_string));
1812 }
1813 f->doc_and_interactive
1814 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1815 cons (doc_string, f->doc_and_interactive));
1816 }
1817 if (UNBOUNDP (f->doc_and_interactive))
1818 f->doc_and_interactive = Qnil;
1752 1819
1753 if (purify_flag) 1820 if (purify_flag)
1754 { 1821 {
1755 if (!purified (arglist)) 1822
1756 arglist = Fpurecopy (arglist); 1823 if (!purified (f->arglist))
1757 if (purecopy_instructions && !purified (instructions)) 1824 f->arglist = Fpurecopy (f->arglist);
1758 instructions = Fpurecopy (instructions);
1759 if (!purified (doc_string))
1760 doc_string = Fpurecopy (doc_string);
1761 if (!purified (interactive) && !UNBOUNDP (interactive))
1762 interactive = Fpurecopy (interactive);
1763 1825
1764 /* Statistics are kept differently for the constants */ 1826 /* Statistics are kept differently for the constants */
1765 if (!purified (constants)) 1827 if (!purified (f->constants))
1828 {
1766 #ifdef PURESTAT 1829 #ifdef PURESTAT
1767 { 1830 int old = purecopying_function_constants;
1768 int old = purecopying_for_bytecode; 1831 purecopying_function_constants = 1;
1769 purecopying_for_bytecode = 1; 1832 f->constants = Fpurecopy (f->constants);
1770 constants = Fpurecopy (constants); 1833 bump_purestat (&purestat_vector_constants,
1771 purecopying_for_bytecode = old; 1834 pure_sizeof (f->constants));
1835 purecopying_function_constants = old;
1836 #else
1837 f->constants = Fpurecopy (f->constants);
1838 #endif /* PURESTAT */
1772 } 1839 }
1773 #else 1840
1774 constants = Fpurecopy (constants); 1841 optimize_compiled_function (fun);
1775 #endif /* PURESTAT */ 1842
1776 1843 bump_purestat (&purestat_opaque_instructions,
1777 #ifdef PURESTAT 1844 pure_sizeof (f->instructions));
1778 if (STRINGP (instructions)) 1845 }
1779 bump_purestat (&purestat_string_bytecodes, pure_sizeof (instructions)); 1846
1780 if (VECTORP (constants)) 1847 return fun;
1781 bump_purestat (&purestat_vector_bytecode_constants,
1782 pure_sizeof (constants));
1783 if (STRINGP (doc_string))
1784 /* These should be have been snagged by make-docfile... */
1785 bump_purestat (&purestat_string_documentation,
1786 pure_sizeof (doc_string));
1787 if (STRINGP (interactive))
1788 bump_purestat (&purestat_string_interactive,
1789 pure_sizeof (interactive));
1790 #endif /* PURESTAT */
1791 }
1792
1793 {
1794 int docp = !NILP (doc_string);
1795 int intp = !UNBOUNDP (interactive);
1796 #ifdef I18N3
1797 int domp = !NILP (Vfile_domain);
1798 #endif
1799 Lisp_Object val = make_compiled_function (purify_flag);
1800 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (val);
1801 b->flags.documentationp = docp;
1802 b->flags.interactivep = intp;
1803 #ifdef I18N3
1804 b->flags.domainp = domp;
1805 #endif
1806 b->maxdepth = XINT (stack_size);
1807 b->bytecodes = instructions;
1808 b->constants = constants;
1809 b->arglist = arglist;
1810 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1811 if (!NILP (Vcurrent_compiled_function_annotation))
1812 b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1813 else if (!NILP (Vload_file_name_internal_the_purecopy))
1814 b->annotated = Vload_file_name_internal_the_purecopy;
1815 else if (!NILP (Vload_file_name_internal))
1816 {
1817 struct gcpro gcpro1;
1818 GCPRO1(val); /* don't let val or b get reaped */
1819 Vload_file_name_internal_the_purecopy =
1820 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1821 b->annotated = Vload_file_name_internal_the_purecopy;
1822 UNGCPRO;
1823 }
1824 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1825
1826 #ifdef I18N3
1827 if (docp && intp && domp)
1828 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1829 (doc_string,
1830 (((purify_flag) ? pure_cons : Fcons)
1831 (interactive, Vfile_domain))));
1832 else if (docp && domp)
1833 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1834 (doc_string, Vfile_domain));
1835 else if (intp && domp)
1836 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1837 (interactive, Vfile_domain));
1838 else
1839 #endif
1840 if (docp && intp)
1841 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1842 (doc_string, interactive));
1843 else if (intp)
1844 b->doc_and_interactive = interactive;
1845 #ifdef I18N3
1846 else if (domp)
1847 b->doc_and_interactive = Vfile_domain;
1848 #endif
1849 else
1850 b->doc_and_interactive = doc_string;
1851
1852 return val;
1853 }
1854 } 1848 }
1855 1849
1856 1850
1857 /**********************************************************************/ 1851 /************************************************************************/
1858 /* Symbol allocation */ 1852 /* Symbol allocation */
1859 /**********************************************************************/ 1853 /************************************************************************/
1860 1854
1861 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol); 1855 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1862 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 1856 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1863 1857
1864 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* 1858 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1865 Return a newly allocated uninterned symbol whose name is NAME. 1859 Return a newly allocated uninterned symbol whose name is NAME.
1866 Its value and function definition are void, and its property list is nil. 1860 Its value and function definition are void, and its property list is nil.
1867 */ 1861 */
1868 (str)) 1862 (name))
1869 { 1863 {
1870 Lisp_Object val; 1864 Lisp_Object val;
1871 struct Lisp_Symbol *p; 1865 struct Lisp_Symbol *p;
1872 1866
1873 CHECK_STRING (str); 1867 CHECK_STRING (name);
1874 1868
1875 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p); 1869 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1876 #ifdef LRECORD_SYMBOL 1870 #ifdef LRECORD_SYMBOL
1877 set_lheader_implementation (&(p->lheader), lrecord_symbol); 1871 set_lheader_implementation (&(p->lheader), lrecord_symbol);
1878 #endif 1872 #endif
1879 p->name = XSTRING (str); 1873 p->name = XSTRING (name);
1880 p->plist = Qnil; 1874 p->plist = Qnil;
1881 p->value = Qunbound; 1875 p->value = Qunbound;
1882 p->function = Qunbound; 1876 p->function = Qunbound;
1883 p->obarray = Qnil; 1877 p->obarray = Qnil;
1884 symbol_next (p) = 0; 1878 symbol_next (p) = 0;
1885 XSETSYMBOL (val, p); 1879 XSETSYMBOL (val, p);
1886 return val; 1880 return val;
1887 } 1881 }
1888 1882
1889 1883
1890 /**********************************************************************/ 1884 /************************************************************************/
1891 /* Extent allocation */ 1885 /* Extent allocation */
1892 /**********************************************************************/ 1886 /************************************************************************/
1893 1887
1894 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); 1888 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1895 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 1889 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1896 1890
1897 struct extent * 1891 struct extent *
1898 allocate_extent (void) 1892 allocate_extent (void)
1899 { 1893 {
1900 struct extent *e; 1894 struct extent *e;
1901 1895
1902 ALLOCATE_FIXED_TYPE (extent, struct extent, e); 1896 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1903 /* xzero (*e); */
1904 set_lheader_implementation (&(e->lheader), lrecord_extent); 1897 set_lheader_implementation (&(e->lheader), lrecord_extent);
1905 extent_object (e) = Qnil; 1898 extent_object (e) = Qnil;
1906 set_extent_start (e, -1); 1899 set_extent_start (e, -1);
1907 set_extent_end (e, -1); 1900 set_extent_end (e, -1);
1908 e->plist = Qnil; 1901 e->plist = Qnil;
1915 1908
1916 return e; 1909 return e;
1917 } 1910 }
1918 1911
1919 1912
1920 /**********************************************************************/ 1913 /************************************************************************/
1921 /* Event allocation */ 1914 /* Event allocation */
1922 /**********************************************************************/ 1915 /************************************************************************/
1923 1916
1924 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event); 1917 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1925 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 1918 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1926 1919
1927 Lisp_Object 1920 Lisp_Object
1936 XSETEVENT (val, e); 1929 XSETEVENT (val, e);
1937 return val; 1930 return val;
1938 } 1931 }
1939 1932
1940 1933
1941 /**********************************************************************/ 1934 /************************************************************************/
1942 /* Marker allocation */ 1935 /* Marker allocation */
1943 /**********************************************************************/ 1936 /************************************************************************/
1944 1937
1945 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker); 1938 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1946 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 1939 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1947 1940
1948 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* 1941 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1980 XSETMARKER (val, p); 1973 XSETMARKER (val, p);
1981 return val; 1974 return val;
1982 } 1975 }
1983 1976
1984 1977
1985 /**********************************************************************/ 1978 /************************************************************************/
1986 /* String allocation */ 1979 /* String allocation */
1987 /**********************************************************************/ 1980 /************************************************************************/
1988 1981
1989 /* The data for "short" strings generally resides inside of structs of type 1982 /* The data for "short" strings generally resides inside of structs of type
1990 string_chars_block. The Lisp_String structure is allocated just like any 1983 string_chars_block. The Lisp_String structure is allocated just like any
1991 other Lisp object (except for vectors), and these are freelisted when 1984 other Lisp object (except for vectors), and these are freelisted when
1992 they get garbage collected. The data for short strings get compacted, 1985 they get garbage collected. The data for short strings get compacted,
2014 flush_cached_extent_info (XCAR (ptr->plist)); 2007 flush_cached_extent_info (XCAR (ptr->plist));
2015 return ptr->plist; 2008 return ptr->plist;
2016 } 2009 }
2017 2010
2018 static int 2011 static int
2019 string_equal (Lisp_Object o1, Lisp_Object o2, int depth) 2012 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2020 { 2013 {
2021 Bytecount len; 2014 Bytecount len;
2022 return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && 2015 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2023 !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); 2016 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2024 } 2017 }
2025 2018
2026 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, 2019 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2027 mark_string, print_string, 2020 mark_string, print_string,
2028 /* 2021 /*
2333 Return a new string of length LENGTH, with each character being INIT. 2326 Return a new string of length LENGTH, with each character being INIT.
2334 LENGTH must be an integer and INIT must be a character. 2327 LENGTH must be an integer and INIT must be a character.
2335 */ 2328 */
2336 (length, init)) 2329 (length, init))
2337 { 2330 {
2338 Lisp_Object val;
2339
2340 CHECK_NATNUM (length); 2331 CHECK_NATNUM (length);
2341 CHECK_CHAR_COERCE_INT (init); 2332 CHECK_CHAR_COERCE_INT (init);
2342 { 2333 {
2343 Bufbyte str[MAX_EMCHAR_LEN]; 2334 Bufbyte init_str[MAX_EMCHAR_LEN];
2344 int len = set_charptr_emchar (str, XCHAR (init)); 2335 int len = set_charptr_emchar (init_str, XCHAR (init));
2345 2336 Lisp_Object val = make_uninit_string (len * XINT (length));
2346 val = make_uninit_string (len * XINT (length)); 2337
2347 if (len == 1) 2338 if (len == 1)
2348 /* Optimize the single-byte case */ 2339 /* Optimize the single-byte case */
2349 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val)); 2340 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2350 else 2341 else
2351 { 2342 {
2352 int i, j, k; 2343 int i;
2353 Bufbyte *ptr = XSTRING_DATA (val); 2344 Bufbyte *ptr = XSTRING_DATA (val);
2354 2345
2355 k = 0; 2346 for (i = XINT (length); i; i--)
2356 for (i = 0; i < XINT (length); i++) 2347 {
2357 for (j = 0; j < len; j++) 2348 Bufbyte *init_ptr = init_str;
2358 ptr[k++] = str[j]; 2349 switch (len)
2350 {
2351 case 4: *ptr++ = *init_ptr++;
2352 case 3: *ptr++ = *init_ptr++;
2353 case 2: *ptr++ = *init_ptr++;
2354 case 1: *ptr++ = *init_ptr++;
2355 }
2356 }
2359 } 2357 }
2358 return val;
2360 } 2359 }
2361 return val;
2362 } 2360 }
2363 2361
2364 DEFUN ("string", Fstring, 0, MANY, 0, /* 2362 DEFUN ("string", Fstring, 0, MANY, 0, /*
2365 Concatenate all the argument characters and make the result a string. 2363 Concatenate all the argument characters and make the result a string.
2366 */ 2364 */
2570 2568
2571 #ifdef ERROR_CHECK_GC 2569 #ifdef ERROR_CHECK_GC
2572 /* Make sure the size is correct. This will catch, for example, 2570 /* Make sure the size is correct. This will catch, for example,
2573 putting a window configuration on the wrong free list. */ 2571 putting a window configuration on the wrong free list. */
2574 if (implementation->size_in_bytes_method) 2572 if (implementation->size_in_bytes_method)
2575 assert (((implementation->size_in_bytes_method) (lheader)) 2573 assert (implementation->size_in_bytes_method (lheader) == list->size);
2576 == list->size);
2577 else 2574 else
2578 assert (implementation->static_size == list->size); 2575 assert (implementation->static_size == list->size);
2579 #endif /* ERROR_CHECK_GC */ 2576 #endif /* ERROR_CHECK_GC */
2580 2577
2581 if (implementation->finalizer) 2578 if (implementation->finalizer)
2582 ((implementation->finalizer) (lheader, 0)); 2579 implementation->finalizer (lheader, 0);
2583 free_header->chain = list->free; 2580 free_header->chain = list->free;
2584 free_header->lcheader.free = 1; 2581 free_header->lcheader.free = 1;
2585 list->free = lcrecord; 2582 list->free = lcrecord;
2586 } 2583 }
2587 2584
2588 2585
2589 /**********************************************************************/ 2586 /************************************************************************/
2590 /* Purity of essence, peace on earth */ 2587 /* Purity of essence, peace on earth */
2591 /**********************************************************************/ 2588 /************************************************************************/
2592 2589
2593 static int symbols_initialized; 2590 static int symbols_initialized;
2594 2591
2595 Lisp_Object 2592 Lisp_Object
2596 make_pure_string (CONST Bufbyte *data, Bytecount length, 2593 make_pure_string (CONST Bufbyte *data, Bytecount length,
2639 s->plist = Qnil; 2636 s->plist = Qnil;
2640 pure_bytes_used += size; 2637 pure_bytes_used += size;
2641 2638
2642 #ifdef PURESTAT 2639 #ifdef PURESTAT
2643 bump_purestat (&purestat_string_all, size); 2640 bump_purestat (&purestat_string_all, size);
2644 if (purecopying_for_bytecode) 2641 if (purecopying_function_constants)
2645 bump_purestat (&purestat_string_other_function, size); 2642 bump_purestat (&purestat_string_other_function, size);
2646 #endif /* PURESTAT */ 2643 #endif /* PURESTAT */
2647 2644
2648 /* Do this after the official "completion" of the purecopying. */ 2645 /* Do this after the official "completion" of the purecopying. */
2649 s->plist = Fpurecopy (plist); 2646 s->plist = Fpurecopy (plist);
2758 2755
2759 Lisp_Object 2756 Lisp_Object
2760 make_pure_vector (size_t len, Lisp_Object init) 2757 make_pure_vector (size_t len, Lisp_Object init)
2761 { 2758 {
2762 Lisp_Object new; 2759 Lisp_Object new;
2763 struct Lisp_Vector *v; 2760 Lisp_Vector *v;
2764 size_t size = (sizeof (struct Lisp_Vector) 2761 size_t size = offsetof (Lisp_Vector, contents[len]);
2765 + (len - 1) * sizeof (Lisp_Object));
2766 2762
2767 init = Fpurecopy (init); 2763 init = Fpurecopy (init);
2768 2764
2769 if (!check_purespace (size)) 2765 if (!check_purespace (size))
2770 return make_vector (len, init); 2766 return make_vector (len, init);
2771 2767
2772 v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used); 2768 v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
2773 #ifdef LRECORD_VECTOR 2769 #ifdef LRECORD_VECTOR
2774 set_lheader_implementation (&(v->header.lheader), lrecord_vector); 2770 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2775 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION 2771 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2776 v->header.lheader.pure = 1; 2772 v->header.lheader.pure = 1;
2777 #endif 2773 #endif
2811 Recursively copies contents of vectors and cons cells. 2807 Recursively copies contents of vectors and cons cells.
2812 Does not copy symbols. 2808 Does not copy symbols.
2813 */ 2809 */
2814 (obj)) 2810 (obj))
2815 { 2811 {
2816 int i;
2817 if (!purify_flag) 2812 if (!purify_flag)
2818 return obj; 2813 {
2819 2814 return obj;
2820 if (!POINTER_TYPE_P (XTYPE (obj)) 2815 }
2821 || PURIFIED (XPNTR (obj)) 2816 else if (!POINTER_TYPE_P (XTYPE (obj))
2822 /* happens when bootstrapping Qnil */ 2817 || PURIFIED (XPNTR (obj))
2823 || EQ (obj, Qnull_pointer)) 2818 /* happens when bootstrapping Qnil */
2824 return obj; 2819 || EQ (obj, Qnull_pointer))
2825 2820 {
2826 switch (XTYPE (obj)) 2821 return obj;
2827 { 2822 }
2828 #ifndef LRECORD_CONS 2823 /* Order of subsequent tests determined via profiling. */
2829 case Lisp_Type_Cons: 2824 else if (SYMBOLP (obj))
2825 {
2826 /* Symbols can't be made pure (and thus read-only), because
2827 assigning to their function, value or plist slots would
2828 produced a SEGV in the dumped XEmacs. So we previously would
2829 just return the symbol unchanged.
2830
2831 But purified aggregate objects like lists and vectors can
2832 contain uninterned symbols. If there are no other non-pure
2833 references to the symbol, then the symbol is not protected
2834 from garbage collection because the collector does not mark
2835 the contents of purified objects. So to protect the symbols,
2836 an impure reference has to be kept for each uninterned symbol
2837 that is referenced by a pure object. All such symbols are
2838 stored in the hash table pointed to by
2839 Vpure_uninterned_symbol_table, which is itself
2840 staticpro'd. */
2841 if (NILP (XSYMBOL (obj)->obarray))
2842 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2843 return obj;
2844 }
2845 else if (CONSP (obj))
2846 {
2830 return pure_cons (XCAR (obj), XCDR (obj)); 2847 return pure_cons (XCAR (obj), XCDR (obj));
2831 #endif 2848 }
2832 2849 else if (STRINGP (obj))
2833 #ifndef LRECORD_STRING 2850 {
2834 case Lisp_Type_String:
2835 return make_pure_string (XSTRING_DATA (obj), 2851 return make_pure_string (XSTRING_DATA (obj),
2836 XSTRING_LENGTH (obj), 2852 XSTRING_LENGTH (obj),
2837 XSTRING (obj)->plist, 2853 XSTRING (obj)->plist,
2838 0); 2854 0);
2839 #endif /* ! LRECORD_STRING */ 2855 }
2840 2856 else if (VECTORP (obj))
2841 #ifndef LRECORD_VECTOR 2857 {
2842 case Lisp_Type_Vector: 2858 int i;
2843 { 2859 Lisp_Vector *o = XVECTOR (obj);
2844 struct Lisp_Vector *o = XVECTOR (obj); 2860 Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
2845 Lisp_Object new = make_pure_vector (vector_length (o), Qnil); 2861 for (i = 0; i < vector_length (o); i++)
2846 for (i = 0; i < vector_length (o); i++) 2862 XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
2847 XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]); 2863 return pure_obj;
2848 return new; 2864 }
2849 }
2850 #endif /* !LRECORD_VECTOR */
2851
2852 default:
2853 {
2854 if (COMPILED_FUNCTIONP (obj))
2855 {
2856 struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2857 Lisp_Object new = make_compiled_function (1);
2858 /* How on earth could this code have worked before? -sb */
2859 struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new);
2860 n->flags = o->flags;
2861 n->bytecodes = Fpurecopy (o->bytecodes);
2862 n->constants = Fpurecopy (o->constants);
2863 n->arglist = Fpurecopy (o->arglist);
2864 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2865 n->maxdepth = o->maxdepth;
2866 return new;
2867 }
2868 #ifdef LRECORD_CONS
2869 else if (CONSP (obj))
2870 return pure_cons (XCAR (obj), XCDR (obj));
2871 #endif /* LRECORD_CONS */
2872 #ifdef LRECORD_VECTOR
2873 else if (VECTORP (obj))
2874 {
2875 struct Lisp_Vector *o = XVECTOR (obj);
2876 Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2877 for (i = 0; i < vector_length (o); i++)
2878 XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2879 return new;
2880 }
2881 #endif /* LRECORD_VECTOR */
2882 #ifdef LRECORD_STRING
2883 else if (STRINGP (obj))
2884 {
2885 return make_pure_string (XSTRING_DATA (obj),
2886 XSTRING_LENGTH (obj),
2887 XSTRING (obj)->plist,
2888 0);
2889 }
2890 #endif /* LRECORD_STRING */
2891 #ifdef LISP_FLOAT_TYPE 2865 #ifdef LISP_FLOAT_TYPE
2892 else if (FLOATP (obj)) 2866 else if (FLOATP (obj))
2893 return make_pure_float (float_data (XFLOAT (obj))); 2867 {
2894 #endif /* LISP_FLOAT_TYPE */ 2868 return make_pure_float (XFLOAT_DATA (obj));
2895 else if (SYMBOLP (obj)) 2869 }
2896 { 2870 #endif
2897 /* 2871 else if (COMPILED_FUNCTIONP (obj))
2898 * Symbols can't be made pure (and thus read-only), 2872 {
2899 * because assigning to their function, value or plist 2873 Lisp_Object pure_obj = make_compiled_function (1);
2900 * slots would produced a SEGV in the dumped XEmacs. So 2874 Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2901 * we previously would just return the symbol unchanged. 2875 Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
2902 * 2876 n->flags = o->flags;
2903 * But purified aggregate objects like lists and vectors 2877 n->instructions = o->instructions;
2904 * can contain uninterned symbols. If there are no 2878 n->constants = Fpurecopy (o->constants);
2905 * other non-pure references to the symbol, then the 2879 n->arglist = Fpurecopy (o->arglist);
2906 * symbol is not protected from garbage collection 2880 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2907 * because the collector does not mark the contents of 2881 n->stack_depth = o->stack_depth;
2908 * purified objects. So to protect the symbols, an impure 2882 optimize_compiled_function (pure_obj);
2909 * reference has to be kept for each uninterned symbol 2883 return pure_obj;
2910 * that is referenced by a pure object. All such 2884 }
2911 * symbols are stored in the hashtable pointed to by 2885 else if (OPAQUEP (obj))
2912 * Vpure_uninterned_symbol_table, which is itself 2886 {
2913 * staticpro'd. 2887 Lisp_Object pure_obj;
2914 */ 2888 Lisp_Opaque *old_opaque = XOPAQUE (obj);
2915 if (!NILP (XSYMBOL (obj)->obarray)) 2889 Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
2916 return obj; 2890 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2917 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table); 2891 CONST struct lrecord_implementation *implementation
2918 return obj; 2892 = LHEADER_IMPLEMENTATION (lheader);
2919 } 2893 size_t size = implementation->size_in_bytes_method (lheader);
2920 else 2894 size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2921 signal_simple_error ("Can't purecopy %S", obj); 2895 if (!check_purespace (pure_size))
2922 } 2896 return obj;
2923 } 2897 pure_bytes_used += pure_size;
2924 return obj; 2898
2899 memcpy (new_opaque, old_opaque, size);
2900 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2901 lheader->pure = 1;
2902 #endif
2903 new_opaque->header.next = 0;
2904
2905 XSETOPAQUE (pure_obj, new_opaque);
2906 return pure_obj;
2907 }
2908 else
2909 {
2910 signal_simple_error ("Can't purecopy %S", obj);
2911 }
2912 return obj; /* Unreached */
2925 } 2913 }
2926 2914
2927 2915
2928 2916
2929 static void 2917 static void
2997 2985
2998 #ifdef PURESTAT 2986 #ifdef PURESTAT
2999 2987
3000 purestat_vector_other.nbytes = 2988 purestat_vector_other.nbytes =
3001 purestat_vector_all.nbytes - 2989 purestat_vector_all.nbytes -
3002 purestat_vector_bytecode_constants.nbytes; 2990 purestat_vector_constants.nbytes;
3003 purestat_vector_other.nobjects = 2991 purestat_vector_other.nobjects =
3004 purestat_vector_all.nobjects - 2992 purestat_vector_all.nobjects -
3005 purestat_vector_bytecode_constants.nobjects; 2993 purestat_vector_constants.nobjects;
3006 2994
3007 purestat_string_other.nbytes = 2995 purestat_string_other.nbytes =
3008 purestat_string_all.nbytes - 2996 purestat_string_all.nbytes -
3009 (purestat_string_pname.nbytes + 2997 (purestat_string_pname.nbytes +
3010 purestat_string_bytecodes.nbytes +
3011 purestat_string_interactive.nbytes + 2998 purestat_string_interactive.nbytes +
3012 purestat_string_documentation.nbytes + 2999 purestat_string_documentation.nbytes +
3013 #ifdef I18N3 3000 #ifdef I18N3
3014 purestat_string_domain.nbytes + 3001 purestat_string_domain.nbytes +
3015 #endif 3002 #endif
3016 purestat_string_other_function.nbytes); 3003 purestat_string_other_function.nbytes);
3017 3004
3018 purestat_string_other.nobjects = 3005 purestat_string_other.nobjects =
3019 purestat_string_all.nobjects - 3006 purestat_string_all.nobjects -
3020 (purestat_string_pname.nobjects + 3007 (purestat_string_pname.nobjects +
3021 purestat_string_bytecodes.nobjects +
3022 purestat_string_interactive.nobjects + 3008 purestat_string_interactive.nobjects +
3023 purestat_string_documentation.nobjects + 3009 purestat_string_documentation.nobjects +
3024 #ifdef I18N3 3010 #ifdef I18N3
3025 purestat_string_domain.nobjects + 3011 purestat_string_domain.nobjects +
3026 #endif 3012 #endif
3027 purestat_string_other_function.nobjects); 3013 purestat_string_other_function.nobjects);
3028 3014
3029 message (" %-26s Total Bytes", ""); 3015 message (" %-34s Objects Bytes", "");
3030 3016
3031 { 3017 print_purestat (&purestat_cons);
3032 int j; 3018 print_purestat (&purestat_float);
3033 3019 print_purestat (&purestat_string_pname);
3034 for (j = 0; j < countof (purestats); j++) 3020 print_purestat (&purestat_function);
3035 if (!purestats[j]) 3021 print_purestat (&purestat_opaque_instructions);
3036 clear_message (); 3022 print_purestat (&purestat_vector_constants);
3037 else 3023 print_purestat (&purestat_string_interactive);
3024 #ifdef I18N3
3025 print_purestat (&purestat_string_domain);
3026 #endif
3027 print_purestat (&purestat_string_documentation);
3028 print_purestat (&purestat_string_other_function);
3029 print_purestat (&purestat_vector_other);
3030 print_purestat (&purestat_string_other);
3031 print_purestat (&purestat_string_all);
3032 print_purestat (&purestat_vector_all);
3033
3034 #endif /* PURESTAT */
3035
3036
3037 if (report_impurities)
3038 {
3039 Lisp_Object plist;
3040 struct gcpro gcpro1;
3041 plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
3042 GCPRO1 (plist);
3043 message ("\nImpurities:");
3044 for (; CONSP (plist); plist = XCDR (XCDR (plist)))
3038 { 3045 {
3039 char buf [100]; 3046 Lisp_Object symbol = XCAR (plist);
3040 sprintf(buf, "%s:", purestats[j]->name); 3047 int size = XINT (XCAR (XCDR (plist)));
3041 message (" %-26s %5d %7d %2d%%", 3048 if (size > 0)
3042 buf,
3043 purestats[j]->nobjects,
3044 purestats[j]->nbytes,
3045 (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5));
3046 }
3047 }
3048 #endif /* PURESTAT */
3049
3050
3051 if (report_impurities)
3052 {
3053 Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5));
3054 struct gcpro gcpro1;
3055 GCPRO1 (tem);
3056 message ("\nImpurities:");
3057 while (!NILP (tem))
3058 {
3059 if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem)))
3060 { 3049 {
3061 int total = XINT (Fcar (Fcdr (tem))); 3050 char buf [100];
3062 if (total > 0) 3051 char *s = buf;
3063 { 3052 memcpy (buf,
3064 char buf [100]; 3053 string_data (XSYMBOL (symbol)->name),
3065 char *s = buf; 3054 string_length (XSYMBOL (symbol)->name) + 1);
3066 memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name), 3055 while (*s++) if (*s == '-') *s = ' ';
3067 string_length (XSYMBOL (Fcar (tem))->name) + 1); 3056 *(s-1) = ':'; *s = 0;
3068 while (*s++) if (*s == '-') *s = ' '; 3057 message (" %-34s %6d", buf, size);
3069 s--; *s++ = ':'; *s = 0;
3070 message (" %-33s %6d", buf, total);
3071 }
3072 tem = Fcdr (Fcdr (tem));
3073 }
3074 else /* WTF?! */
3075 {
3076 Fprin1 (tem, Qexternal_debugging_output);
3077 tem = Qnil;
3078 } 3058 }
3079 } 3059 }
3080 UNGCPRO; 3060 UNGCPRO;
3081 garbage_collect_1 (); /* GC garbage_collect's garbage */ 3061 garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
3082 } 3062 }
3083 clear_message (); 3063 clear_message ();
3084 3064
3085 if (rc < 0) { 3065 if (rc < 0) {
3086 unlink("SATISFIED"); 3066 unlink("SATISFIED");
3089 fatal ("Pure storage exhausted"); 3069 fatal ("Pure storage exhausted");
3090 } 3070 }
3091 } 3071 }
3092 3072
3093 3073
3094 /**********************************************************************/ 3074 /************************************************************************/
3095 /* staticpro */ 3075 /* Garbage Collection */
3096 /**********************************************************************/ 3076 /************************************************************************/
3077
3078 /* This will be used more extensively In The Future */
3079 static int last_lrecord_type_index_assigned;
3080
3081 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3082 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3097 3083
3098 struct gcpro *gcprolist; 3084 struct gcpro *gcprolist;
3099 3085
3100 /* 415 used Mly 29-Jun-93 */ 3086 /* 415 used Mly 29-Jun-93 */
3101 /* 1327 used slb 28-Feb-98 */ 3087 /* 1327 used slb 28-Feb-98 */
3129 static void 3115 static void
3130 mark_object (Lisp_Object obj) 3116 mark_object (Lisp_Object obj)
3131 { 3117 {
3132 tail_recurse: 3118 tail_recurse:
3133 3119
3134 if (EQ (obj, Qnull_pointer)) 3120 #ifdef ERROR_CHECK_GC
3135 return; 3121 assert (! (GC_EQ (obj, Qnull_pointer)));
3136 if (!POINTER_TYPE_P (XGCTYPE (obj))) 3122 #endif
3137 return; 3123 /* Checks we used to perform */
3138 if (PURIFIED (XPNTR (obj))) 3124 /* if (EQ (obj, Qnull_pointer)) return; */
3139 return; 3125 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3126 /* if (PURIFIED (XPNTR (obj))) return; */
3127
3140 switch (XGCTYPE (obj)) 3128 switch (XGCTYPE (obj))
3141 { 3129 {
3142 #ifndef LRECORD_CONS 3130 #ifndef LRECORD_CONS
3143 case Lisp_Type_Cons: 3131 case Lisp_Type_Cons:
3144 { 3132 {
3145 struct Lisp_Cons *ptr = XCONS (obj); 3133 struct Lisp_Cons *ptr = XCONS (obj);
3134 if (PURIFIED (ptr))
3135 break;
3146 if (CONS_MARKED_P (ptr)) 3136 if (CONS_MARKED_P (ptr))
3147 break; 3137 break;
3148 MARK_CONS (ptr); 3138 MARK_CONS (ptr);
3149 /* If the cdr is nil, tail-recurse on the car. */ 3139 /* If the cdr is nil, tail-recurse on the car. */
3150 if (NILP (ptr->cdr)) 3140 if (GC_NILP (ptr->cdr))
3151 { 3141 {
3152 obj = ptr->car; 3142 obj = ptr->car;
3153 } 3143 }
3154 else 3144 else
3155 { 3145 {
3159 goto tail_recurse; 3149 goto tail_recurse;
3160 } 3150 }
3161 #endif 3151 #endif
3162 3152
3163 case Lisp_Type_Record: 3153 case Lisp_Type_Record:
3164 /* case Lisp_Symbol_Value_Magic: */
3165 { 3154 {
3166 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 3155 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3167 CONST struct lrecord_implementation *implementation 3156 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
3168 = LHEADER_IMPLEMENTATION (lheader); 3157 assert (lheader->type <= last_lrecord_type_index_assigned);
3158 #endif
3159 if (PURIFIED (lheader))
3160 return;
3169 3161
3170 if (! MARKED_RECORD_HEADER_P (lheader) && 3162 if (! MARKED_RECORD_HEADER_P (lheader) &&
3171 ! UNMARKABLE_RECORD_HEADER_P (lheader)) 3163 ! UNMARKABLE_RECORD_HEADER_P (lheader))
3172 { 3164 {
3165 CONST struct lrecord_implementation *implementation =
3166 LHEADER_IMPLEMENTATION (lheader);
3173 MARK_RECORD_HEADER (lheader); 3167 MARK_RECORD_HEADER (lheader);
3174 #ifdef ERROR_CHECK_GC 3168 #ifdef ERROR_CHECK_GC
3175 if (!implementation->basic_p) 3169 if (!implementation->basic_p)
3176 assert (! ((struct lcrecord_header *) lheader)->free); 3170 assert (! ((struct lcrecord_header *) lheader)->free);
3177 #endif 3171 #endif
3178 if (implementation->marker != 0) 3172 if (implementation->marker)
3179 { 3173 {
3180 obj = ((implementation->marker) (obj, mark_object)); 3174 obj = implementation->marker (obj, mark_object);
3181 if (!NILP (obj)) goto tail_recurse; 3175 if (!GC_NILP (obj)) goto tail_recurse;
3182 } 3176 }
3183 } 3177 }
3184 } 3178 }
3185 break; 3179 break;
3186 3180
3187 #ifndef LRECORD_STRING 3181 #ifndef LRECORD_STRING
3188 case Lisp_Type_String: 3182 case Lisp_Type_String:
3189 { 3183 {
3190 struct Lisp_String *ptr = XSTRING (obj); 3184 struct Lisp_String *ptr = XSTRING (obj);
3185 if (PURIFIED (ptr))
3186 return;
3191 3187
3192 if (!XMARKBIT (ptr->plist)) 3188 if (!XMARKBIT (ptr->plist))
3193 { 3189 {
3194 if (CONSP (ptr->plist) && 3190 if (CONSP (ptr->plist) &&
3195 EXTENT_INFOP (XCAR (ptr->plist))) 3191 EXTENT_INFOP (XCAR (ptr->plist)))
3204 3200
3205 #ifndef LRECORD_VECTOR 3201 #ifndef LRECORD_VECTOR
3206 case Lisp_Type_Vector: 3202 case Lisp_Type_Vector:
3207 { 3203 {
3208 struct Lisp_Vector *ptr = XVECTOR (obj); 3204 struct Lisp_Vector *ptr = XVECTOR (obj);
3209 int len = vector_length (ptr); 3205 int len, i;
3210 int i; 3206
3207 if (PURIFIED (ptr))
3208 return;
3209
3210 len = vector_length (ptr);
3211 3211
3212 if (len < 0) 3212 if (len < 0)
3213 break; /* Already marked */ 3213 break; /* Already marked */
3214 ptr->size = -1 - len; /* Else mark it */ 3214 ptr->size = -1 - len; /* Else mark it */
3215 for (i = 0; i < len - 1; i++) /* and then mark its elements */ 3215 for (i = 0; i < len - 1; i++) /* and then mark its elements */
3226 #ifndef LRECORD_SYMBOL 3226 #ifndef LRECORD_SYMBOL
3227 case Lisp_Type_Symbol: 3227 case Lisp_Type_Symbol:
3228 { 3228 {
3229 struct Lisp_Symbol *sym = XSYMBOL (obj); 3229 struct Lisp_Symbol *sym = XSYMBOL (obj);
3230 3230
3231 if (PURIFIED (sym))
3232 return;
3233
3231 while (!XMARKBIT (sym->plist)) 3234 while (!XMARKBIT (sym->plist))
3232 { 3235 {
3233 XMARK (sym->plist); 3236 XMARK (sym->plist);
3234 mark_object (sym->value); 3237 mark_object (sym->value);
3235 mark_object (sym->function); 3238 mark_object (sym->function);
3237 /* 3240 /*
3238 * symbol->name is a struct Lisp_String *, not a 3241 * symbol->name is a struct Lisp_String *, not a
3239 * Lisp_Object. Fix it up and pass to mark_object. 3242 * Lisp_Object. Fix it up and pass to mark_object.
3240 */ 3243 */
3241 Lisp_Object symname; 3244 Lisp_Object symname;
3242 XSETSTRING(symname, sym->name); 3245 XSETSTRING (symname, sym->name);
3243 mark_object(symname); 3246 mark_object (symname);
3244 } 3247 }
3245 if (!symbol_next (sym)) 3248 if (!symbol_next (sym))
3246 { 3249 {
3247 obj = sym->plist; 3250 obj = sym->plist;
3248 goto tail_recurse; 3251 goto tail_recurse;
3253 } 3256 }
3254 } 3257 }
3255 break; 3258 break;
3256 #endif /* !LRECORD_SYMBOL */ 3259 #endif /* !LRECORD_SYMBOL */
3257 3260
3261 /* Check for invalid Lisp_Object types */
3262 #if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
3263 case Lisp_Type_Int:
3264 case Lisp_Type_Char:
3265 break;
3258 default: 3266 default:
3259 abort (); 3267 abort();
3268 break;
3269 #endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
3260 } 3270 }
3261 } 3271 }
3262 3272
3263 /* mark all of the conses in a list and mark the final cdr; but 3273 /* mark all of the conses in a list and mark the final cdr; but
3264 DO NOT mark the cars. 3274 DO NOT mark the cars.
3284 3294
3285 #ifdef PURESTAT 3295 #ifdef PURESTAT
3286 /* Simpler than mark-object, because pure structure can't 3296 /* Simpler than mark-object, because pure structure can't
3287 have any circularities */ 3297 have any circularities */
3288 3298
3289 #if 0 /* unused */
3290 static int idiot_c_doesnt_have_closures;
3291 static void
3292 idiot_c (Lisp_Object obj)
3293 {
3294 idiot_c_doesnt_have_closures += pure_sizeof (obj, 1);
3295 }
3296 #endif /* unused */
3297
3298 static size_t 3299 static size_t
3299 pure_string_sizeof (Lisp_Object obj) 3300 pure_string_sizeof (Lisp_Object obj)
3300 { 3301 {
3301 struct Lisp_String *ptr = XSTRING (obj); 3302 struct Lisp_String *ptr = XSTRING (obj);
3302 3303
3312 size = ALIGN_SIZE (size, sizeof (Lisp_Object)); 3313 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3313 return size; 3314 return size;
3314 } 3315 }
3315 } 3316 }
3316 3317
3317 /* recurse arg isn't actually used */
3318 static size_t 3318 static size_t
3319 pure_sizeof (Lisp_Object obj /*, int recurse */) 3319 pure_sizeof (Lisp_Object obj)
3320 { 3320 {
3321 size_t total = 0;
3322
3323 /*tail_recurse: */
3324 if (!POINTER_TYPE_P (XTYPE (obj)) 3321 if (!POINTER_TYPE_P (XTYPE (obj))
3325 || !PURIFIED (XPNTR (obj))) 3322 || !PURIFIED (XPNTR (obj)))
3326 return total; 3323 return 0;
3327 3324 /* symbol sizes are accounted for separately */
3328 /* symbol's sizes are accounted for separately */ 3325 else if (SYMBOLP (obj))
3329 if (SYMBOLP (obj)) 3326 return 0;
3330 return total; 3327 else if (STRINGP (obj))
3331 3328 return pure_string_sizeof (obj);
3332 switch (XTYPE (obj)) 3329 else if (LRECORDP (obj))
3333 { 3330 {
3334 3331 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3335 #ifndef LRECORD_STRING 3332 CONST struct lrecord_implementation *implementation
3336 case Lisp_Type_String: 3333 = LHEADER_IMPLEMENTATION (lheader);
3337 total += pure_string_sizeof (obj); 3334
3338 break; 3335 return implementation->size_in_bytes_method
3339 #endif /* ! LRECORD_STRING */ 3336 ? implementation->size_in_bytes_method (lheader)
3340 3337 : implementation->static_size;
3338 }
3341 #ifndef LRECORD_VECTOR 3339 #ifndef LRECORD_VECTOR
3342 case Lisp_Type_Vector: 3340 else if (VECTORP (obj))
3343 { 3341 return offsetof (Lisp_Vector, contents[XVECTOR_LENGTH (obj)]);
3344 struct Lisp_Vector *ptr = XVECTOR (obj);
3345 int len = vector_length (ptr);
3346
3347 total += (sizeof (struct Lisp_Vector)
3348 + (len - 1) * sizeof (Lisp_Object));
3349 #if 0 /* unused */
3350 if (!recurse)
3351 break;
3352 {
3353 int i;
3354 for (i = 0; i < len - 1; i++)
3355 total += pure_sizeof (ptr->contents[i], 1);
3356 }
3357 if (len > 0)
3358 {
3359 obj = ptr->contents[len - 1];
3360 goto tail_recurse;
3361 }
3362 #endif /* unused */
3363 }
3364 break;
3365 #endif /* !LRECORD_VECTOR */ 3342 #endif /* !LRECORD_VECTOR */
3366 3343
3367 case Lisp_Type_Record:
3368 {
3369 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3370 CONST struct lrecord_implementation *implementation
3371 = LHEADER_IMPLEMENTATION (lheader);
3372
3373 #ifdef LRECORD_STRING
3374 if (STRINGP (obj))
3375 total += pure_string_sizeof (obj);
3376 else
3377 #endif
3378 if (implementation->size_in_bytes_method)
3379 total += ((implementation->size_in_bytes_method) (lheader));
3380 else
3381 total += implementation->static_size;
3382
3383 #if 0 /* unused */
3384 if (!recurse)
3385 break;
3386
3387 if (implementation->marker != 0)
3388 {
3389 int old = idiot_c_doesnt_have_closures;
3390
3391 idiot_c_doesnt_have_closures = 0;
3392 obj = ((implementation->marker) (obj, idiot_c));
3393 total += idiot_c_doesnt_have_closures;
3394 idiot_c_doesnt_have_closures = old;
3395
3396 if (!NILP (obj)) goto tail_recurse;
3397 }
3398 #endif /* unused */
3399 }
3400 break;
3401
3402 #ifndef LRECORD_CONS 3344 #ifndef LRECORD_CONS
3403 case Lisp_Type_Cons: 3345 else if (CONSP (obj))
3404 { 3346 return sizeof (struct Lisp_Cons);
3405 struct Lisp_Cons *ptr = XCONS (obj); 3347 #endif /* !LRECORD_CONS */
3406 total += sizeof (*ptr); 3348 else
3407 #if 0 /* unused */ 3349 /* Others can't be purified */
3408 if (!recurse) 3350 abort ();
3409 break; 3351 return 0; /* unreached */
3410 /* If the cdr is nil, tail-recurse on the car. */
3411 if (NILP (ptr->cdr))
3412 {
3413 obj = ptr->car;
3414 }
3415 else
3416 {
3417 total += pure_sizeof (ptr->car, 1);
3418 obj = ptr->cdr;
3419 }
3420 goto tail_recurse;
3421 #endif /* unused */
3422 }
3423 break;
3424 #endif
3425
3426 /* Others can't be purified */
3427 default:
3428 abort ();
3429 }
3430 return total;
3431 } 3352 }
3432 #endif /* PURESTAT */ 3353 #endif /* PURESTAT */
3433 3354
3434 3355
3435 3356
3447 static int gc_count_short_string_total_size; 3368 static int gc_count_short_string_total_size;
3448 3369
3449 /* static int gc_count_total_records_used, gc_count_records_total_size; */ 3370 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3450 3371
3451 3372
3452 /* This will be used more extensively In The Future */
3453 static int last_lrecord_type_index_assigned;
3454
3455 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3456 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3457
3458 int 3373 int
3459 lrecord_type_index (CONST struct lrecord_implementation *implementation) 3374 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3460 { 3375 {
3461 int type_index = *(implementation->lrecord_type_index); 3376 int type_index = *(implementation->lrecord_type_index);
3462 /* Have to do this circuitous validation test because of problems 3377 /* Have to do this circuitous validation test because of problems
3513 lcrecord_stats[type_index].instances_on_free_list++; 3428 lcrecord_stats[type_index].instances_on_free_list++;
3514 } 3429 }
3515 else 3430 else
3516 { 3431 {
3517 size_t sz = (implementation->size_in_bytes_method 3432 size_t sz = (implementation->size_in_bytes_method
3518 ? ((implementation->size_in_bytes_method) (h)) 3433 ? implementation->size_in_bytes_method (h)
3519 : implementation->static_size); 3434 : implementation->static_size);
3520 3435
3521 if (free_p) 3436 if (free_p)
3522 { 3437 {
3523 lcrecord_stats[type_index].instances_freed++; 3438 lcrecord_stats[type_index].instances_freed++;
3555 { 3470 {
3556 struct lrecord_header *h = &(header->lheader); 3471 struct lrecord_header *h = &(header->lheader);
3557 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free)) 3472 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3558 { 3473 {
3559 if (LHEADER_IMPLEMENTATION (h)->finalizer) 3474 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3560 ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0)); 3475 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3561 } 3476 }
3562 } 3477 }
3563 3478
3564 for (header = *prev; header; ) 3479 for (header = *prev; header; )
3565 { 3480 {
3566 struct lrecord_header *h = &(header->lheader); 3481 struct lrecord_header *h = &(header->lheader);
3567 if (MARKED_RECORD_HEADER_P (h)) 3482 if (MARKED_RECORD_HEADER_P (h))
3568 { 3483 {
3569 UNMARK_RECORD_HEADER (h); 3484 UNMARK_RECORD_HEADER (h);
3570 num_used++; 3485 num_used++;
3571 /* total_size += ((n->implementation->size_in_bytes) (h));*/ 3486 /* total_size += n->implementation->size_in_bytes (h);*/
3572 prev = &(header->next); 3487 prev = &(header->next);
3573 header = *prev; 3488 header = *prev;
3574 tick_lcrecord_stats (h, 0); 3489 tick_lcrecord_stats (h, 0);
3575 } 3490 }
3576 else 3491 else
3598 int total_size = 0; 3513 int total_size = 0;
3599 int total_storage = 0; 3514 int total_storage = 0;
3600 3515
3601 for (vector = *prev; VECTORP (vector); ) 3516 for (vector = *prev; VECTORP (vector); )
3602 { 3517 {
3603 struct Lisp_Vector *v = XVECTOR (vector); 3518 Lisp_Vector *v = XVECTOR (vector);
3604 int len = v->size; 3519 int len = v->size;
3605 if (len < 0) /* marked */ 3520 if (len < 0) /* marked */
3606 { 3521 {
3607 len = - (len + 1); 3522 len = - (len + 1);
3608 v->size = len; 3523 v->size = len;
3609 total_size += len; 3524 total_size += len;
3610 total_storage += (MALLOC_OVERHEAD 3525 total_storage +=
3611 + sizeof (struct Lisp_Vector) 3526 MALLOC_OVERHEAD + offsetof (Lisp_Vector, contents[len + 1]);
3612 + (len - 1 + 1) * sizeof (Lisp_Object));
3613 num_used++; 3527 num_used++;
3614 prev = &(vector_next (v)); 3528 prev = &(vector_next (v));
3615 vector = *prev; 3529 vector = *prev;
3616 } 3530 }
3617 else 3531 else
3640 3554
3641 /* BIT_VECTORP fails because the objects are marked, which changes 3555 /* BIT_VECTORP fails because the objects are marked, which changes
3642 their implementation */ 3556 their implementation */
3643 for (bit_vector = *prev; !EQ (bit_vector, Qzero); ) 3557 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3644 { 3558 {
3645 struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); 3559 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3646 int len = v->size; 3560 int len = v->size;
3647 if (MARKED_RECORD_P (bit_vector)) 3561 if (MARKED_RECORD_P (bit_vector))
3648 { 3562 {
3649 UNMARK_RECORD_HEADER (&(v->lheader)); 3563 UNMARK_RECORD_HEADER (&(v->lheader));
3650 total_size += len; 3564 total_size += len;
3651 total_storage += (MALLOC_OVERHEAD 3565 total_storage +=
3652 + sizeof (struct Lisp_Bit_Vector) 3566 MALLOC_OVERHEAD
3653 + (BIT_VECTOR_LONG_STORAGE (len) - 1) 3567 + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
3654 * sizeof (long));
3655 num_used++; 3568 num_used++;
3656 prev = &(bit_vector_next (v)); 3569 prev = &(bit_vector_next (v));
3657 bit_vector = *prev; 3570 bit_vector = *prev;
3658 } 3571 }
3659 else 3572 else
3674 3587
3675 #ifdef ERROR_CHECK_GC 3588 #ifdef ERROR_CHECK_GC
3676 3589
3677 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ 3590 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3678 do { \ 3591 do { \
3679 struct typename##_block *_frob_current; \ 3592 struct typename##_block *SFTB_current; \
3680 struct typename##_block **_frob_prev; \ 3593 struct typename##_block **SFTB_prev; \
3681 int _frob_limit; \ 3594 int SFTB_limit; \
3682 int num_free = 0, num_used = 0; \ 3595 int num_free = 0, num_used = 0; \
3683 \ 3596 \
3684 for (_frob_prev = &current_##typename##_block, \ 3597 for (SFTB_prev = &current_##typename##_block, \
3685 _frob_current = current_##typename##_block, \ 3598 SFTB_current = current_##typename##_block, \
3686 _frob_limit = current_##typename##_block_index; \ 3599 SFTB_limit = current_##typename##_block_index; \
3687 _frob_current; \ 3600 SFTB_current; \
3688 ) \ 3601 ) \
3689 { \ 3602 { \
3690 int _frob_iii; \ 3603 int SFTB_iii; \
3691 \ 3604 \
3692 for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ 3605 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3693 { \ 3606 { \
3694 obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ 3607 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3695 \ 3608 \
3696 if (FREE_STRUCT_P (_frob_victim)) \ 3609 if (FREE_STRUCT_P (SFTB_victim)) \
3697 { \ 3610 { \
3698 num_free++; \ 3611 num_free++; \
3699 } \ 3612 } \
3700 else if (!MARKED_##typename##_P (_frob_victim)) \ 3613 else if (!MARKED_##typename##_P (SFTB_victim)) \
3701 { \ 3614 { \
3702 num_free++; \ 3615 num_free++; \
3703 FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ 3616 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3704 } \ 3617 } \
3705 else \ 3618 else \
3706 { \ 3619 { \
3707 num_used++; \ 3620 num_used++; \
3708 UNMARK_##typename (_frob_victim); \ 3621 UNMARK_##typename (SFTB_victim); \
3709 } \ 3622 } \
3710 } \ 3623 } \
3711 _frob_prev = &(_frob_current->prev); \ 3624 SFTB_prev = &(SFTB_current->prev); \
3712 _frob_current = _frob_current->prev; \ 3625 SFTB_current = SFTB_current->prev; \
3713 _frob_limit = countof (current_##typename##_block->block); \ 3626 SFTB_limit = countof (current_##typename##_block->block); \
3714 } \ 3627 } \
3715 \ 3628 \
3716 gc_count_num_##typename##_in_use = num_used; \ 3629 gc_count_num_##typename##_in_use = num_used; \
3717 gc_count_num_##typename##_freelist = num_free; \ 3630 gc_count_num_##typename##_freelist = num_free; \
3718 } while (0) 3631 } while (0)
3719 3632
3720 #else /* !ERROR_CHECK_GC */ 3633 #else /* !ERROR_CHECK_GC */
3721 3634
3722 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ 3635 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3723 do { \ 3636 do { \
3724 struct typename##_block *_frob_current; \ 3637 struct typename##_block *SFTB_current; \
3725 struct typename##_block **_frob_prev; \ 3638 struct typename##_block **SFTB_prev; \
3726 int _frob_limit; \ 3639 int SFTB_limit; \
3727 int num_free = 0, num_used = 0; \ 3640 int num_free = 0, num_used = 0; \
3728 \ 3641 \
3729 typename##_free_list = 0; \ 3642 typename##_free_list = 0; \
3730 \ 3643 \
3731 for (_frob_prev = &current_##typename##_block, \ 3644 for (SFTB_prev = &current_##typename##_block, \
3732 _frob_current = current_##typename##_block, \ 3645 SFTB_current = current_##typename##_block, \
3733 _frob_limit = current_##typename##_block_index; \ 3646 SFTB_limit = current_##typename##_block_index; \
3734 _frob_current; \ 3647 SFTB_current; \
3735 ) \ 3648 ) \
3736 { \ 3649 { \
3737 int _frob_iii; \ 3650 int SFTB_iii; \
3738 int _frob_empty = 1; \ 3651 int SFTB_empty = 1; \
3739 obj_type *_frob_old_free_list = typename##_free_list; \ 3652 obj_type *SFTB_old_free_list = typename##_free_list; \
3740 \ 3653 \
3741 for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ 3654 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3742 { \ 3655 { \
3743 obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ 3656 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3744 \ 3657 \
3745 if (FREE_STRUCT_P (_frob_victim)) \ 3658 if (FREE_STRUCT_P (SFTB_victim)) \
3746 { \ 3659 { \
3747 num_free++; \ 3660 num_free++; \
3748 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \ 3661 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
3749 } \ 3662 } \
3750 else if (!MARKED_##typename##_P (_frob_victim)) \ 3663 else if (!MARKED_##typename##_P (SFTB_victim)) \
3751 { \ 3664 { \
3752 num_free++; \ 3665 num_free++; \
3753 FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ 3666 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3754 } \ 3667 } \
3755 else \ 3668 else \
3756 { \ 3669 { \
3757 _frob_empty = 0; \ 3670 SFTB_empty = 0; \
3758 num_used++; \ 3671 num_used++; \
3759 UNMARK_##typename (_frob_victim); \ 3672 UNMARK_##typename (SFTB_victim); \
3760 } \ 3673 } \
3761 } \ 3674 } \
3762 if (!_frob_empty) \ 3675 if (!SFTB_empty) \
3763 { \ 3676 { \
3764 _frob_prev = &(_frob_current->prev); \ 3677 SFTB_prev = &(SFTB_current->prev); \
3765 _frob_current = _frob_current->prev; \ 3678 SFTB_current = SFTB_current->prev; \
3766 } \ 3679 } \
3767 else if (_frob_current == current_##typename##_block \ 3680 else if (SFTB_current == current_##typename##_block \
3768 && !_frob_current->prev) \ 3681 && !SFTB_current->prev) \
3769 { \ 3682 { \
3770 /* No real point in freeing sole allocation block */ \ 3683 /* No real point in freeing sole allocation block */ \
3771 break; \ 3684 break; \
3772 } \ 3685 } \
3773 else \ 3686 else \
3774 { \ 3687 { \
3775 struct typename##_block *_frob_victim_block = _frob_current; \ 3688 struct typename##_block *SFTB_victim_block = SFTB_current; \
3776 if (_frob_victim_block == current_##typename##_block) \ 3689 if (SFTB_victim_block == current_##typename##_block) \
3777 current_##typename##_block_index \ 3690 current_##typename##_block_index \
3778 = countof (current_##typename##_block->block); \ 3691 = countof (current_##typename##_block->block); \
3779 _frob_current = _frob_current->prev; \ 3692 SFTB_current = SFTB_current->prev; \
3780 { \ 3693 { \
3781 *_frob_prev = _frob_current; \ 3694 *SFTB_prev = SFTB_current; \
3782 xfree (_frob_victim_block); \ 3695 xfree (SFTB_victim_block); \
3783 /* Restore free list to what it was before victim was swept */ \ 3696 /* Restore free list to what it was before victim was swept */ \
3784 typename##_free_list = _frob_old_free_list; \ 3697 typename##_free_list = SFTB_old_free_list; \
3785 num_free -= _frob_limit; \ 3698 num_free -= SFTB_limit; \
3786 } \ 3699 } \
3787 } \ 3700 } \
3788 _frob_limit = countof (current_##typename##_block->block); \ 3701 SFTB_limit = countof (current_##typename##_block->block); \
3789 } \ 3702 } \
3790 \ 3703 \
3791 gc_count_num_##typename##_in_use = num_used; \ 3704 gc_count_num_##typename##_in_use = num_used; \
3792 gc_count_num_##typename##_freelist = num_free; \ 3705 gc_count_num_##typename##_freelist = num_free; \
3793 } while (0) 3706 } while (0)
3794 3707
3795 #endif /* !ERROR_CHECK_GC */ 3708 #endif /* !ERROR_CHECK_GC */
3796 3709
3797 3710
3873 #define MARKED_compiled_function_P(ptr) \ 3786 #define MARKED_compiled_function_P(ptr) \
3874 MARKED_RECORD_HEADER_P (&((ptr)->lheader)) 3787 MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3875 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 3788 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3876 #define ADDITIONAL_FREE_compiled_function(ptr) 3789 #define ADDITIONAL_FREE_compiled_function(ptr)
3877 3790
3878 SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function); 3791 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3879 } 3792 }
3880 3793
3881 3794
3882 #ifdef LISP_FLOAT_TYPE 3795 #ifdef LISP_FLOAT_TYPE
3883 static void 3796 static void
4191 4104
4192 /* I hate duplicating all this crap! */ 4105 /* I hate duplicating all this crap! */
4193 static int 4106 static int
4194 marked_p (Lisp_Object obj) 4107 marked_p (Lisp_Object obj)
4195 { 4108 {
4196 if (EQ (obj, Qnull_pointer)) return 1; 4109 #ifdef ERROR_CHECK_GC
4197 if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; 4110 assert (! (GC_EQ (obj, Qnull_pointer)));
4198 if (PURIFIED (XPNTR (obj))) return 1; 4111 #endif
4112 /* Checks we used to perform. */
4113 /* if (EQ (obj, Qnull_pointer)) return 1; */
4114 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4115 /* if (PURIFIED (XPNTR (obj))) return 1; */
4116
4199 switch (XGCTYPE (obj)) 4117 switch (XGCTYPE (obj))
4200 { 4118 {
4201 #ifndef LRECORD_CONS 4119 #ifndef LRECORD_CONS
4202 case Lisp_Type_Cons: 4120 case Lisp_Type_Cons:
4203 return XMARKBIT (XCAR (obj)); 4121 {
4122 struct Lisp_Cons *ptr = XCONS (obj);
4123 return PURIFIED (ptr) || XMARKBIT (ptr->car);
4124 }
4204 #endif 4125 #endif
4205 case Lisp_Type_Record: 4126 case Lisp_Type_Record:
4206 return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); 4127 {
4128 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
4129 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
4130 assert (lheader->type <= last_lrecord_type_index_assigned);
4131 #endif
4132 return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
4133 }
4207 #ifndef LRECORD_STRING 4134 #ifndef LRECORD_STRING
4208 case Lisp_Type_String: 4135 case Lisp_Type_String:
4209 return XMARKBIT (XSTRING (obj)->plist); 4136 {
4137 struct Lisp_String *ptr = XSTRING (obj);
4138 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4139 }
4210 #endif /* ! LRECORD_STRING */ 4140 #endif /* ! LRECORD_STRING */
4211 #ifndef LRECORD_VECTOR 4141 #ifndef LRECORD_VECTOR
4212 case Lisp_Type_Vector: 4142 case Lisp_Type_Vector:
4213 return XVECTOR_LENGTH (obj) < 0; 4143 {
4144 struct Lisp_Vector *ptr = XVECTOR (obj);
4145 return PURIFIED (ptr) || vector_length (ptr) < 0;
4146 }
4214 #endif /* !LRECORD_VECTOR */ 4147 #endif /* !LRECORD_VECTOR */
4215 #ifndef LRECORD_SYMBOL 4148 #ifndef LRECORD_SYMBOL
4216 case Lisp_Type_Symbol: 4149 case Lisp_Type_Symbol:
4217 return XMARKBIT (XSYMBOL (obj)->plist); 4150 {
4218 #endif 4151 struct Lisp_Symbol *ptr = XSYMBOL (obj);
4152 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4153 }
4154 #endif
4155
4156 /* Ints and Chars don't need GC */
4157 #if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
4219 default: 4158 default:
4220 abort (); 4159 return 1;
4221 } 4160 #else
4222 return 0; /* suppress compiler warning */ 4161 default:
4162 abort();
4163 case Lisp_Type_Int:
4164 case Lisp_Type_Char:
4165 return 1;
4166 #endif
4167 }
4223 } 4168 }
4224 4169
4225 static void 4170 static void
4226 gc_sweep (void) 4171 gc_sweep (void)
4227 { 4172 {
4295 void 4240 void
4296 disksave_object_finalization (void) 4241 disksave_object_finalization (void)
4297 { 4242 {
4298 /* It's important that certain information from the environment not get 4243 /* It's important that certain information from the environment not get
4299 dumped with the executable (pathnames, environment variables, etc.). 4244 dumped with the executable (pathnames, environment variables, etc.).
4300 To make it easier to tell when this has happend with strings(1) we 4245 To make it easier to tell when this has happened with strings(1) we
4301 clear some known-to-be-garbage blocks of memory, so that leftover 4246 clear some known-to-be-garbage blocks of memory, so that leftover
4302 results of old evaluation don't look like potential problems. 4247 results of old evaluation don't look like potential problems.
4303 But first we set some notable variables to nil and do one more GC, 4248 But first we set some notable variables to nil and do one more GC,
4304 to turn those strings into garbage. 4249 to turn those strings into garbage.
4305 */ 4250 */
4368 4313
4369 4314
4370 void 4315 void
4371 garbage_collect_1 (void) 4316 garbage_collect_1 (void)
4372 { 4317 {
4318 #if MAX_SAVE_STACK > 0
4373 char stack_top_variable; 4319 char stack_top_variable;
4374 extern char *stack_bottom; 4320 extern char *stack_bottom;
4321 #endif
4375 int i; 4322 int i;
4376 struct frame *f; 4323 struct frame *f;
4377 int speccount; 4324 int speccount;
4378 int cursor_changed; 4325 int cursor_changed;
4379 Lisp_Object pre_gc_cursor; 4326 Lisp_Object pre_gc_cursor;
4383 || gc_currently_forbidden 4330 || gc_currently_forbidden
4384 || in_display 4331 || in_display
4385 || preparing_for_armageddon) 4332 || preparing_for_armageddon)
4386 return; 4333 return;
4387 4334
4335 /* We used to call selected_frame() here.
4336
4337 The following functions cannot be called inside GC
4338 so we move to after the above tests. */
4339 {
4340 Lisp_Object frame;
4341 Lisp_Object device = Fselected_device (Qnil);
4342 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
4343 return;
4344 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
4345 if (NILP (frame))
4346 signal_simple_error ("No frames exist on device", device);
4347 f = XFRAME (frame);
4348 }
4349
4388 pre_gc_cursor = Qnil; 4350 pre_gc_cursor = Qnil;
4389 cursor_changed = 0; 4351 cursor_changed = 0;
4390
4391 /* This function cannot be called inside GC so we move to after the */
4392 /* above tests */
4393 f = selected_frame ();
4394 4352
4395 GCPRO1 (pre_gc_cursor); 4353 GCPRO1 (pre_gc_cursor);
4396 4354
4397 /* Very important to prevent GC during any of the following 4355 /* Very important to prevent GC during any of the following
4398 stuff that might run Lisp code; otherwise, we'll likely 4356 stuff that might run Lisp code; otherwise, we'll likely
4484 struct backtrace *backlist; 4442 struct backtrace *backlist;
4485 struct specbinding *bind; 4443 struct specbinding *bind;
4486 4444
4487 for (i = 0; i < staticidx; i++) 4445 for (i = 0; i < staticidx; i++)
4488 { 4446 {
4489 #ifdef GDB_SUCKS
4490 printf ("%d\n", i);
4491 debug_print (*staticvec[i]);
4492 #endif
4493 mark_object (*(staticvec[i])); 4447 mark_object (*(staticvec[i]));
4494 } 4448 }
4495 4449
4496 for (tail = gcprolist; tail; tail = tail->next) 4450 for (tail = gcprolist; tail; tail = tail->next)
4497 { 4451 {
4526 mark_redisplay (mark_object); 4480 mark_redisplay (mark_object);
4527 mark_profiling_info (mark_object); 4481 mark_profiling_info (mark_object);
4528 } 4482 }
4529 4483
4530 /* OK, now do the after-mark stuff. This is for things that 4484 /* OK, now do the after-mark stuff. This is for things that
4531 are only marked when something else is marked (e.g. weak hashtables). 4485 are only marked when something else is marked (e.g. weak hash tables).
4532 There may be complex dependencies between such objects -- e.g. 4486 There may be complex dependencies between such objects -- e.g.
4533 a weak hashtable might be unmarked, but after processing a later 4487 a weak hash table might be unmarked, but after processing a later
4534 weak hashtable, the former one might get marked. So we have to 4488 weak hash table, the former one might get marked. So we have to
4535 iterate until nothing more gets marked. */ 4489 iterate until nothing more gets marked. */
4536 { 4490
4537 int did_mark; 4491 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
4538 /* Need to iterate until there's nothing more to mark, in case 4492 finish_marking_weak_lists (marked_p, mark_object) > 0)
4539 of chains of mark dependencies. */ 4493 ;
4540 do
4541 {
4542 did_mark = 0;
4543 did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object);
4544 did_mark += !!finish_marking_weak_lists (marked_p, mark_object);
4545 }
4546 while (did_mark);
4547 }
4548 4494
4549 /* And prune (this needs to be called after everything else has been 4495 /* And prune (this needs to be called after everything else has been
4550 marked and before we do any sweeping). */ 4496 marked and before we do any sweeping). */
4551 /* #### this is somewhat ad-hoc and should probably be an object 4497 /* #### this is somewhat ad-hoc and should probably be an object
4552 method */ 4498 method */
4553 prune_weak_hashtables (marked_p); 4499 prune_weak_hash_tables (marked_p);
4554 prune_weak_lists (marked_p); 4500 prune_weak_lists (marked_p);
4555 prune_specifiers (marked_p); 4501 prune_specifiers (marked_p);
4556 prune_syntax_tables (marked_p); 4502 prune_syntax_tables (marked_p);
4557 4503
4558 gc_sweep (); 4504 gc_sweep ();
4608 4554
4609 UNGCPRO; 4555 UNGCPRO;
4610 return; 4556 return;
4611 } 4557 }
4612 4558
4613 #ifdef EMACS_BTL
4614 /* This isn't actually called. BTL recognizes the stack frame of the top
4615 of the garbage collector by noting that PC is between &garbage_collect_1
4616 and &BTL_after_garbage_collect_1_stub. So this fn must be right here.
4617 There's not any other way to know the address of the end of a function.
4618 */
4619 void BTL_after_garbage_collect_1_stub () { abort (); }
4620 #endif /* EMACS_BTL */
4621
4622 /* Debugging aids. */ 4559 /* Debugging aids. */
4623 4560
4624 static Lisp_Object 4561 static Lisp_Object
4625 gc_plist_hack (CONST char *name, int value, Lisp_Object tail) 4562 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4626 { 4563 {
4628 or portable numeric datatypes, or bit-vectors, or characters, or 4565 or portable numeric datatypes, or bit-vectors, or characters, or
4629 arrays, or exceptions, or ...) */ 4566 arrays, or exceptions, or ...) */
4630 return cons3 (intern (name), make_int (value), tail); 4567 return cons3 (intern (name), make_int (value), tail);
4631 } 4568 }
4632 4569
4633 #define HACK_O_MATIC(type, name, pl) \ 4570 #define HACK_O_MATIC(type, name, pl) do { \
4634 { \ 4571 int s = 0; \
4635 int s = 0; \ 4572 struct type##_block *x = current_##type##_block; \
4636 struct type##_block *x = current_##type##_block; \ 4573 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
4637 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ 4574 (pl) = gc_plist_hack ((name), s, (pl)); \
4638 (pl) = gc_plist_hack ((name), s, (pl)); \ 4575 } while (0)
4639 }
4640 4576
4641 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* 4577 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4642 Reclaim storage for Lisp objects no longer needed. 4578 Reclaim storage for Lisp objects no longer needed.
4643 Return info on amount of space in use: 4579 Return info on amount of space in use:
4644 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) 4580 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4946 void 4882 void
4947 init_alloc_once_early (void) 4883 init_alloc_once_early (void)
4948 { 4884 {
4949 int iii; 4885 int iii;
4950 4886
4951 #ifdef PURESTAT
4952 for (iii = 0; iii < countof (purestats); iii++)
4953 {
4954 if (! purestats[iii]) continue;
4955 purestats[iii]->nobjects = 0;
4956 purestats[iii]->nbytes = 0;
4957 }
4958 purecopying_for_bytecode = 0;
4959 #endif /* PURESTAT */
4960
4961 last_lrecord_type_index_assigned = -1; 4887 last_lrecord_type_index_assigned = -1;
4962 for (iii = 0; iii < countof (lrecord_implementations_table); iii++) 4888 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4963 { 4889 {
4964 lrecord_implementations_table[iii] = 0; 4890 lrecord_implementations_table[iii] = 0;
4965 } 4891 }