Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 424:11054d720c21 r21-2-20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-20
author cvs
date Mon, 13 Aug 2007 11:26:11 +0200
parents 41dbb7a9d5f2
children
comparison
equal deleted inserted replaced
423:28d9c139be4c 424:11054d720c21
34 and various changes for Mule, for 19.12. 34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13. 35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14. 36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code. 37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2. 38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. 39 og: Killed the purespace. Portable dumper.
40 */ 40 */
41 41
42 #include <config.h> 42 #include <config.h>
43 #include "lisp.h" 43 #include "lisp.h"
44 44
55 #include "opaque.h" 55 #include "opaque.h"
56 #include "redisplay.h" 56 #include "redisplay.h"
57 #include "specifier.h" 57 #include "specifier.h"
58 #include "sysfile.h" 58 #include "sysfile.h"
59 #include "window.h" 59 #include "window.h"
60 #include "console-stream.h"
60 61
61 #ifdef DOUG_LEA_MALLOC 62 #ifdef DOUG_LEA_MALLOC
62 #include <malloc.h> 63 #include <malloc.h>
64 #endif
65
66 #ifdef HAVE_MMAP
67 #include <unistd.h>
68 #include <sys/mman.h>
69 #endif
70
71 #ifdef PDUMP
72 typedef struct
73 {
74 const struct lrecord_description *desc;
75 int count;
76 } pdump_reloc_table;
77
78 static char *pdump_rt_list = 0;
63 #endif 79 #endif
64 80
65 EXFUN (Fgarbage_collect, 0); 81 EXFUN (Fgarbage_collect, 0);
66 82
67 /* Return the true size of a struct with a variable-length array field. */ 83 /* Return the true size of a struct with a variable-length array field. */
181 #endif 197 #endif
182 198
183 int 199 int
184 c_readonly (Lisp_Object obj) 200 c_readonly (Lisp_Object obj)
185 { 201 {
186 return POINTER_TYPE_P (XGCTYPE (obj)) && C_READONLY (obj); 202 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
187 } 203 }
188 204
189 int 205 int
190 lisp_readonly (Lisp_Object obj) 206 lisp_readonly (Lisp_Object obj)
191 { 207 {
192 return POINTER_TYPE_P (XGCTYPE (obj)) && LISP_READONLY (obj); 208 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
193 } 209 }
194 210
195 211
196 /* Maximum amount of C stack to save when a GC happens. */ 212 /* Maximum amount of C stack to save when a GC happens. */
197 213
357 { 373 {
358 int len = strlen (str) + 1; /* for stupid terminating 0 */ 374 int len = strlen (str) + 1; /* for stupid terminating 0 */
359 375
360 void *val = xmalloc (len); 376 void *val = xmalloc (len);
361 if (val == 0) return 0; 377 if (val == 0) return 0;
362 memcpy (val, str, len); 378 return (char *) memcpy (val, str, len);
363 return (char *) val;
364 } 379 }
365 380
366 #ifdef NEED_STRDUP 381 #ifdef NEED_STRDUP
367 char * 382 char *
368 strdup (CONST char *s) 383 strdup (CONST char *s)
373 388
374 389
375 static void * 390 static void *
376 allocate_lisp_storage (size_t size) 391 allocate_lisp_storage (size_t size)
377 { 392 {
378 void *p = xmalloc (size); 393 return xmalloc (size);
379 return p;
380 } 394 }
381 395
382 396
383 /* lrecords are chained together through their "next.v" field. 397 /* lrecords are chained together through their "next.v" field.
384 * After doing the mark phase, the GC will walk this linked 398 * After doing the mark phase, the GC will walk this linked
463 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer) 477 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
464 (header, 1)); 478 (header, 1));
465 } 479 }
466 } 480 }
467 481
468
469 /* This must not be called -- it just serves as for EQ test
470 * If lheader->implementation->finalizer is this_marks_a_marked_record,
471 * then lrecord has been marked by the GC sweeper
472 * header->implementation is put back to its correct value by
473 * sweep_records */
474 void
475 this_marks_a_marked_record (void *dummy0, int dummy1)
476 {
477 abort ();
478 }
479
480 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck 482 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
481 in CONST space and you get SEGV's if you attempt to mark them. 483 in CONST space and you get SEGV's if you attempt to mark them.
482 This sits in lheader->implementation->marker. */ 484 This sits in lheader->implementation->marker. */
483 485
484 Lisp_Object 486 Lisp_Object
485 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object)) 487 this_one_is_unmarkable (Lisp_Object obj)
486 { 488 {
487 abort (); 489 abort ();
488 return Qnil; 490 return Qnil;
489 }
490
491 /* XGCTYPE for records */
492 int
493 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
494 {
495 CONST struct lrecord_implementation *imp;
496
497 if (XGCTYPE (frob) != Lisp_Type_Record)
498 return 0;
499
500 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
501 return imp == type;
502 } 491 }
503 492
504 493
505 /************************************************************************/ 494 /************************************************************************/
506 /* Debugger support */ 495 /* Debugger support */
941 /* conses are used and freed so often that we set this really high */ 930 /* conses are used and freed so often that we set this really high */
942 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ 931 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
943 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 932 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
944 933
945 static Lisp_Object 934 static Lisp_Object
946 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object)) 935 mark_cons (Lisp_Object obj)
947 { 936 {
948 if (GC_NILP (XCDR (obj))) 937 if (NILP (XCDR (obj)))
949 return XCAR (obj); 938 return XCAR (obj);
950 939
951 markobj (XCAR (obj)); 940 mark_object (XCAR (obj));
952 return XCDR (obj); 941 return XCDR (obj);
953 } 942 }
954 943
955 static int 944 static int
956 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) 945 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1094 { 1083 {
1095 CHECK_NATNUM (length); 1084 CHECK_NATNUM (length);
1096 1085
1097 { 1086 {
1098 Lisp_Object val = Qnil; 1087 Lisp_Object val = Qnil;
1099 int size = XINT (length); 1088 size_t size = XINT (length);
1100 1089
1101 while (size-- > 0) 1090 while (size--)
1102 val = Fcons (init, val); 1091 val = Fcons (init, val);
1103 return val; 1092 return val;
1104 } 1093 }
1105 } 1094 }
1106 1095
1133 /************************************************************************/ 1122 /************************************************************************/
1134 /* Vector allocation */ 1123 /* Vector allocation */
1135 /************************************************************************/ 1124 /************************************************************************/
1136 1125
1137 static Lisp_Object 1126 static Lisp_Object
1138 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1127 mark_vector (Lisp_Object obj)
1139 { 1128 {
1140 Lisp_Vector *ptr = XVECTOR (obj); 1129 Lisp_Vector *ptr = XVECTOR (obj);
1141 int len = vector_length (ptr); 1130 int len = vector_length (ptr);
1142 int i; 1131 int i;
1143 1132
1144 for (i = 0; i < len - 1; i++) 1133 for (i = 0; i < len - 1; i++)
1145 markobj (ptr->contents[i]); 1134 mark_object (ptr->contents[i]);
1146 return (len > 0) ? ptr->contents[len - 1] : Qnil; 1135 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1147 } 1136 }
1148 1137
1149 static size_t 1138 static size_t
1150 size_vector (CONST void *lheader) 1139 size_vector (CONST void *lheader)
1170 return 1; 1159 return 1;
1171 } 1160 }
1172 1161
1173 static const struct lrecord_description vector_description[] = { 1162 static const struct lrecord_description vector_description[] = {
1174 { XD_LONG, offsetof(struct Lisp_Vector, size) }, 1163 { XD_LONG, offsetof(struct Lisp_Vector, size) },
1175 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0) } 1164 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1165 { XD_END }
1176 }; 1166 };
1177 1167
1178 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, 1168 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1179 mark_vector, print_vector, 0, 1169 mark_vector, print_vector, 0,
1180 vector_equal, 1170 vector_equal,
1543 if (!NILP (constants)) 1533 if (!NILP (constants))
1544 CHECK_VECTOR (constants); 1534 CHECK_VECTOR (constants);
1545 f->constants = constants; 1535 f->constants = constants;
1546 1536
1547 CHECK_NATNUM (stack_depth); 1537 CHECK_NATNUM (stack_depth);
1548 f->stack_depth = XINT (stack_depth); 1538 f->stack_depth = XINT (stack_depth);
1549 1539
1550 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1540 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1551 if (!NILP (Vcurrent_compiled_function_annotation)) 1541 if (!NILP (Vcurrent_compiled_function_annotation))
1552 f->annotated = Fcopy (Vcurrent_compiled_function_annotation); 1542 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1553 else if (!NILP (Vload_file_name_internal_the_purecopy)) 1543 else if (!NILP (Vload_file_name_internal_the_purecopy))
1555 else if (!NILP (Vload_file_name_internal)) 1545 else if (!NILP (Vload_file_name_internal))
1556 { 1546 {
1557 struct gcpro gcpro1; 1547 struct gcpro gcpro1;
1558 GCPRO1 (fun); /* don't let fun get reaped */ 1548 GCPRO1 (fun); /* don't let fun get reaped */
1559 Vload_file_name_internal_the_purecopy = 1549 Vload_file_name_internal_the_purecopy =
1560 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal)); 1550 Ffile_name_nondirectory (Vload_file_name_internal);
1561 f->annotated = Vload_file_name_internal_the_purecopy; 1551 f->annotated = Vload_file_name_internal_the_purecopy;
1562 UNGCPRO; 1552 UNGCPRO;
1563 } 1553 }
1564 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ 1554 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1565 1555
1734 /* strings are used and freed quite often */ 1724 /* strings are used and freed quite often */
1735 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ 1725 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1736 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 1726 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1737 1727
1738 static Lisp_Object 1728 static Lisp_Object
1739 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1729 mark_string (Lisp_Object obj)
1740 { 1730 {
1741 struct Lisp_String *ptr = XSTRING (obj); 1731 struct Lisp_String *ptr = XSTRING (obj);
1742 1732
1743 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist))) 1733 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1744 flush_cached_extent_info (XCAR (ptr->plist)); 1734 flush_cached_extent_info (XCAR (ptr->plist));
1745 return ptr->plist; 1735 return ptr->plist;
1746 } 1736 }
1747 1737
1748 static int 1738 static int
1752 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && 1742 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1753 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); 1743 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1754 } 1744 }
1755 1745
1756 static const struct lrecord_description string_description[] = { 1746 static const struct lrecord_description string_description[] = {
1757 { XD_STRING_DATA, offsetof(Lisp_String, data) }, 1747 { XD_BYTECOUNT, offsetof(Lisp_String, size) },
1758 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 }, 1748 { XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1) },
1749 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 },
1759 { XD_END } 1750 { XD_END }
1760 }; 1751 };
1761 1752
1762 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, 1753 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1763 mark_string, print_string, 1754 mark_string, print_string,
1789 /* Contents of string_chars_block->string_chars are interleaved 1780 /* Contents of string_chars_block->string_chars are interleaved
1790 string_chars structures (see below) and the actual string data */ 1781 string_chars structures (see below) and the actual string data */
1791 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE]; 1782 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1792 }; 1783 };
1793 1784
1794 struct string_chars_block *first_string_chars_block; 1785 static struct string_chars_block *first_string_chars_block;
1795 struct string_chars_block *current_string_chars_block; 1786 static struct string_chars_block *current_string_chars_block;
1796 1787
1797 /* If SIZE is the length of a string, this returns how many bytes 1788 /* If SIZE is the length of a string, this returns how many bytes
1798 * the string occupies in string_chars_block->string_chars 1789 * the string occupies in string_chars_block->string_chars
1799 * (including alignment padding). 1790 * (including alignment padding).
1800 */ 1791 */
2077 if (len == 1) 2068 if (len == 1)
2078 /* Optimize the single-byte case */ 2069 /* Optimize the single-byte case */
2079 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val)); 2070 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2080 else 2071 else
2081 { 2072 {
2082 int i; 2073 size_t i;
2083 Bufbyte *ptr = XSTRING_DATA (val); 2074 Bufbyte *ptr = XSTRING_DATA (val);
2084 2075
2085 for (i = XINT (length); i; i--) 2076 for (i = XINT (length); i; i--)
2086 { 2077 {
2087 Bufbyte *init_ptr = init_str; 2078 Bufbyte *init_ptr = init_str;
2200 It is similar to the Blocktype class. 2191 It is similar to the Blocktype class.
2201 2192
2202 It works like this: 2193 It works like this:
2203 2194
2204 1) Create an lcrecord-list object using make_lcrecord_list(). 2195 1) Create an lcrecord-list object using make_lcrecord_list().
2205 This is often done at initialization. Remember to staticpro 2196 This is often done at initialization. Remember to staticpro_nodump
2206 this object! The arguments to make_lcrecord_list() are the 2197 this object! The arguments to make_lcrecord_list() are the
2207 same as would be passed to alloc_lcrecord(). 2198 same as would be passed to alloc_lcrecord().
2208 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord() 2199 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2209 and pass the lcrecord-list earlier created. 2200 and pass the lcrecord-list earlier created.
2210 3) When done with the lcrecord, call free_managed_lcrecord(). 2201 3) When done with the lcrecord, call free_managed_lcrecord().
2221 at the time that free_managed_lcrecord() is called. 2212 at the time that free_managed_lcrecord() is called.
2222 2213
2223 */ 2214 */
2224 2215
2225 static Lisp_Object 2216 static Lisp_Object
2226 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) 2217 mark_lcrecord_list (Lisp_Object obj)
2227 { 2218 {
2228 struct lcrecord_list *list = XLCRECORD_LIST (obj); 2219 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2229 Lisp_Object chain = list->free; 2220 Lisp_Object chain = list->free;
2230 2221
2231 while (!NILP (chain)) 2222 while (!NILP (chain))
2374 2365
2375 struct gcpro *gcprolist; 2366 struct gcpro *gcprolist;
2376 2367
2377 /* 415 used Mly 29-Jun-93 */ 2368 /* 415 used Mly 29-Jun-93 */
2378 /* 1327 used slb 28-Feb-98 */ 2369 /* 1327 used slb 28-Feb-98 */
2370 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2379 #ifdef HAVE_SHLIB 2371 #ifdef HAVE_SHLIB
2380 #define NSTATICS 4000 2372 #define NSTATICS 4000
2381 #else 2373 #else
2382 #define NSTATICS 2000 2374 #define NSTATICS 2000
2383 #endif 2375 #endif
2397 /* by Lisp attempting to load a DLL. */ 2389 /* by Lisp attempting to load a DLL. */
2398 abort (); 2390 abort ();
2399 staticvec[staticidx++] = varaddress; 2391 staticvec[staticidx++] = varaddress;
2400 } 2392 }
2401 2393
2394 /* Not "static" because of linker lossage on some systems */
2395 Lisp_Object *staticvec_nodump[200]
2396 /* Force it into data space! */
2397 = {0};
2398 static int staticidx_nodump;
2399
2400 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2401 */
2402 void
2403 staticpro_nodump (Lisp_Object *varaddress)
2404 {
2405 if (staticidx_nodump >= countof (staticvec_nodump))
2406 /* #### This is now a dubious abort() since this routine may be called */
2407 /* by Lisp attempting to load a DLL. */
2408 abort ();
2409 staticvec_nodump[staticidx_nodump++] = varaddress;
2410 }
2411
2412 /* Not "static" because of linker lossage on some systems */
2413 struct {
2414 void *data;
2415 const struct struct_description *desc;
2416 } dumpstructvec[200];
2417
2418 static int dumpstructidx;
2419
2420 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2421 */
2422 void
2423 dumpstruct (void *varaddress, const struct struct_description *desc)
2424 {
2425 if (dumpstructidx >= countof (dumpstructvec))
2426 abort ();
2427 dumpstructvec[dumpstructidx].data = varaddress;
2428 dumpstructvec[dumpstructidx].desc = desc;
2429 dumpstructidx++;
2430 }
2431
2432 Lisp_Object *pdump_wirevec[50];
2433 static int pdump_wireidx;
2434
2435 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2436 */
2437 void
2438 pdump_wire (Lisp_Object *varaddress)
2439 {
2440 if (pdump_wireidx >= countof (pdump_wirevec))
2441 abort ();
2442 pdump_wirevec[pdump_wireidx++] = varaddress;
2443 }
2444
2445
2446 Lisp_Object *pdump_wirevec_list[50];
2447 static int pdump_wireidx_list;
2448
2449 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2450 */
2451 void
2452 pdump_wire_list (Lisp_Object *varaddress)
2453 {
2454 if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2455 abort ();
2456 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2457 }
2458
2402 2459
2403 /* Mark reference to a Lisp_Object. If the object referred to has not been 2460 /* Mark reference to a Lisp_Object. If the object referred to has not been
2404 seen yet, recursively mark all the references contained in it. */ 2461 seen yet, recursively mark all the references contained in it. */
2405 2462
2406 static void 2463 void
2407 mark_object (Lisp_Object obj) 2464 mark_object (Lisp_Object obj)
2408 { 2465 {
2409 tail_recurse: 2466 tail_recurse:
2410 2467
2411 #ifdef ERROR_CHECK_GC 2468 #ifdef ERROR_CHECK_GC
2412 assert (! (GC_EQ (obj, Qnull_pointer))); 2469 assert (! (EQ (obj, Qnull_pointer)));
2413 #endif 2470 #endif
2414 /* Checks we used to perform */ 2471 /* Checks we used to perform */
2415 /* if (EQ (obj, Qnull_pointer)) return; */ 2472 /* if (EQ (obj, Qnull_pointer)) return; */
2416 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ 2473 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2417 /* if (PURIFIED (XPNTR (obj))) return; */ 2474 /* if (PURIFIED (XPNTR (obj))) return; */
2418 2475
2419 if (XGCTYPE (obj) == Lisp_Type_Record) 2476 if (XTYPE (obj) == Lisp_Type_Record)
2420 { 2477 {
2421 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 2478 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2422 #if defined (ERROR_CHECK_GC) 2479 #if defined (ERROR_CHECK_GC)
2423 assert (lheader->type <= last_lrecord_type_index_assigned); 2480 assert (lheader->type <= last_lrecord_type_index_assigned);
2424 #endif 2481 #endif
2435 if (!implementation->basic_p) 2492 if (!implementation->basic_p)
2436 assert (! ((struct lcrecord_header *) lheader)->free); 2493 assert (! ((struct lcrecord_header *) lheader)->free);
2437 #endif 2494 #endif
2438 if (implementation->marker) 2495 if (implementation->marker)
2439 { 2496 {
2440 obj = implementation->marker (obj, mark_object); 2497 obj = implementation->marker (obj);
2441 if (!GC_NILP (obj)) goto tail_recurse; 2498 if (!NILP (obj)) goto tail_recurse;
2442 } 2499 }
2443 } 2500 }
2444 } 2501 }
2445 } 2502 }
2446 2503
2909 { 2966 {
2910 #ifdef ERROR_CHECK_GC 2967 #ifdef ERROR_CHECK_GC
2911 /* Perhaps this will catch freeing an already-freed marker. */ 2968 /* Perhaps this will catch freeing an already-freed marker. */
2912 Lisp_Object temmy; 2969 Lisp_Object temmy;
2913 XSETMARKER (temmy, ptr); 2970 XSETMARKER (temmy, ptr);
2914 assert (GC_MARKERP (temmy)); 2971 assert (MARKERP (temmy));
2915 #endif /* ERROR_CHECK_GC */ 2972 #endif /* ERROR_CHECK_GC */
2916 2973
2917 #ifndef ALLOC_NO_POOLS 2974 #ifndef ALLOC_NO_POOLS
2918 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr); 2975 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2919 #endif /* ALLOC_NO_POOLS */ 2976 #endif /* ALLOC_NO_POOLS */
3122 gc_count_short_string_total_size = num_small_bytes; 3179 gc_count_short_string_total_size = num_small_bytes;
3123 } 3180 }
3124 3181
3125 3182
3126 /* I hate duplicating all this crap! */ 3183 /* I hate duplicating all this crap! */
3127 static int 3184 int
3128 marked_p (Lisp_Object obj) 3185 marked_p (Lisp_Object obj)
3129 { 3186 {
3130 #ifdef ERROR_CHECK_GC 3187 #ifdef ERROR_CHECK_GC
3131 assert (! (GC_EQ (obj, Qnull_pointer))); 3188 assert (! (EQ (obj, Qnull_pointer)));
3132 #endif 3189 #endif
3133 /* Checks we used to perform. */ 3190 /* Checks we used to perform. */
3134 /* if (EQ (obj, Qnull_pointer)) return 1; */ 3191 /* if (EQ (obj, Qnull_pointer)) return 1; */
3135 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ 3192 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3136 /* if (PURIFIED (XPNTR (obj))) return 1; */ 3193 /* if (PURIFIED (XPNTR (obj))) return 1; */
3137 3194
3138 if (XGCTYPE (obj) == Lisp_Type_Record) 3195 if (XTYPE (obj) == Lisp_Type_Record)
3139 { 3196 {
3140 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 3197 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3141 #if defined (ERROR_CHECK_GC) 3198 #if defined (ERROR_CHECK_GC)
3142 assert (lheader->type <= last_lrecord_type_index_assigned); 3199 assert (lheader->type <= last_lrecord_type_index_assigned);
3143 #endif 3200 #endif
3203 Dechain each one first from the buffer into which it points. */ 3260 Dechain each one first from the buffer into which it points. */
3204 sweep_markers (); 3261 sweep_markers ();
3205 3262
3206 sweep_events (); 3263 sweep_events ();
3207 3264
3265 #ifdef PDUMP
3266 /* Unmark all dumped objects */
3267 {
3268 int i;
3269 char *p = pdump_rt_list;
3270 if(p)
3271 for(;;)
3272 {
3273 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3274 p += sizeof (pdump_reloc_table);
3275 if (rt->desc) {
3276 for (i=0; i<rt->count; i++)
3277 {
3278 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3279 p += sizeof (EMACS_INT);
3280 }
3281 } else
3282 break;
3283 }
3284 }
3285 #endif
3208 } 3286 }
3209 3287
3210 /* Clearing for disksave. */ 3288 /* Clearing for disksave. */
3211 3289
3212 void 3290 void
3404 3482
3405 { /* staticpro() */ 3483 { /* staticpro() */
3406 int i; 3484 int i;
3407 for (i = 0; i < staticidx; i++) 3485 for (i = 0; i < staticidx; i++)
3408 mark_object (*(staticvec[i])); 3486 mark_object (*(staticvec[i]));
3487 for (i = 0; i < staticidx_nodump; i++)
3488 mark_object (*(staticvec_nodump[i]));
3409 } 3489 }
3410 3490
3411 { /* GCPRO() */ 3491 { /* GCPRO() */
3412 struct gcpro *tail; 3492 struct gcpro *tail;
3413 int i; 3493 int i;
3448 for (i = 0; i < nargs; i++) 3528 for (i = 0; i < nargs; i++)
3449 mark_object (backlist->args[i]); 3529 mark_object (backlist->args[i]);
3450 } 3530 }
3451 } 3531 }
3452 3532
3453 mark_redisplay (mark_object); 3533 mark_redisplay ();
3454 mark_profiling_info (mark_object); 3534 mark_profiling_info ();
3455 3535
3456 /* OK, now do the after-mark stuff. This is for things that 3536 /* OK, now do the after-mark stuff. This is for things that
3457 are only marked when something else is marked (e.g. weak hash tables). 3537 are only marked when something else is marked (e.g. weak hash tables).
3458 There may be complex dependencies between such objects -- e.g. 3538 There may be complex dependencies between such objects -- e.g.
3459 a weak hash table might be unmarked, but after processing a later 3539 a weak hash table might be unmarked, but after processing a later
3460 weak hash table, the former one might get marked. So we have to 3540 weak hash table, the former one might get marked. So we have to
3461 iterate until nothing more gets marked. */ 3541 iterate until nothing more gets marked. */
3462 3542
3463 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 || 3543 while (finish_marking_weak_hash_tables () > 0 ||
3464 finish_marking_weak_lists (marked_p, mark_object) > 0) 3544 finish_marking_weak_lists () > 0)
3465 ; 3545 ;
3466 3546
3467 /* And prune (this needs to be called after everything else has been 3547 /* And prune (this needs to be called after everything else has been
3468 marked and before we do any sweeping). */ 3548 marked and before we do any sweeping). */
3469 /* #### this is somewhat ad-hoc and should probably be an object 3549 /* #### this is somewhat ad-hoc and should probably be an object
3470 method */ 3550 method */
3471 prune_weak_hash_tables (marked_p); 3551 prune_weak_hash_tables ();
3472 prune_weak_lists (marked_p); 3552 prune_weak_lists ();
3473 prune_specifiers (marked_p); 3553 prune_specifiers ();
3474 prune_syntax_tables (marked_p); 3554 prune_syntax_tables ();
3475 3555
3476 gc_sweep (); 3556 gc_sweep ();
3477 3557
3478 consing_since_gc = 0; 3558 consing_since_gc = 0;
3479 #ifndef DEBUG_XEMACS 3559 #ifndef DEBUG_XEMACS
3563 int i; 3643 int i;
3564 int gc_count_vector_total_size = 0; 3644 int gc_count_vector_total_size = 0;
3565 3645
3566 garbage_collect_1 (); 3646 garbage_collect_1 ();
3567 3647
3568 for (i = 0; i < last_lrecord_type_index_assigned; i++) 3648 for (i = 0; i <= last_lrecord_type_index_assigned; i++)
3569 { 3649 {
3570 if (lcrecord_stats[i].bytes_in_use != 0 3650 if (lcrecord_stats[i].bytes_in_use != 0
3571 || lcrecord_stats[i].bytes_freed != 0 3651 || lcrecord_stats[i].bytes_freed != 0
3572 || lcrecord_stats[i].instances_on_free_list != 0) 3652 || lcrecord_stats[i].instances_on_free_list != 0)
3573 { 3653 {
3837 #endif /* MEMORY_USAGE_STATS */ 3917 #endif /* MEMORY_USAGE_STATS */
3838 3918
3839 3919
3840 /* Initialization */ 3920 /* Initialization */
3841 void 3921 void
3842 init_alloc_once_early (void) 3922 reinit_alloc_once_early (void)
3843 { 3923 {
3844 int iii;
3845
3846 last_lrecord_type_index_assigned = -1;
3847 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3848 {
3849 lrecord_implementations_table[iii] = 0;
3850 }
3851
3852 /*
3853 * All the staticly
3854 * defined subr lrecords were initialized with lheader->type == 0.
3855 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3856 * assigned to lrecord_subr so that those predefined indexes match
3857 * reality.
3858 */
3859 lrecord_type_index (&lrecord_subr);
3860 assert (*(lrecord_subr.lrecord_type_index) == 0);
3861 /*
3862 * The same is true for symbol_value_forward objects, except the
3863 * type is 1.
3864 */
3865 lrecord_type_index (&lrecord_symbol_value_forward);
3866 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3867
3868 gc_generation_number[0] = 0; 3924 gc_generation_number[0] = 0;
3869 /* purify_flag 1 is correct even if CANNOT_DUMP. 3925 /* purify_flag 1 is correct even if CANNOT_DUMP.
3870 * loadup.el will set to nil at end. */ 3926 * loadup.el will set to nil at end. */
3871 purify_flag = 1; 3927 purify_flag = 1;
3872 breathing_space = 0; 3928 breathing_space = 0;
3892 init_marker_alloc (); 3948 init_marker_alloc ();
3893 init_extent_alloc (); 3949 init_extent_alloc ();
3894 init_event_alloc (); 3950 init_event_alloc ();
3895 3951
3896 ignore_malloc_warnings = 0; 3952 ignore_malloc_warnings = 0;
3897 staticidx = 0; 3953
3954 staticidx_nodump = 0;
3955 dumpstructidx = 0;
3956 pdump_wireidx = 0;
3957
3898 consing_since_gc = 0; 3958 consing_since_gc = 0;
3899 #if 1 3959 #if 1
3900 gc_cons_threshold = 500000; /* XEmacs change */ 3960 gc_cons_threshold = 500000; /* XEmacs change */
3901 #else 3961 #else
3902 gc_cons_threshold = 15000; /* debugging */ 3962 gc_cons_threshold = 15000; /* debugging */
3919 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; 3979 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3920 ERROR_ME_WARN. 3980 ERROR_ME_WARN.
3921 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 3981 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3922 3333632; 3982 3333632;
3923 #endif /* ERROR_CHECK_TYPECHECK */ 3983 #endif /* ERROR_CHECK_TYPECHECK */
3984 }
3985
3986 void
3987 init_alloc_once_early (void)
3988 {
3989 int iii;
3990
3991 reinit_alloc_once_early ();
3992
3993 last_lrecord_type_index_assigned = -1;
3994 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3995 {
3996 lrecord_implementations_table[iii] = 0;
3997 }
3998
3999 /*
4000 * All the staticly
4001 * defined subr lrecords were initialized with lheader->type == 0.
4002 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4003 * assigned to lrecord_subr so that those predefined indexes match
4004 * reality.
4005 */
4006 lrecord_type_index (&lrecord_subr);
4007 assert (*(lrecord_subr.lrecord_type_index) == 0);
4008 /*
4009 * The same is true for symbol_value_forward objects, except the
4010 * type is 1.
4011 */
4012 lrecord_type_index (&lrecord_symbol_value_forward);
4013 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
4014
4015 staticidx = 0;
3924 } 4016 }
3925 4017
3926 int pure_bytes_used = 0; 4018 int pure_bytes_used = 0;
3927 4019
3928 void 4020 void
4028 This is printed in the echo area. If the selected frame is on a 4120 This is printed in the echo area. If the selected frame is on a
4029 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer 4121 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4030 image instance) in the domain of the selected frame, the mouse pointer 4122 image instance) in the domain of the selected frame, the mouse pointer
4031 will change instead of this message being printed. 4123 will change instead of this message being printed.
4032 */ ); 4124 */ );
4033 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message, 4125 Vgc_message = build_string (gc_default_message);
4034 countof (gc_default_message) - 1);
4035 4126
4036 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* 4127 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4037 Pointer glyph used to indicate that a garbage collection is in progress. 4128 Pointer glyph used to indicate that a garbage collection is in progress.
4038 If the selected window is on a window system and this glyph specifies a 4129 If the selected window is on a window system and this glyph specifies a
4039 value (i.e. a pointer image instance) in the domain of the selected 4130 value (i.e. a pointer image instance) in the domain of the selected
4046 void 4137 void
4047 complex_vars_of_alloc (void) 4138 complex_vars_of_alloc (void)
4048 { 4139 {
4049 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); 4140 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4050 } 4141 }
4142
4143
4144 #ifdef PDUMP
4145
4146 /* The structure of the file
4147 *
4148 * 0 - header
4149 * 256 - dumped objects
4150 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4151 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4152 * - nb_structdmp*pair(void *, adr) for pointers to structures
4153 * - lrecord_implementations_table[]
4154 * - relocation table
4155 * - wired variable address/value couples with the count preceding the list
4156 */
4157 typedef struct
4158 {
4159 char signature[8];
4160 EMACS_UINT stab_offset;
4161 EMACS_UINT reloc_address;
4162 int nb_staticpro;
4163 int nb_structdmp;
4164 int last_type;
4165 } dump_header;
4166
4167 char *pdump_start, *pdump_end;
4168
4169 static const unsigned char align_table[256] =
4170 {
4171 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4172 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4173 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4174 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4175 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4176 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4177 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4178 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4179 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4180 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4181 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4182 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4183 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4184 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4185 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4186 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
4187 };
4188
4189 typedef struct pdump_entry_list_elmt
4190 {
4191 struct pdump_entry_list_elmt *next;
4192 const void *obj;
4193 size_t size;
4194 int count;
4195 int is_lrecord;
4196 EMACS_INT save_offset;
4197 } pdump_entry_list_elmt;
4198
4199 typedef struct
4200 {
4201 pdump_entry_list_elmt *first;
4202 int align;
4203 int count;
4204 } pdump_entry_list;
4205
4206 typedef struct pdump_struct_list_elmt
4207 {
4208 pdump_entry_list list;
4209 const struct struct_description *sdesc;
4210 } pdump_struct_list_elmt;
4211
4212 typedef struct
4213 {
4214 pdump_struct_list_elmt *list;
4215 int count;
4216 int size;
4217 } pdump_struct_list;
4218
4219 static pdump_entry_list pdump_object_table[256];
4220 static pdump_entry_list pdump_opaque_data_list;
4221 static pdump_struct_list pdump_struct_table;
4222 static pdump_entry_list_elmt *pdump_qnil;
4223
4224 static int pdump_alert_undump_object[256];
4225
4226 static unsigned long cur_offset;
4227 static size_t max_size;
4228 static int pdump_fd;
4229 static void *pdump_buf;
4230
4231 #define PDUMP_HASHSIZE 200001
4232
4233 static pdump_entry_list_elmt **pdump_hash;
4234
4235 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4236 static int
4237 pdump_make_hash (const void *obj)
4238 {
4239 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4240 }
4241
4242 static pdump_entry_list_elmt *
4243 pdump_get_entry (const void *obj)
4244 {
4245 int pos = pdump_make_hash(obj);
4246 pdump_entry_list_elmt *e;
4247 while ((e = pdump_hash[pos]) != 0)
4248 {
4249 if (e->obj == obj)
4250 return e;
4251
4252 pos++;
4253 if (pos == PDUMP_HASHSIZE)
4254 pos = 0;
4255 }
4256 return 0;
4257 }
4258
4259 static void
4260 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
4261 {
4262 pdump_entry_list_elmt *e;
4263 int align;
4264 int pos = pdump_make_hash (obj);
4265
4266 while ((e = pdump_hash[pos]) != 0)
4267 {
4268 if (e->obj == obj)
4269 return;
4270
4271 pos++;
4272 if (pos == PDUMP_HASHSIZE)
4273 pos = 0;
4274 }
4275
4276 e = malloc (sizeof (pdump_entry_list_elmt));
4277
4278 e->next = list->first;
4279 e->obj = obj;
4280 e->size = size;
4281 e->count = count;
4282 e->is_lrecord = is_lrecord;
4283 list->first = e;
4284
4285 list->count += count;
4286 pdump_hash[pos] = e;
4287
4288 align = align_table[size & 255];
4289 if (align<2 && is_lrecord)
4290 align = 2;
4291
4292 if(align < list->align)
4293 list->align = align;
4294 }
4295
4296 static pdump_entry_list *
4297 pdump_get_entry_list(const struct struct_description *sdesc)
4298 {
4299 int i;
4300 for(i=0; i<pdump_struct_table.count; i++)
4301 if (pdump_struct_table.list[i].sdesc == sdesc)
4302 return &pdump_struct_table.list[i].list;
4303
4304 if (pdump_struct_table.size <= pdump_struct_table.count)
4305 {
4306 if (pdump_struct_table.size == -1)
4307 pdump_struct_table.size = 10;
4308 else
4309 pdump_struct_table.size = pdump_struct_table.size * 2;
4310 pdump_struct_table.list = xrealloc (pdump_struct_table.list,
4311 pdump_struct_table.size*sizeof (pdump_struct_list_elmt));
4312 }
4313 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4314 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4315 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4316 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4317
4318 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4319 }
4320
4321 static struct {
4322 Lisp_Object obj;
4323 int position;
4324 int offset;
4325 } backtrace[65536];
4326
4327 static int depth;
4328
4329 static void pdump_backtrace (void)
4330 {
4331 int i;
4332 fprintf (stderr, "pdump backtrace :\n");
4333 for (i=0;i<depth;i++)
4334 {
4335 if (!backtrace[i].obj)
4336 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4337 else
4338 {
4339 fprintf (stderr, " - %s (%d, %d)\n",
4340 XRECORD_LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4341 backtrace[i].position,
4342 backtrace[i].offset);
4343 }
4344 }
4345 }
4346
4347 static void pdump_register_object (Lisp_Object obj);
4348 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4349
4350 static EMACS_INT
4351 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4352 {
4353 EMACS_INT count;
4354 const void *irdata;
4355
4356 int line = XD_INDIRECT_VAL (code);
4357 int delta = XD_INDIRECT_DELTA (code);
4358
4359 irdata = ((char *)idata) + idesc[line].offset;
4360 switch (idesc[line].type) {
4361 case XD_SIZE_T:
4362 count = *(size_t *)irdata;
4363 break;
4364 case XD_INT:
4365 count = *(int *)irdata;
4366 break;
4367 case XD_LONG:
4368 count = *(long *)irdata;
4369 break;
4370 case XD_BYTECOUNT:
4371 count = *(Bytecount *)irdata;
4372 break;
4373 default:
4374 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4375 pdump_backtrace ();
4376 abort ();
4377 }
4378 count += delta;
4379 return count;
4380 }
4381
4382 static void
4383 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4384 {
4385 int pos;
4386 const void *rdata;
4387
4388 restart:
4389 for (pos = 0; desc[pos].type != XD_END; pos++)
4390 {
4391 backtrace[me].position = pos;
4392 backtrace[me].offset = desc[pos].offset;
4393
4394 rdata = ((const char *)data) + desc[pos].offset;
4395 switch(desc[pos].type)
4396 {
4397 case XD_SPECIFIER_END:
4398 pos = 0;
4399 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description;
4400 goto restart;
4401 case XD_SIZE_T:
4402 case XD_INT:
4403 case XD_LONG:
4404 case XD_BYTECOUNT:
4405 case XD_LO_RESET_NIL:
4406 case XD_INT_RESET:
4407 case XD_LO_LINK:
4408 break;
4409 case XD_OPAQUE_DATA_PTR:
4410 {
4411 EMACS_INT count = desc[pos].data1;
4412 if (XD_IS_INDIRECT(count))
4413 count = pdump_get_indirect_count (count, desc, data);
4414
4415 pdump_add_entry (&pdump_opaque_data_list,
4416 *(void **)rdata,
4417 count,
4418 1,
4419 0);
4420 break;
4421 }
4422 case XD_C_STRING:
4423 {
4424 const char *str = *(const char **)rdata;
4425 if (str)
4426 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4427 break;
4428 }
4429 case XD_DOC_STRING:
4430 {
4431 const char *str = *(const char **)rdata;
4432 if ((EMACS_INT)str > 0)
4433 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4434 break;
4435 }
4436 case XD_LISP_OBJECT:
4437 {
4438 EMACS_INT count = desc[pos].data1;
4439 int i;
4440 if (XD_IS_INDIRECT (count))
4441 count = pdump_get_indirect_count (count, desc, data);
4442
4443 for(i=0;i<count;i++) {
4444 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4445 Lisp_Object dobj = *pobj;
4446
4447 backtrace[me].offset = (const char *)pobj - (const char *)data;
4448 pdump_register_object (dobj);
4449 }
4450 break;
4451 }
4452 case XD_STRUCT_PTR:
4453 {
4454 EMACS_INT count = desc[pos].data1;
4455 const struct struct_description *sdesc = desc[pos].data2;
4456 const char *dobj = *(const char **)rdata;
4457 if (dobj) {
4458 if (XD_IS_INDIRECT (count))
4459 count = pdump_get_indirect_count (count, desc, data);
4460
4461 pdump_register_struct (dobj, sdesc, count);
4462 }
4463 break;
4464 }
4465 default:
4466 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4467 pdump_backtrace ();
4468 abort ();
4469 };
4470 }
4471 }
4472
4473 static void
4474 pdump_register_object (Lisp_Object obj)
4475 {
4476 if (!obj ||
4477 !POINTER_TYPE_P (XTYPE (obj)) ||
4478 pdump_get_entry (XRECORD_LHEADER (obj)))
4479 return;
4480
4481 if (XRECORD_LHEADER_IMPLEMENTATION (obj)->description)
4482 {
4483 int me = depth++;
4484 if (me>65536)
4485 {
4486 fprintf (stderr, "Backtrace overflow, loop ?\n");
4487 abort ();
4488 }
4489 backtrace[me].obj = obj;
4490 backtrace[me].position = 0;
4491 backtrace[me].offset = 0;
4492
4493 pdump_add_entry (pdump_object_table + XRECORD_LHEADER (obj)->type,
4494 XRECORD_LHEADER (obj),
4495 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size ?
4496 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size :
4497 XRECORD_LHEADER_IMPLEMENTATION (obj)->size_in_bytes_method (XRECORD_LHEADER (obj)),
4498 1,
4499 1);
4500 pdump_register_sub (XRECORD_LHEADER (obj),
4501 XRECORD_LHEADER_IMPLEMENTATION (obj)->description,
4502 me);
4503 --depth;
4504 }
4505 else
4506 {
4507 pdump_alert_undump_object[XRECORD_LHEADER (obj)->type]++;
4508 fprintf (stderr, "Undumpable object type : %s\n", XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
4509 pdump_backtrace ();
4510 }
4511 }
4512
4513 static void
4514 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4515 {
4516 if (data && !pdump_get_entry (data))
4517 {
4518 int me = depth++;
4519 int i;
4520 if (me>65536)
4521 {
4522 fprintf (stderr, "Backtrace overflow, loop ?\n");
4523 abort ();
4524 }
4525 backtrace[me].obj = 0;
4526 backtrace[me].position = 0;
4527 backtrace[me].offset = 0;
4528
4529 pdump_add_entry (pdump_get_entry_list (sdesc),
4530 data,
4531 sdesc->size,
4532 count,
4533 0);
4534 for (i=0; i<count; i++)
4535 {
4536 pdump_register_sub (((char *)data) + sdesc->size*i,
4537 sdesc->description,
4538 me);
4539 }
4540 --depth;
4541 }
4542 }
4543
4544 static void
4545 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4546 {
4547 size_t size = elmt->size;
4548 int count = elmt->count;
4549 if (desc)
4550 {
4551 int pos, i;
4552 void *rdata;
4553 memcpy (pdump_buf, elmt->obj, size*count);
4554
4555 for (i=0; i<count; i++)
4556 {
4557 char *cur = ((char *)pdump_buf) + i*size;
4558 restart:
4559 for (pos = 0; desc[pos].type != XD_END; pos++)
4560 {
4561 rdata = cur + desc[pos].offset;
4562 switch (desc[pos].type)
4563 {
4564 case XD_SPECIFIER_END:
4565 pos = 0;
4566 desc = ((const struct Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4567 goto restart;
4568 case XD_SIZE_T:
4569 case XD_INT:
4570 case XD_LONG:
4571 case XD_BYTECOUNT:
4572 break;
4573 case XD_LO_RESET_NIL:
4574 {
4575 EMACS_INT count = desc[pos].data1;
4576 int i;
4577 if (XD_IS_INDIRECT (count))
4578 count = pdump_get_indirect_count (count, desc, elmt->obj);
4579 for (i=0; i<count; i++)
4580 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4581 break;
4582 }
4583 case XD_INT_RESET:
4584 {
4585 EMACS_INT val = desc[pos].data1;
4586 if (XD_IS_INDIRECT (val))
4587 val = pdump_get_indirect_count (val, desc, elmt->obj);
4588 *(int *)rdata = val;
4589 break;
4590 }
4591 case XD_OPAQUE_DATA_PTR:
4592 case XD_C_STRING:
4593 case XD_STRUCT_PTR:
4594 {
4595 void *ptr = *(void **)rdata;
4596 if (ptr)
4597 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4598 break;
4599 }
4600 case XD_LO_LINK:
4601 {
4602 Lisp_Object obj = *(Lisp_Object *)rdata;
4603 pdump_entry_list_elmt *elmt1;
4604 for(;;)
4605 {
4606 elmt1 = pdump_get_entry (XRECORD_LHEADER(obj));
4607 if (elmt1)
4608 break;
4609 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4610 }
4611 *(EMACS_INT *)rdata = elmt1->save_offset;
4612 break;
4613 }
4614 case XD_LISP_OBJECT:
4615 {
4616 EMACS_INT count = desc[pos].data1;
4617 int i;
4618 if (XD_IS_INDIRECT (count))
4619 count = pdump_get_indirect_count (count, desc, elmt->obj);
4620
4621 for(i=0; i<count; i++)
4622 {
4623 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4624 Lisp_Object dobj = *pobj;
4625 if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
4626 *pobj = pdump_get_entry (XRECORD_LHEADER (dobj))->save_offset;
4627 }
4628 break;
4629 }
4630 case XD_DOC_STRING:
4631 {
4632 EMACS_INT str = *(EMACS_INT *)rdata;
4633 if (str > 0)
4634 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4635 break;
4636 }
4637 default:
4638 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4639 abort ();
4640 };
4641 }
4642 }
4643 }
4644 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4645 if (elmt->is_lrecord && ((size*count) & 3))
4646 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4647 }
4648
4649 static void
4650 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4651 {
4652 int pos;
4653 void *rdata;
4654
4655 restart:
4656 for (pos = 0; desc[pos].type != XD_END; pos++)
4657 {
4658 rdata = ((char *)data) + desc[pos].offset;
4659 switch (desc[pos].type) {
4660 case XD_SPECIFIER_END:
4661 pos = 0;
4662 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description;
4663 goto restart;
4664 case XD_SIZE_T:
4665 case XD_INT:
4666 case XD_LONG:
4667 case XD_BYTECOUNT:
4668 case XD_INT_RESET:
4669 break;
4670 case XD_OPAQUE_DATA_PTR:
4671 case XD_C_STRING:
4672 case XD_STRUCT_PTR:
4673 case XD_LO_LINK:
4674 {
4675 EMACS_INT ptr = *(EMACS_INT *)rdata;
4676 if (ptr)
4677 *(EMACS_INT *)rdata = ptr+delta;
4678 break;
4679 }
4680 case XD_LISP_OBJECT:
4681 case XD_LO_RESET_NIL:
4682 {
4683 EMACS_INT count = desc[pos].data1;
4684 int i;
4685 if (XD_IS_INDIRECT (count))
4686 count = pdump_get_indirect_count (count, desc, data);
4687
4688 for (i=0; i<count; i++)
4689 {
4690 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4691 Lisp_Object dobj = *pobj;
4692 if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
4693 *pobj = dobj + delta;
4694 }
4695 break;
4696 }
4697 case XD_DOC_STRING:
4698 {
4699 EMACS_INT str = *(EMACS_INT *)rdata;
4700 if (str > 0)
4701 *(EMACS_INT *)rdata = str + delta;
4702 break;
4703 }
4704 default:
4705 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4706 abort ();
4707 };
4708 }
4709 }
4710
4711 static void
4712 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4713 {
4714 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4715 elmt->save_offset = cur_offset;
4716 if (size>max_size)
4717 max_size = size;
4718 cur_offset += size;
4719 }
4720
4721 static void
4722 pdump_scan_by_alignement (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4723 {
4724 int align, i;
4725 const struct lrecord_description *idesc;
4726 pdump_entry_list_elmt *elmt;
4727 for (align=8; align>=0; align--)
4728 {
4729 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4730 if (pdump_object_table[i].align == align)
4731 {
4732 elmt = pdump_object_table[i].first;
4733 if (!elmt)
4734 continue;
4735 idesc = lrecord_implementations_table[i]->description;
4736 while (elmt)
4737 {
4738 f (elmt, idesc);
4739 elmt = elmt->next;
4740 }
4741 }
4742
4743 for (i=0; i<pdump_struct_table.count; i++)
4744 if (pdump_struct_table.list[i].list.align == align) {
4745 elmt = pdump_struct_table.list[i].list.first;
4746 idesc = pdump_struct_table.list[i].sdesc->description;
4747 while (elmt)
4748 {
4749 f (elmt, idesc);
4750 elmt = elmt->next;
4751 }
4752 }
4753
4754 elmt = pdump_opaque_data_list.first;
4755 while (elmt)
4756 {
4757 if (align_table[elmt->size & 255] == align)
4758 f (elmt, 0);
4759 elmt = elmt->next;
4760 }
4761 }
4762 }
4763
4764 static void
4765 pdump_dump_staticvec (void)
4766 {
4767 Lisp_Object *reloc = malloc (staticidx*sizeof (Lisp_Object));
4768 int i;
4769 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4770
4771 for(i=0; i<staticidx; i++)
4772 {
4773 Lisp_Object obj = *staticvec[i];
4774 if (obj && POINTER_TYPE_P (XTYPE (obj)))
4775 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4776 else
4777 reloc[i] = obj;
4778 }
4779 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4780 free (reloc);
4781 }
4782
4783 static void
4784 pdump_dump_structvec (void)
4785 {
4786 int i;
4787 for (i=0; i<dumpstructidx; i++)
4788 {
4789 EMACS_INT adr;
4790 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4791 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4792 write (pdump_fd, &adr, sizeof (adr));
4793 }
4794 }
4795
4796 static void
4797 pdump_dump_itable (void)
4798 {
4799 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4800 }
4801
4802 static void
4803 pdump_dump_rtables (void)
4804 {
4805 int i, j;
4806 pdump_entry_list_elmt *elmt;
4807 pdump_reloc_table rt;
4808
4809 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4810 {
4811 elmt = pdump_object_table[i].first;
4812 if(!elmt)
4813 continue;
4814 rt.desc = lrecord_implementations_table[i]->description;
4815 rt.count = pdump_object_table[i].count;
4816 write (pdump_fd, &rt, sizeof (rt));
4817 while (elmt)
4818 {
4819 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset;
4820 write (pdump_fd, &rdata, sizeof (rdata));
4821 elmt = elmt->next;
4822 }
4823 }
4824
4825 rt.desc = 0;
4826 rt.count = 0;
4827 write (pdump_fd, &rt, sizeof (rt));
4828
4829 for (i=0; i<pdump_struct_table.count; i++)
4830 {
4831 elmt = pdump_struct_table.list[i].list.first;
4832 rt.desc = pdump_struct_table.list[i].sdesc->description;
4833 rt.count = pdump_struct_table.list[i].list.count;
4834 write (pdump_fd, &rt, sizeof (rt));
4835 while (elmt)
4836 {
4837 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset;
4838 for (j=0; j<elmt->count; j++) {
4839 write (pdump_fd, &rdata, sizeof (rdata));
4840 rdata += elmt->size;
4841 }
4842 elmt = elmt->next;
4843 }
4844 }
4845 rt.desc = 0;
4846 rt.count = 0;
4847 write (pdump_fd, &rt, sizeof (rt));
4848 }
4849
4850 static void
4851 pdump_dump_wired (void)
4852 {
4853 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4854 int i;
4855
4856 write (pdump_fd, &count, sizeof (count));
4857
4858 for (i=0; i<pdump_wireidx; i++)
4859 {
4860 Lisp_Object obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4861 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4862 write (pdump_fd, &obj, sizeof (obj));
4863 }
4864
4865 for (i=0; i<pdump_wireidx_list; i++)
4866 {
4867 Lisp_Object obj = *(pdump_wirevec_list[i]);
4868 pdump_entry_list_elmt *elmt;
4869 EMACS_INT res;
4870
4871 for(;;)
4872 {
4873 const struct lrecord_description *desc;
4874 int pos;
4875 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4876 if (elmt)
4877 break;
4878 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
4879 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
4880 if (desc[pos].type == XD_END)
4881 abort ();
4882
4883 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4884 }
4885 res = elmt->save_offset;
4886
4887 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
4888 write (pdump_fd, &res, sizeof (res));
4889 }
4890 }
4891
4892 void
4893 pdump (void)
4894 {
4895 int i;
4896 Lisp_Object t_console, t_device, t_frame;
4897 int none;
4898 dump_header hd;
4899
4900 /* These appear in a DEFVAR_LISP, which does a staticpro() */
4901 t_console = Vterminal_console;
4902 t_frame = Vterminal_frame;
4903 t_device = Vterminal_device;
4904
4905 Vterminal_console = Qnil;
4906 Vterminal_frame = Qnil;
4907 Vterminal_device = Qnil;
4908
4909 pdump_hash = malloc (PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
4910 memset (pdump_hash, 0, PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
4911
4912 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4913 {
4914 pdump_object_table[i].first = 0;
4915 pdump_object_table[i].align = 8;
4916 pdump_object_table[i].count = 0;
4917 pdump_alert_undump_object[i] = 0;
4918 }
4919 pdump_struct_table.count = 0;
4920 pdump_struct_table.size = -1;
4921
4922 pdump_opaque_data_list.first = 0;
4923 pdump_opaque_data_list.align = 8;
4924 pdump_opaque_data_list.count = 0;
4925 depth = 0;
4926
4927 for (i=0; i<staticidx; i++)
4928 pdump_register_object (*staticvec[i]);
4929 for (i=0; i<pdump_wireidx; i++)
4930 pdump_register_object (*pdump_wirevec[i]);
4931
4932 none = 1;
4933 for(i=0;i<=last_lrecord_type_index_assigned;i++)
4934 if (pdump_alert_undump_object[i])
4935 {
4936 if (none)
4937 printf ("Undumpable types list :\n");
4938 none = 0;
4939 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
4940 }
4941 if (!none)
4942 return;
4943
4944 for (i=0; i<dumpstructidx; i++)
4945 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
4946
4947 memcpy (hd.signature, "XEmacsDP", 8);
4948 hd.reloc_address = 0;
4949 hd.nb_staticpro = staticidx;
4950 hd.nb_structdmp = dumpstructidx;
4951 hd.last_type = last_lrecord_type_index_assigned;
4952
4953 cur_offset = 256;
4954 max_size = 0;
4955
4956 pdump_scan_by_alignement (pdump_allocate_offset);
4957 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
4958
4959 pdump_buf = malloc (max_size);
4960 pdump_fd = open ("xemacs.dmp", O_WRONLY|O_CREAT|O_TRUNC, 0666);
4961 hd.stab_offset = (cur_offset + 3) & ~3;
4962
4963 write (pdump_fd, &hd, sizeof (hd));
4964 lseek (pdump_fd, 256, SEEK_SET);
4965
4966 pdump_scan_by_alignement (pdump_dump_data);
4967
4968 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
4969
4970 pdump_dump_staticvec ();
4971 pdump_dump_structvec ();
4972 pdump_dump_itable ();
4973 pdump_dump_rtables ();
4974 pdump_dump_wired ();
4975
4976 close (pdump_fd);
4977 free (pdump_buf);
4978
4979 free (pdump_hash);
4980
4981 Vterminal_console = t_console;
4982 Vterminal_frame = t_frame;
4983 Vterminal_device = t_device;
4984 }
4985
4986 int
4987 pdump_load (void)
4988 {
4989 size_t length;
4990 int i;
4991 char *p;
4992 EMACS_INT delta;
4993 EMACS_INT count;
4994
4995 pdump_start = pdump_end = 0;
4996
4997 pdump_fd = open ("xemacs.dmp", O_RDONLY);
4998 if (pdump_fd<0)
4999 return 0;
5000
5001 length = lseek (pdump_fd, 0, SEEK_END);
5002 lseek (pdump_fd, 0, SEEK_SET);
5003
5004 #ifdef HAVE_MMAP
5005 pdump_start = mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5006 if (pdump_start == MAP_FAILED)
5007 pdump_start = 0;
5008 #endif
5009
5010 if (!pdump_start)
5011 {
5012 pdump_start = (void *)((((unsigned long)(malloc(length+255))) + 255) & ~255);
5013 read(pdump_fd, pdump_start, length);
5014 }
5015
5016 close (pdump_fd);
5017
5018 pdump_end = pdump_start + length;
5019
5020 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5021 last_lrecord_type_index_assigned = ((dump_header *)(pdump_start))->last_type;
5022 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5023 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5024
5025 /* Put back the staticvec in place */
5026 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5027 p += staticidx*sizeof (Lisp_Object *);
5028 for (i=0; i<staticidx; i++)
5029 {
5030 Lisp_Object obj = *(Lisp_Object *)p;
5031 p += sizeof (Lisp_Object);
5032 if (obj && POINTER_TYPE_P (XTYPE (obj)))
5033 obj += delta;
5034 *staticvec[i] = obj;
5035 }
5036
5037 /* Put back the dumpstructs */
5038 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5039 {
5040 void **adr = *(void **)p;
5041 p += sizeof (void *);
5042 *adr = (void *)((*(EMACS_INT *)p) + delta);
5043 p += sizeof (EMACS_INT);
5044 }
5045
5046 /* Put back the lrecord_implementations_table */
5047 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5048 p += sizeof (lrecord_implementations_table);
5049
5050 /* Give back their numbers to the lrecord implementations */
5051 for (i=0; i<sizeof(lrecord_implementations_table)/sizeof(lrecord_implementations_table[0]); i++)
5052 if (lrecord_implementations_table[i])
5053 {
5054 *(lrecord_implementations_table[i]->lrecord_type_index) = i;
5055 last_lrecord_type_index_assigned = i;
5056 }
5057
5058 /* Do the relocations */
5059 pdump_rt_list = p;
5060 count = 2;
5061 for(;;)
5062 {
5063 pdump_reloc_table *rt = (pdump_reloc_table *)p;
5064 p += sizeof (pdump_reloc_table);
5065 if (rt->desc) {
5066 for (i=0; i<rt->count; i++)
5067 {
5068 EMACS_INT adr = delta + *(EMACS_INT *)p;
5069 *(EMACS_INT *)p = adr;
5070 pdump_reloc_one ((void *)adr, delta, rt->desc);
5071 p += sizeof (EMACS_INT);
5072 }
5073 } else
5074 if(!(--count))
5075 break;
5076 }
5077
5078 /* Put the pdump_wire variables in place */
5079 count = *(EMACS_INT *)p;
5080 p += sizeof(EMACS_INT);
5081
5082 for (i=0; i<count; i++)
5083 {
5084 Lisp_Object *var, obj;
5085 var = *(Lisp_Object **)p;
5086 p += sizeof (Lisp_Object *);
5087
5088 obj = *(Lisp_Object *)p;
5089 p += sizeof (Lisp_Object);
5090
5091 if (obj && POINTER_TYPE_P (XTYPE (obj)))
5092 obj += delta;
5093 *var = obj;
5094 }
5095
5096 /* Final cleanups */
5097 /* reorganize hash tables */
5098 p = pdump_rt_list;
5099 for(;;)
5100 {
5101 pdump_reloc_table *rt = (pdump_reloc_table *)p;
5102 p += sizeof (pdump_reloc_table);
5103 if (!rt->desc)
5104 break;
5105 if (rt->desc == hash_table_description)
5106 {
5107 for (i=0; i<rt->count; i++)
5108 {
5109 struct Lisp_Hash_Table *ht = XHASH_TABLE (*(EMACS_INT *)p);
5110 reorganize_hash_table (ht);
5111 p += sizeof (EMACS_INT);
5112 }
5113 break;
5114 } else
5115 p += sizeof (EMACS_INT)*rt->count;
5116 }
5117 return 1;
5118 }
5119
5120 #endif