Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 404:2f8bb876ab1d r21-2-32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-32
author cvs
date Mon, 13 Aug 2007 11:16:07 +0200
parents a86b2b5e0111
children b8cc9ab3f761
comparison
equal deleted inserted replaced
403:9f011ab08d48 404:2f8bb876ab1d
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. Portable dumper. 39 og: Killed the purespace. Portable dumper (moved to dumper.c)
40 */ 40 */
41 41
42 #include <config.h> 42 #include <config.h>
43 #include "lisp.h" 43 #include "lisp.h"
44 44
45 #include "alloc.h"
45 #include "backtrace.h" 46 #include "backtrace.h"
46 #include "buffer.h" 47 #include "buffer.h"
47 #include "bytecode.h" 48 #include "bytecode.h"
48 #include "chartab.h" 49 #include "chartab.h"
49 #include "device.h" 50 #include "device.h"
54 #include "glyphs.h" 55 #include "glyphs.h"
55 #include "opaque.h" 56 #include "opaque.h"
56 #include "redisplay.h" 57 #include "redisplay.h"
57 #include "specifier.h" 58 #include "specifier.h"
58 #include "sysfile.h" 59 #include "sysfile.h"
60 #include "sysdep.h"
59 #include "window.h" 61 #include "window.h"
60 #include "console-stream.h" 62 #include "console-stream.h"
61 63
62 #ifdef DOUG_LEA_MALLOC 64 #ifdef DOUG_LEA_MALLOC
63 #include <malloc.h> 65 #include <malloc.h>
64 #endif 66 #endif
65 67
66 #ifdef HAVE_MMAP
67 #include <unistd.h>
68 #include <sys/mman.h>
69 #endif
70
71 #ifdef PDUMP 68 #ifdef PDUMP
72 typedef struct 69 #include "dumper.h"
73 {
74 const struct lrecord_description *desc;
75 int count;
76 } pdump_reloc_table;
77
78 static char *pdump_rt_list = 0;
79 #endif 70 #endif
80 71
81 EXFUN (Fgarbage_collect, 0); 72 EXFUN (Fgarbage_collect, 0);
82 73
83 #if 0 /* this is _way_ too slow to be part of the standard debug options */ 74 #if 0 /* this is _way_ too slow to be part of the standard debug options */
391 (! implementation->basic_p) 382 (! implementation->basic_p)
392 && 383 &&
393 (! (implementation->hash == NULL && implementation->equal != NULL))); 384 (! (implementation->hash == NULL && implementation->equal != NULL)));
394 385
395 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); 386 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
396 set_lheader_implementation (&(lcheader->lheader), implementation); 387 set_lheader_implementation (&lcheader->lheader, implementation);
397 lcheader->next = all_lcrecords; 388 lcheader->next = all_lcrecords;
398 #if 1 /* mly prefers to see small ID numbers */ 389 #if 1 /* mly prefers to see small ID numbers */
399 lcheader->uid = lrecord_uid_counter++; 390 lcheader->uid = lrecord_uid_counter++;
400 #else /* jwz prefers to see real addrs */ 391 #else /* jwz prefers to see real addrs */
401 lcheader->uid = (int) &lcheader; 392 lcheader->uid = (int) &lcheader;
655 try to set aside another reserve in case we run out once more. 646 try to set aside another reserve in case we run out once more.
656 647
657 This is called when a relocatable block is freed in ralloc.c. */ 648 This is called when a relocatable block is freed in ralloc.c. */
658 void refill_memory_reserve (void); 649 void refill_memory_reserve (void);
659 void 650 void
660 refill_memory_reserve () 651 refill_memory_reserve (void)
661 { 652 {
662 if (breathing_space == 0) 653 if (breathing_space == 0)
663 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); 654 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
664 } 655 }
665 #endif 656 #endif
794 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF 785 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
795 #else 786 #else
796 You have some weird system and need to supply a reasonable value here. 787 You have some weird system and need to supply a reasonable value here.
797 #endif 788 #endif
798 789
790 /* The construct (* (void **) (ptr)) would cause aliasing problems
791 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
792 But `char *' can legally alias any pointer. Hence this union trick. */
793 typedef union { char c; void *p; } *aliasing_voidpp;
794 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
795 (((aliasing_voidpp) (ptr))->p)
799 #define FREE_STRUCT_P(ptr) \ 796 #define FREE_STRUCT_P(ptr) \
800 (* (void **) ptr == (void *) INVALID_POINTER_VALUE) 797 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
801 #define MARK_STRUCT_AS_FREE(ptr) \ 798 #define MARK_STRUCT_AS_FREE(ptr) \
802 (* (void **) ptr = (void *) INVALID_POINTER_VALUE) 799 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
803 #define MARK_STRUCT_AS_NOT_FREE(ptr) \ 800 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
804 (* (void **) ptr = 0) 801 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
805 802
806 #ifdef ERROR_CHECK_GC 803 #ifdef ERROR_CHECK_GC
807 804
808 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \ 805 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
809 do { if (type##_free_list_tail) \ 806 do { if (type##_free_list_tail) \
921 /* This cannot GC. */ 918 /* This cannot GC. */
922 Lisp_Object val; 919 Lisp_Object val;
923 Lisp_Cons *c; 920 Lisp_Cons *c;
924 921
925 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); 922 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
926 set_lheader_implementation (&(c->lheader), &lrecord_cons); 923 set_lheader_implementation (&c->lheader, &lrecord_cons);
927 XSETCONS (val, c); 924 XSETCONS (val, c);
928 c->car = car; 925 c->car = car;
929 c->cdr = cdr; 926 c->cdr = cdr;
930 return val; 927 return val;
931 } 928 }
938 { 935 {
939 Lisp_Object val; 936 Lisp_Object val;
940 Lisp_Cons *c; 937 Lisp_Cons *c;
941 938
942 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); 939 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
943 set_lheader_implementation (&(c->lheader), &lrecord_cons); 940 set_lheader_implementation (&c->lheader, &lrecord_cons);
944 XSETCONS (val, c); 941 XSETCONS (val, c);
945 XCAR (val) = car; 942 XCAR (val) = car;
946 XCDR (val) = cdr; 943 XCDR (val) = cdr;
947 return val; 944 return val;
948 } 945 }
1055 1052
1056 /* Avoid dump-time `uninitialized memory read' purify warnings. */ 1053 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1057 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) 1054 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1058 xzero (*f); 1055 xzero (*f);
1059 1056
1060 set_lheader_implementation (&(f->lheader), &lrecord_float); 1057 set_lheader_implementation (&f->lheader, &lrecord_float);
1061 float_data (f) = float_value; 1058 float_data (f) = float_value;
1062 XSETFLOAT (val, f); 1059 XSETFLOAT (val, f);
1063 return val; 1060 return val;
1064 } 1061 }
1065 1062
1295 make_bit_vector_internal (size_t sizei) 1292 make_bit_vector_internal (size_t sizei)
1296 { 1293 {
1297 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei); 1294 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1298 size_t sizem = offsetof (Lisp_Bit_Vector, bits[num_longs]); 1295 size_t sizem = offsetof (Lisp_Bit_Vector, bits[num_longs]);
1299 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem); 1296 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1300 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector); 1297 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1301 1298
1302 INCREMENT_CONS_COUNTER (sizem, "bit-vector"); 1299 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1303 1300
1304 bit_vector_length (p) = sizei; 1301 bit_vector_length (p) = sizei;
1305 bit_vector_next (p) = all_bit_vectors; 1302 bit_vector_next (p) = all_bit_vectors;
1399 { 1396 {
1400 Lisp_Compiled_Function *f; 1397 Lisp_Compiled_Function *f;
1401 Lisp_Object fun; 1398 Lisp_Object fun;
1402 1399
1403 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); 1400 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1404 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function); 1401 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1405 1402
1406 f->stack_depth = 0; 1403 f->stack_depth = 0;
1407 f->specpdl_depth = 0; 1404 f->specpdl_depth = 0;
1408 f->flags.documentationp = 0; 1405 f->flags.documentationp = 0;
1409 f->flags.interactivep = 0; 1406 f->flags.interactivep = 0;
1483 if (!NILP (constants)) 1480 if (!NILP (constants))
1484 CHECK_VECTOR (constants); 1481 CHECK_VECTOR (constants);
1485 f->constants = constants; 1482 f->constants = constants;
1486 1483
1487 CHECK_NATNUM (stack_depth); 1484 CHECK_NATNUM (stack_depth);
1488 f->stack_depth = XINT (stack_depth); 1485 f->stack_depth = (unsigned short) XINT (stack_depth);
1489 1486
1490 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1487 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1491 if (!NILP (Vcurrent_compiled_function_annotation)) 1488 if (!NILP (Vcurrent_compiled_function_annotation))
1492 f->annotated = Fcopy (Vcurrent_compiled_function_annotation); 1489 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1493 else if (!NILP (Vload_file_name_internal_the_purecopy)) 1490 else if (!NILP (Vload_file_name_internal_the_purecopy))
1546 Lisp_Symbol *p; 1543 Lisp_Symbol *p;
1547 1544
1548 CHECK_STRING (name); 1545 CHECK_STRING (name);
1549 1546
1550 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p); 1547 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1551 set_lheader_implementation (&(p->lheader), &lrecord_symbol); 1548 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1552 p->name = XSTRING (name); 1549 p->name = XSTRING (name);
1553 p->plist = Qnil; 1550 p->plist = Qnil;
1554 p->value = Qunbound; 1551 p->value = Qunbound;
1555 p->function = Qunbound; 1552 p->function = Qunbound;
1556 symbol_next (p) = 0; 1553 symbol_next (p) = 0;
1570 allocate_extent (void) 1567 allocate_extent (void)
1571 { 1568 {
1572 struct extent *e; 1569 struct extent *e;
1573 1570
1574 ALLOCATE_FIXED_TYPE (extent, struct extent, e); 1571 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1575 set_lheader_implementation (&(e->lheader), &lrecord_extent); 1572 set_lheader_implementation (&e->lheader, &lrecord_extent);
1576 extent_object (e) = Qnil; 1573 extent_object (e) = Qnil;
1577 set_extent_start (e, -1); 1574 set_extent_start (e, -1);
1578 set_extent_end (e, -1); 1575 set_extent_end (e, -1);
1579 e->plist = Qnil; 1576 e->plist = Qnil;
1580 1577
1600 { 1597 {
1601 Lisp_Object val; 1598 Lisp_Object val;
1602 Lisp_Event *e; 1599 Lisp_Event *e;
1603 1600
1604 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e); 1601 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1605 set_lheader_implementation (&(e->lheader), &lrecord_event); 1602 set_lheader_implementation (&e->lheader, &lrecord_event);
1606 1603
1607 XSETEVENT (val, e); 1604 XSETEVENT (val, e);
1608 return val; 1605 return val;
1609 } 1606 }
1610 1607
1623 { 1620 {
1624 Lisp_Object val; 1621 Lisp_Object val;
1625 Lisp_Marker *p; 1622 Lisp_Marker *p;
1626 1623
1627 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); 1624 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1628 set_lheader_implementation (&(p->lheader), &lrecord_marker); 1625 set_lheader_implementation (&p->lheader, &lrecord_marker);
1629 p->buffer = 0; 1626 p->buffer = 0;
1630 p->memind = 0; 1627 p->memind = 0;
1631 marker_next (p) = 0; 1628 marker_next (p) = 0;
1632 marker_prev (p) = 0; 1629 marker_prev (p) = 0;
1633 p->insertion_type = 0; 1630 p->insertion_type = 0;
1640 { 1637 {
1641 Lisp_Object val; 1638 Lisp_Object val;
1642 Lisp_Marker *p; 1639 Lisp_Marker *p;
1643 1640
1644 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); 1641 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1645 set_lheader_implementation (&(p->lheader), &lrecord_marker); 1642 set_lheader_implementation (&p->lheader, &lrecord_marker);
1646 p->buffer = 0; 1643 p->buffer = 0;
1647 p->memind = 0; 1644 p->memind = 0;
1648 marker_next (p) = 0; 1645 marker_next (p) = 0;
1649 marker_prev (p) = 0; 1646 marker_prev (p) = 0;
1650 p->insertion_type = 0; 1647 p->insertion_type = 0;
1860 1857
1861 assert (length >= 0 && fullsize > 0); 1858 assert (length >= 0 && fullsize > 0);
1862 1859
1863 /* Allocate the string header */ 1860 /* Allocate the string header */
1864 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); 1861 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1865 set_lheader_implementation (&(s->lheader), &lrecord_string); 1862 set_lheader_implementation (&s->lheader, &lrecord_string);
1866 1863
1867 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize) 1864 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1868 ? xnew_array (Bufbyte, length + 1) 1865 ? xnew_array (Bufbyte, length + 1)
1869 : allocate_string_chars_struct (s, fullsize)->chars); 1866 : allocate_string_chars_struct (s, fullsize)->chars);
1870 1867
2164 bytecount_to_charcount (contents, length); /* Just for the assertions */ 2161 bytecount_to_charcount (contents, length); /* Just for the assertions */
2165 #endif 2162 #endif
2166 2163
2167 /* Allocate the string header */ 2164 /* Allocate the string header */
2168 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); 2165 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2169 set_lheader_implementation (&(s->lheader), &lrecord_string); 2166 set_lheader_implementation (&s->lheader, &lrecord_string);
2170 SET_C_READONLY_RECORD_HEADER (&s->lheader); 2167 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2171 s->plist = Qnil; 2168 s->plist = Qnil;
2172 set_string_data (s, (Bufbyte *)contents); 2169 set_string_data (s, (Bufbyte *)contents);
2173 set_string_length (s, length); 2170 set_string_length (s, length);
2174 2171
2346 2343
2347 /************************************************************************/ 2344 /************************************************************************/
2348 /* Garbage Collection */ 2345 /* Garbage Collection */
2349 /************************************************************************/ 2346 /************************************************************************/
2350 2347
2351 /* This will be used more extensively In The Future */
2352 static int last_lrecord_type_index_assigned;
2353
2354 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. 2348 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2355 Additional ones may be defined by a module (none yet). We leave some 2349 Additional ones may be defined by a module (none yet). We leave some
2356 room in `lrecord_implementations_table' for such new lisp object types. */ 2350 room in `lrecord_implementations_table' for such new lisp object types. */
2357 #define MODULE_DEFINABLE_TYPE_COUNT 32 2351 #define MODULE_DEFINABLE_TYPE_COUNT 32
2358 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT]; 2352 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2370 #ifdef HAVE_SHLIB 2364 #ifdef HAVE_SHLIB
2371 #define NSTATICS 4000 2365 #define NSTATICS 4000
2372 #else 2366 #else
2373 #define NSTATICS 2000 2367 #define NSTATICS 2000
2374 #endif 2368 #endif
2375 /* Not "static" because of linker lossage on some systems */ 2369
2376 Lisp_Object *staticvec[NSTATICS] 2370 /* Not "static" because used by dumper.c */
2377 /* Force it into data space! */ 2371 Lisp_Object *staticvec[NSTATICS];
2378 = {0}; 2372 int staticidx;
2379 static int staticidx;
2380 2373
2381 /* Put an entry in staticvec, pointing at the variable whose address is given 2374 /* Put an entry in staticvec, pointing at the variable whose address is given
2382 */ 2375 */
2383 void 2376 void
2384 staticpro (Lisp_Object *varaddress) 2377 staticpro (Lisp_Object *varaddress)
2385 { 2378 {
2386 if (staticidx >= countof (staticvec)) 2379 /* #### This is now a dubious assert() since this routine may be called */
2387 /* #### This is now a dubious abort() since this routine may be called */ 2380 /* by Lisp attempting to load a DLL. */
2388 /* by Lisp attempting to load a DLL. */ 2381 assert (staticidx < countof (staticvec));
2389 abort ();
2390 staticvec[staticidx++] = varaddress; 2382 staticvec[staticidx++] = varaddress;
2391 } 2383 }
2392 2384
2393 /* Not "static" because of linker lossage on some systems */ 2385
2394 Lisp_Object *staticvec_nodump[200] 2386 Lisp_Object *staticvec_nodump[200];
2395 /* Force it into data space! */ 2387 int staticidx_nodump;
2396 = {0};
2397 static int staticidx_nodump;
2398 2388
2399 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given 2389 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2400 */ 2390 */
2401 void 2391 void
2402 staticpro_nodump (Lisp_Object *varaddress) 2392 staticpro_nodump (Lisp_Object *varaddress)
2403 { 2393 {
2404 if (staticidx_nodump >= countof (staticvec_nodump)) 2394 /* #### This is now a dubious assert() since this routine may be called */
2405 /* #### This is now a dubious abort() since this routine may be called */ 2395 /* by Lisp attempting to load a DLL. */
2406 /* by Lisp attempting to load a DLL. */ 2396 assert (staticidx_nodump < countof (staticvec_nodump));
2407 abort ();
2408 staticvec_nodump[staticidx_nodump++] = varaddress; 2397 staticvec_nodump[staticidx_nodump++] = varaddress;
2409 } 2398 }
2410 2399
2411 /* Not "static" because of linker lossage on some systems */ 2400
2412 struct 2401 struct pdump_dumpstructinfo dumpstructvec[200];
2413 { 2402 int dumpstructidx;
2414 void *data;
2415 const struct struct_description *desc;
2416 } dumpstructvec[200];
2417
2418 static int dumpstructidx;
2419 2403
2420 /* Put an entry in dumpstructvec, pointing at the variable whose address is given 2404 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2421 */ 2405 */
2422 void 2406 void
2423 dumpstruct (void *varaddress, const struct struct_description *desc) 2407 dumpstruct (void *varaddress, const struct struct_description *desc)
2424 { 2408 {
2425 if (dumpstructidx >= countof (dumpstructvec)) 2409 assert (dumpstructidx < countof (dumpstructvec));
2426 abort ();
2427 dumpstructvec[dumpstructidx].data = varaddress; 2410 dumpstructvec[dumpstructidx].data = varaddress;
2428 dumpstructvec[dumpstructidx].desc = desc; 2411 dumpstructvec[dumpstructidx].desc = desc;
2429 dumpstructidx++; 2412 dumpstructidx++;
2430 } 2413 }
2431 2414
2432 /* Not "static" because of linker lossage on some systems */ 2415 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2433 struct dumpopaque_info 2416 int dumpopaqueidx;
2434 {
2435 void *data;
2436 size_t size;
2437 } dumpopaquevec[200];
2438
2439 static int dumpopaqueidx;
2440 2417
2441 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given 2418 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2442 */ 2419 */
2443 void 2420 void
2444 dumpopaque (void *varaddress, size_t size) 2421 dumpopaque (void *varaddress, size_t size)
2445 { 2422 {
2446 if (dumpopaqueidx >= countof (dumpopaquevec)) 2423 assert (dumpopaqueidx < countof (dumpopaquevec));
2447 abort (); 2424
2448 dumpopaquevec[dumpopaqueidx].data = varaddress; 2425 dumpopaquevec[dumpopaqueidx].data = varaddress;
2449 dumpopaquevec[dumpopaqueidx].size = size; 2426 dumpopaquevec[dumpopaqueidx].size = size;
2450 dumpopaqueidx++; 2427 dumpopaqueidx++;
2451 } 2428 }
2452 2429
2453 Lisp_Object *pdump_wirevec[50]; 2430 Lisp_Object *pdump_wirevec[50];
2454 static int pdump_wireidx; 2431 int pdump_wireidx;
2455 2432
2456 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given 2433 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2457 */ 2434 */
2458 void 2435 void
2459 pdump_wire (Lisp_Object *varaddress) 2436 pdump_wire (Lisp_Object *varaddress)
2460 { 2437 {
2461 if (pdump_wireidx >= countof (pdump_wirevec)) 2438 assert (pdump_wireidx < countof (pdump_wirevec));
2462 abort ();
2463 pdump_wirevec[pdump_wireidx++] = varaddress; 2439 pdump_wirevec[pdump_wireidx++] = varaddress;
2464 } 2440 }
2465 2441
2466 2442
2467 Lisp_Object *pdump_wirevec_list[50]; 2443 Lisp_Object *pdump_wirevec_list[50];
2468 static int pdump_wireidx_list; 2444 int pdump_wireidx_list;
2469 2445
2470 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given 2446 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2471 */ 2447 */
2472 void 2448 void
2473 pdump_wire_list (Lisp_Object *varaddress) 2449 pdump_wire_list (Lisp_Object *varaddress)
2474 { 2450 {
2475 if (pdump_wireidx_list >= countof (pdump_wirevec_list)) 2451 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2476 abort ();
2477 pdump_wirevec_list[pdump_wireidx_list++] = varaddress; 2452 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2478 } 2453 }
2479 2454
2480 #ifdef ERROR_CHECK_GC 2455 #ifdef ERROR_CHECK_GC
2481 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ 2456 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2482 struct lrecord_header * GCLI_lh = (lheader); \ 2457 struct lrecord_header * GCLI_lh = (lheader); \
2483 assert (GCLI_lh != 0); \ 2458 assert (GCLI_lh != 0); \
2484 assert (GCLI_lh->type <= last_lrecord_type_index_assigned); \ 2459 assert (GCLI_lh->type < lrecord_type_count); \
2485 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \ 2460 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2486 (MARKED_RECORD_HEADER_P (GCLI_lh) && \ 2461 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2487 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \ 2462 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2488 } while (0) 2463 } while (0)
2489 #else 2464 #else
3073 assert (!(FREE_STRUCT_P (string))); 3048 assert (!(FREE_STRUCT_P (string)));
3074 3049
3075 size = string_length (string); 3050 size = string_length (string);
3076 fullsize = STRING_FULLSIZE (size); 3051 fullsize = STRING_FULLSIZE (size);
3077 3052
3078 if (BIG_STRING_FULLSIZE_P (fullsize)) 3053 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3079 abort ();
3080 3054
3081 /* Just skip it if it isn't marked. */ 3055 /* Just skip it if it isn't marked. */
3082 if (! MARKED_RECORD_HEADER_P (&(string->lheader))) 3056 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3083 { 3057 {
3084 from_pos += fullsize; 3058 from_pos += fullsize;
3136 static void 3110 static void
3137 debug_string_purity_print (Lisp_String *p) 3111 debug_string_purity_print (Lisp_String *p)
3138 { 3112 {
3139 Charcount i; 3113 Charcount i;
3140 Charcount s = string_char_length (p); 3114 Charcount s = string_char_length (p);
3141 putc ('\"', stderr); 3115 stderr_out ("\"");
3142 for (i = 0; i < s; i++) 3116 for (i = 0; i < s; i++)
3143 { 3117 {
3144 Emchar ch = string_char (p, i); 3118 Emchar ch = string_char (p, i);
3145 if (ch < 32 || ch >= 126) 3119 if (ch < 32 || ch >= 126)
3146 stderr_out ("\\%03o", ch); 3120 stderr_out ("\\%03o", ch);
3264 sweep_markers (); 3238 sweep_markers ();
3265 3239
3266 sweep_events (); 3240 sweep_events ();
3267 3241
3268 #ifdef PDUMP 3242 #ifdef PDUMP
3269 /* Unmark all dumped objects */ 3243 pdump_objects_unmark ();
3270 {
3271 int i;
3272 char *p = pdump_rt_list;
3273 if (p)
3274 for (;;)
3275 {
3276 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3277 p += sizeof (pdump_reloc_table);
3278 if (rt->desc)
3279 {
3280 for (i=0; i<rt->count; i++)
3281 {
3282 struct lrecord_header *lh = * (struct lrecord_header **) p;
3283 if (! C_READONLY_RECORD_HEADER_P (lh))
3284 UNMARK_RECORD_HEADER (lh);
3285 p += sizeof (EMACS_INT);
3286 }
3287 } else
3288 break;
3289 }
3290 }
3291 #endif 3244 #endif
3292 } 3245 }
3293 3246
3294 /* Clearing for disksave. */ 3247 /* Clearing for disksave. */
3295 3248
3650 int i; 3603 int i;
3651 int gc_count_vector_total_size = 0; 3604 int gc_count_vector_total_size = 0;
3652 3605
3653 garbage_collect_1 (); 3606 garbage_collect_1 ();
3654 3607
3655 for (i = 0; i <= last_lrecord_type_index_assigned; i++) 3608 for (i = 0; i < lrecord_type_count; i++)
3656 { 3609 {
3657 if (lcrecord_stats[i].bytes_in_use != 0 3610 if (lcrecord_stats[i].bytes_in_use != 0
3658 || lcrecord_stats[i].bytes_freed != 0 3611 || lcrecord_stats[i].bytes_freed != 0
3659 || lcrecord_stats[i].instances_on_free_list != 0) 3612 || lcrecord_stats[i].instances_on_free_list != 0)
3660 { 3613 {
3991 void 3944 void
3992 init_alloc_once_early (void) 3945 init_alloc_once_early (void)
3993 { 3946 {
3994 reinit_alloc_once_early (); 3947 reinit_alloc_once_early ();
3995 3948
3996 last_lrecord_type_index_assigned = lrecord_type_count - 1;
3997
3998 { 3949 {
3999 int i; 3950 int i;
4000 for (i = 0; i < countof (lrecord_implementations_table); i++) 3951 for (i = 0; i < countof (lrecord_implementations_table); i++)
4001 lrecord_implementations_table[i] = 0; 3952 lrecord_implementations_table[i] = 0;
4002 } 3953 }
4133 void 4084 void
4134 complex_vars_of_alloc (void) 4085 complex_vars_of_alloc (void)
4135 { 4086 {
4136 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); 4087 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4137 } 4088 }
4138
4139
4140 #ifdef PDUMP
4141
4142 /* The structure of the file
4143 *
4144 * 0 - header
4145 * 256 - dumped objects
4146 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4147 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4148 * - nb_structdmp*pair(void *, adr) for pointers to structures
4149 * - lrecord_implementations_table[]
4150 * - relocation table
4151 * - wired variable address/value couples with the count preceding the list
4152 */
4153 typedef struct
4154 {
4155 char signature[8];
4156 EMACS_UINT stab_offset;
4157 EMACS_UINT reloc_address;
4158 int nb_staticpro;
4159 int nb_structdmp;
4160 int nb_opaquedmp;
4161 int last_type;
4162 } dump_header;
4163
4164 char *pdump_start, *pdump_end;
4165
4166 static const unsigned char align_table[256] =
4167 {
4168 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4169 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4170 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4171 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4172 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4173 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4174 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4175 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4176 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4177 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4178 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4179 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4180 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4181 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4182 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4183 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
4184 };
4185
4186 typedef struct pdump_entry_list_elmt
4187 {
4188 struct pdump_entry_list_elmt *next;
4189 const void *obj;
4190 size_t size;
4191 int count;
4192 int is_lrecord;
4193 EMACS_INT save_offset;
4194 } pdump_entry_list_elmt;
4195
4196 typedef struct
4197 {
4198 pdump_entry_list_elmt *first;
4199 int align;
4200 int count;
4201 } pdump_entry_list;
4202
4203 typedef struct pdump_struct_list_elmt
4204 {
4205 pdump_entry_list list;
4206 const struct struct_description *sdesc;
4207 } pdump_struct_list_elmt;
4208
4209 typedef struct
4210 {
4211 pdump_struct_list_elmt *list;
4212 int count;
4213 int size;
4214 } pdump_struct_list;
4215
4216 static pdump_entry_list pdump_object_table[256];
4217 static pdump_entry_list pdump_opaque_data_list;
4218 static pdump_struct_list pdump_struct_table;
4219 static pdump_entry_list_elmt *pdump_qnil;
4220
4221 static int pdump_alert_undump_object[256];
4222
4223 static unsigned long cur_offset;
4224 static size_t max_size;
4225 static int pdump_fd;
4226 static void *pdump_buf;
4227
4228 #define PDUMP_HASHSIZE 200001
4229
4230 static pdump_entry_list_elmt **pdump_hash;
4231
4232 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4233 static int
4234 pdump_make_hash (const void *obj)
4235 {
4236 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4237 }
4238
4239 static pdump_entry_list_elmt *
4240 pdump_get_entry (const void *obj)
4241 {
4242 int pos = pdump_make_hash (obj);
4243 pdump_entry_list_elmt *e;
4244
4245 assert (obj != 0);
4246
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 = xnew (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 = (pdump_struct_list_elmt *)
4311 xrealloc (pdump_struct_table.list,
4312 pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
4313 }
4314 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4315 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4316 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4317 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4318
4319 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4320 }
4321
4322 static struct
4323 {
4324 struct lrecord_header *obj;
4325 int position;
4326 int offset;
4327 } backtrace[65536];
4328
4329 static int depth;
4330
4331 static void pdump_backtrace (void)
4332 {
4333 int i;
4334 fprintf (stderr, "pdump backtrace :\n");
4335 for (i=0;i<depth;i++)
4336 {
4337 if (!backtrace[i].obj)
4338 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4339 else
4340 {
4341 fprintf (stderr, " - %s (%d, %d)\n",
4342 LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4343 backtrace[i].position,
4344 backtrace[i].offset);
4345 }
4346 }
4347 }
4348
4349 static void pdump_register_object (Lisp_Object obj);
4350 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4351
4352 static EMACS_INT
4353 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4354 {
4355 EMACS_INT count;
4356 const void *irdata;
4357
4358 int line = XD_INDIRECT_VAL (code);
4359 int delta = XD_INDIRECT_DELTA (code);
4360
4361 irdata = ((char *)idata) + idesc[line].offset;
4362 switch (idesc[line].type)
4363 {
4364 case XD_SIZE_T:
4365 count = *(size_t *)irdata;
4366 break;
4367 case XD_INT:
4368 count = *(int *)irdata;
4369 break;
4370 case XD_LONG:
4371 count = *(long *)irdata;
4372 break;
4373 case XD_BYTECOUNT:
4374 count = *(Bytecount *)irdata;
4375 break;
4376 default:
4377 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4378 pdump_backtrace ();
4379 abort ();
4380 }
4381 count += delta;
4382 return count;
4383 }
4384
4385 static void
4386 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4387 {
4388 int pos;
4389
4390 restart:
4391 for (pos = 0; desc[pos].type != XD_END; pos++)
4392 {
4393 const void *rdata = (const char *)data + desc[pos].offset;
4394
4395 backtrace[me].position = pos;
4396 backtrace[me].offset = desc[pos].offset;
4397
4398 switch (desc[pos].type)
4399 {
4400 case XD_SPECIFIER_END:
4401 pos = 0;
4402 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4403 goto restart;
4404 case XD_SIZE_T:
4405 case XD_INT:
4406 case XD_LONG:
4407 case XD_BYTECOUNT:
4408 case XD_LO_RESET_NIL:
4409 case XD_INT_RESET:
4410 case XD_LO_LINK:
4411 break;
4412 case XD_OPAQUE_DATA_PTR:
4413 {
4414 EMACS_INT count = desc[pos].data1;
4415 if (XD_IS_INDIRECT (count))
4416 count = pdump_get_indirect_count (count, desc, data);
4417
4418 pdump_add_entry (&pdump_opaque_data_list,
4419 *(void **)rdata,
4420 count,
4421 1,
4422 0);
4423 break;
4424 }
4425 case XD_C_STRING:
4426 {
4427 const char *str = *(const char **)rdata;
4428 if (str)
4429 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4430 break;
4431 }
4432 case XD_DOC_STRING:
4433 {
4434 const char *str = *(const char **)rdata;
4435 if ((EMACS_INT)str > 0)
4436 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4437 break;
4438 }
4439 case XD_LISP_OBJECT:
4440 {
4441 const Lisp_Object *pobj = (const Lisp_Object *)rdata;
4442
4443 assert (desc[pos].data1 == 0);
4444
4445 backtrace[me].offset = (const char *)pobj - (const char *)data;
4446 pdump_register_object (*pobj);
4447 break;
4448 }
4449 case XD_LISP_OBJECT_ARRAY:
4450 {
4451 int i;
4452 EMACS_INT count = desc[pos].data1;
4453 if (XD_IS_INDIRECT (count))
4454 count = pdump_get_indirect_count (count, desc, data);
4455
4456 for (i = 0; i < count; i++)
4457 {
4458 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4459 Lisp_Object dobj = *pobj;
4460
4461 backtrace[me].offset = (const char *)pobj - (const char *)data;
4462 pdump_register_object (dobj);
4463 }
4464 break;
4465 }
4466 case XD_STRUCT_PTR:
4467 {
4468 EMACS_INT count = desc[pos].data1;
4469 const struct struct_description *sdesc = desc[pos].data2;
4470 const char *dobj = *(const char **)rdata;
4471 if (dobj)
4472 {
4473 if (XD_IS_INDIRECT (count))
4474 count = pdump_get_indirect_count (count, desc, data);
4475
4476 pdump_register_struct (dobj, sdesc, count);
4477 }
4478 break;
4479 }
4480 default:
4481 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4482 pdump_backtrace ();
4483 abort ();
4484 };
4485 }
4486 }
4487
4488 static void
4489 pdump_register_object (Lisp_Object obj)
4490 {
4491 struct lrecord_header *objh;
4492
4493 if (!POINTER_TYPE_P (XTYPE (obj)))
4494 return;
4495
4496 objh = XRECORD_LHEADER (obj);
4497 if (!objh)
4498 return;
4499
4500 if (pdump_get_entry (objh))
4501 return;
4502
4503 if (LHEADER_IMPLEMENTATION (objh)->description)
4504 {
4505 int me = depth++;
4506 if (me>65536)
4507 {
4508 fprintf (stderr, "Backtrace overflow, loop ?\n");
4509 abort ();
4510 }
4511 backtrace[me].obj = objh;
4512 backtrace[me].position = 0;
4513 backtrace[me].offset = 0;
4514
4515 pdump_add_entry (pdump_object_table + objh->type,
4516 objh,
4517 LHEADER_IMPLEMENTATION (objh)->static_size ?
4518 LHEADER_IMPLEMENTATION (objh)->static_size :
4519 LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
4520 1,
4521 1);
4522 pdump_register_sub (objh,
4523 LHEADER_IMPLEMENTATION (objh)->description,
4524 me);
4525 --depth;
4526 }
4527 else
4528 {
4529 pdump_alert_undump_object[objh->type]++;
4530 fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
4531 pdump_backtrace ();
4532 }
4533 }
4534
4535 static void
4536 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4537 {
4538 if (data && !pdump_get_entry (data))
4539 {
4540 int me = depth++;
4541 int i;
4542 if (me>65536)
4543 {
4544 fprintf (stderr, "Backtrace overflow, loop ?\n");
4545 abort ();
4546 }
4547 backtrace[me].obj = 0;
4548 backtrace[me].position = 0;
4549 backtrace[me].offset = 0;
4550
4551 pdump_add_entry (pdump_get_entry_list (sdesc),
4552 data,
4553 sdesc->size,
4554 count,
4555 0);
4556 for (i=0; i<count; i++)
4557 {
4558 pdump_register_sub (((char *)data) + sdesc->size*i,
4559 sdesc->description,
4560 me);
4561 }
4562 --depth;
4563 }
4564 }
4565
4566 static void
4567 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4568 {
4569 size_t size = elmt->size;
4570 int count = elmt->count;
4571 if (desc)
4572 {
4573 int pos, i;
4574 memcpy (pdump_buf, elmt->obj, size*count);
4575
4576 for (i=0; i<count; i++)
4577 {
4578 char *cur = ((char *)pdump_buf) + i*size;
4579 restart:
4580 for (pos = 0; desc[pos].type != XD_END; pos++)
4581 {
4582 void *rdata = cur + desc[pos].offset;
4583 switch (desc[pos].type)
4584 {
4585 case XD_SPECIFIER_END:
4586 desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4587 goto restart;
4588 case XD_SIZE_T:
4589 case XD_INT:
4590 case XD_LONG:
4591 case XD_BYTECOUNT:
4592 break;
4593 case XD_LO_RESET_NIL:
4594 {
4595 EMACS_INT count = desc[pos].data1;
4596 int i;
4597 if (XD_IS_INDIRECT (count))
4598 count = pdump_get_indirect_count (count, desc, elmt->obj);
4599 for (i=0; i<count; i++)
4600 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4601 break;
4602 }
4603 case XD_INT_RESET:
4604 {
4605 EMACS_INT val = desc[pos].data1;
4606 if (XD_IS_INDIRECT (val))
4607 val = pdump_get_indirect_count (val, desc, elmt->obj);
4608 *(int *)rdata = val;
4609 break;
4610 }
4611 case XD_OPAQUE_DATA_PTR:
4612 case XD_C_STRING:
4613 case XD_STRUCT_PTR:
4614 {
4615 void *ptr = *(void **)rdata;
4616 if (ptr)
4617 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4618 break;
4619 }
4620 case XD_LO_LINK:
4621 {
4622 Lisp_Object obj = *(Lisp_Object *)rdata;
4623 pdump_entry_list_elmt *elmt1;
4624 for (;;)
4625 {
4626 elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
4627 if (elmt1)
4628 break;
4629 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4630 }
4631 *(EMACS_INT *)rdata = elmt1->save_offset;
4632 break;
4633 }
4634 case XD_LISP_OBJECT:
4635 {
4636 Lisp_Object *pobj = (Lisp_Object *) rdata;
4637
4638 assert (desc[pos].data1 == 0);
4639
4640 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4641 *(EMACS_INT *)pobj =
4642 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4643 break;
4644 }
4645 case XD_LISP_OBJECT_ARRAY:
4646 {
4647 EMACS_INT count = desc[pos].data1;
4648 int i;
4649 if (XD_IS_INDIRECT (count))
4650 count = pdump_get_indirect_count (count, desc, elmt->obj);
4651
4652 for (i=0; i<count; i++)
4653 {
4654 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4655 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4656 *(EMACS_INT *)pobj =
4657 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4658 }
4659 break;
4660 }
4661 case XD_DOC_STRING:
4662 {
4663 EMACS_INT str = *(EMACS_INT *)rdata;
4664 if (str > 0)
4665 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4666 break;
4667 }
4668 default:
4669 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4670 abort ();
4671 };
4672 }
4673 }
4674 }
4675 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4676 if (elmt->is_lrecord && ((size*count) & 3))
4677 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4678 }
4679
4680 static void
4681 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4682 {
4683 int pos;
4684
4685 restart:
4686 for (pos = 0; desc[pos].type != XD_END; pos++)
4687 {
4688 void *rdata = (char *)data + desc[pos].offset;
4689 switch (desc[pos].type)
4690 {
4691 case XD_SPECIFIER_END:
4692 pos = 0;
4693 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4694 goto restart;
4695 case XD_SIZE_T:
4696 case XD_INT:
4697 case XD_LONG:
4698 case XD_BYTECOUNT:
4699 case XD_INT_RESET:
4700 break;
4701 case XD_OPAQUE_DATA_PTR:
4702 case XD_C_STRING:
4703 case XD_STRUCT_PTR:
4704 case XD_LO_LINK:
4705 {
4706 EMACS_INT ptr = *(EMACS_INT *)rdata;
4707 if (ptr)
4708 *(EMACS_INT *)rdata = ptr+delta;
4709 break;
4710 }
4711 case XD_LISP_OBJECT:
4712 {
4713 Lisp_Object *pobj = (Lisp_Object *) rdata;
4714
4715 assert (desc[pos].data1 == 0);
4716
4717 if (POINTER_TYPE_P (XTYPE (*pobj))
4718 && ! EQ (*pobj, Qnull_pointer))
4719 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4720
4721 break;
4722 }
4723 case XD_LISP_OBJECT_ARRAY:
4724 case XD_LO_RESET_NIL:
4725 {
4726 EMACS_INT count = desc[pos].data1;
4727 int i;
4728 if (XD_IS_INDIRECT (count))
4729 count = pdump_get_indirect_count (count, desc, data);
4730
4731 for (i=0; i<count; i++)
4732 {
4733 Lisp_Object *pobj = (Lisp_Object *) rdata + i;
4734
4735 if (POINTER_TYPE_P (XTYPE (*pobj))
4736 && ! EQ (*pobj, Qnull_pointer))
4737 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4738 }
4739 break;
4740 }
4741 case XD_DOC_STRING:
4742 {
4743 EMACS_INT str = *(EMACS_INT *)rdata;
4744 if (str > 0)
4745 *(EMACS_INT *)rdata = str + delta;
4746 break;
4747 }
4748 default:
4749 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4750 abort ();
4751 };
4752 }
4753 }
4754
4755 static void
4756 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4757 {
4758 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4759 elmt->save_offset = cur_offset;
4760 if (size>max_size)
4761 max_size = size;
4762 cur_offset += size;
4763 }
4764
4765 static void
4766 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4767 {
4768 int align, i;
4769 const struct lrecord_description *idesc;
4770 pdump_entry_list_elmt *elmt;
4771 for (align=8; align>=0; align--)
4772 {
4773 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4774 if (pdump_object_table[i].align == align)
4775 {
4776 elmt = pdump_object_table[i].first;
4777 if (!elmt)
4778 continue;
4779 idesc = lrecord_implementations_table[i]->description;
4780 while (elmt)
4781 {
4782 f (elmt, idesc);
4783 elmt = elmt->next;
4784 }
4785 }
4786
4787 for (i=0; i<pdump_struct_table.count; i++)
4788 if (pdump_struct_table.list[i].list.align == align)
4789 {
4790 elmt = pdump_struct_table.list[i].list.first;
4791 idesc = pdump_struct_table.list[i].sdesc->description;
4792 while (elmt)
4793 {
4794 f (elmt, idesc);
4795 elmt = elmt->next;
4796 }
4797 }
4798
4799 elmt = pdump_opaque_data_list.first;
4800 while (elmt)
4801 {
4802 if (align_table[elmt->size & 255] == align)
4803 f (elmt, 0);
4804 elmt = elmt->next;
4805 }
4806 }
4807 }
4808
4809 static void
4810 pdump_dump_staticvec (void)
4811 {
4812 EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
4813 int i;
4814 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4815
4816 for (i=0; i<staticidx; i++)
4817 {
4818 Lisp_Object obj = *staticvec[i];
4819 if (POINTER_TYPE_P (XTYPE (obj)))
4820 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4821 else
4822 reloc[i] = *(EMACS_INT *)(staticvec[i]);
4823 }
4824 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4825 free (reloc);
4826 }
4827
4828 static void
4829 pdump_dump_structvec (void)
4830 {
4831 int i;
4832 for (i=0; i<dumpstructidx; i++)
4833 {
4834 EMACS_INT adr;
4835 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4836 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4837 write (pdump_fd, &adr, sizeof (adr));
4838 }
4839 }
4840
4841 static void
4842 pdump_dump_opaquevec (void)
4843 {
4844 int i;
4845 for (i=0; i<dumpopaqueidx; i++)
4846 {
4847 write (pdump_fd, &(dumpopaquevec[i]), sizeof (dumpopaquevec[i]));
4848 write (pdump_fd, dumpopaquevec[i].data, dumpopaquevec[i].size);
4849 }
4850 }
4851
4852 static void
4853 pdump_dump_itable (void)
4854 {
4855 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4856 }
4857
4858 static void
4859 pdump_dump_rtables (void)
4860 {
4861 int i, j;
4862 pdump_entry_list_elmt *elmt;
4863 pdump_reloc_table rt;
4864
4865 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4866 {
4867 elmt = pdump_object_table[i].first;
4868 if (!elmt)
4869 continue;
4870 rt.desc = lrecord_implementations_table[i]->description;
4871 rt.count = pdump_object_table[i].count;
4872 write (pdump_fd, &rt, sizeof (rt));
4873 while (elmt)
4874 {
4875 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4876 write (pdump_fd, &rdata, sizeof (rdata));
4877 elmt = elmt->next;
4878 }
4879 }
4880
4881 rt.desc = 0;
4882 rt.count = 0;
4883 write (pdump_fd, &rt, sizeof (rt));
4884
4885 for (i=0; i<pdump_struct_table.count; i++)
4886 {
4887 elmt = pdump_struct_table.list[i].list.first;
4888 rt.desc = pdump_struct_table.list[i].sdesc->description;
4889 rt.count = pdump_struct_table.list[i].list.count;
4890 write (pdump_fd, &rt, sizeof (rt));
4891 while (elmt)
4892 {
4893 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4894 for (j=0; j<elmt->count; j++)
4895 {
4896 write (pdump_fd, &rdata, sizeof (rdata));
4897 rdata += elmt->size;
4898 }
4899 elmt = elmt->next;
4900 }
4901 }
4902 rt.desc = 0;
4903 rt.count = 0;
4904 write (pdump_fd, &rt, sizeof (rt));
4905 }
4906
4907 static void
4908 pdump_dump_wired (void)
4909 {
4910 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4911 int i;
4912
4913 write (pdump_fd, &count, sizeof (count));
4914
4915 for (i=0; i<pdump_wireidx; i++)
4916 {
4917 EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4918 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4919 write (pdump_fd, &obj, sizeof (obj));
4920 }
4921
4922 for (i=0; i<pdump_wireidx_list; i++)
4923 {
4924 Lisp_Object obj = *(pdump_wirevec_list[i]);
4925 pdump_entry_list_elmt *elmt;
4926 EMACS_INT res;
4927
4928 for (;;)
4929 {
4930 const struct lrecord_description *desc;
4931 int pos;
4932 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4933 if (elmt)
4934 break;
4935 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
4936 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
4937 if (desc[pos].type == XD_END)
4938 abort ();
4939
4940 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4941 }
4942 res = elmt->save_offset;
4943
4944 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
4945 write (pdump_fd, &res, sizeof (res));
4946 }
4947 }
4948
4949 void
4950 pdump (void)
4951 {
4952 int i;
4953 Lisp_Object t_console, t_device, t_frame;
4954 int none;
4955 dump_header hd;
4956
4957 /* These appear in a DEFVAR_LISP, which does a staticpro() */
4958 t_console = Vterminal_console;
4959 t_frame = Vterminal_frame;
4960 t_device = Vterminal_device;
4961
4962 Vterminal_console = Qnil;
4963 Vterminal_frame = Qnil;
4964 Vterminal_device = Qnil;
4965
4966 pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
4967
4968 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4969 {
4970 pdump_object_table[i].first = 0;
4971 pdump_object_table[i].align = 8;
4972 pdump_object_table[i].count = 0;
4973 pdump_alert_undump_object[i] = 0;
4974 }
4975 pdump_struct_table.count = 0;
4976 pdump_struct_table.size = -1;
4977
4978 pdump_opaque_data_list.first = 0;
4979 pdump_opaque_data_list.align = 8;
4980 pdump_opaque_data_list.count = 0;
4981 depth = 0;
4982
4983 for (i=0; i<staticidx; i++)
4984 pdump_register_object (*staticvec[i]);
4985 for (i=0; i<pdump_wireidx; i++)
4986 pdump_register_object (*pdump_wirevec[i]);
4987
4988 none = 1;
4989 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4990 if (pdump_alert_undump_object[i])
4991 {
4992 if (none)
4993 printf ("Undumpable types list :\n");
4994 none = 0;
4995 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
4996 }
4997 if (!none)
4998 return;
4999
5000 for (i=0; i<dumpstructidx; i++)
5001 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
5002
5003 memcpy (hd.signature, "XEmacsDP", 8);
5004 hd.reloc_address = 0;
5005 hd.nb_staticpro = staticidx;
5006 hd.nb_structdmp = dumpstructidx;
5007 hd.nb_opaquedmp = dumpopaqueidx;
5008 hd.last_type = last_lrecord_type_index_assigned;
5009
5010 cur_offset = 256;
5011 max_size = 0;
5012
5013 pdump_scan_by_alignment (pdump_allocate_offset);
5014 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
5015
5016 pdump_buf = xmalloc (max_size);
5017 /* Avoid use of the `open' macro. We want the real function. */
5018 #undef open
5019 pdump_fd = open ("xemacs.dmp",
5020 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
5021 hd.stab_offset = (cur_offset + 3) & ~3;
5022
5023 write (pdump_fd, &hd, sizeof (hd));
5024 lseek (pdump_fd, 256, SEEK_SET);
5025
5026 pdump_scan_by_alignment (pdump_dump_data);
5027
5028 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
5029
5030 pdump_dump_staticvec ();
5031 pdump_dump_structvec ();
5032 pdump_dump_opaquevec ();
5033 pdump_dump_itable ();
5034 pdump_dump_rtables ();
5035 pdump_dump_wired ();
5036
5037 close (pdump_fd);
5038 free (pdump_buf);
5039
5040 free (pdump_hash);
5041
5042 Vterminal_console = t_console;
5043 Vterminal_frame = t_frame;
5044 Vterminal_device = t_device;
5045 }
5046
5047 int
5048 pdump_load (void)
5049 {
5050 size_t length;
5051 int i;
5052 char *p;
5053 EMACS_INT delta;
5054 EMACS_INT count;
5055
5056 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
5057
5058 pdump_start = pdump_end = 0;
5059
5060 pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
5061 if (pdump_fd<0)
5062 return 0;
5063
5064 length = lseek (pdump_fd, 0, SEEK_END);
5065 lseek (pdump_fd, 0, SEEK_SET);
5066
5067 #ifdef HAVE_MMAP
5068 pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5069 if (pdump_start == MAP_FAILED)
5070 pdump_start = 0;
5071 #endif
5072
5073 if (!pdump_start)
5074 {
5075 pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
5076 read (pdump_fd, pdump_start, length);
5077 }
5078
5079 close (pdump_fd);
5080
5081 pdump_end = pdump_start + length;
5082
5083 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5084 last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
5085 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5086 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5087
5088 /* Put back the staticvec in place */
5089 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5090 p += staticidx*sizeof (Lisp_Object *);
5091 for (i=0; i<staticidx; i++)
5092 {
5093 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5094 if (POINTER_TYPE_P (XTYPE (obj)))
5095 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5096 *staticvec[i] = obj;
5097 }
5098
5099 /* Put back the dumpstructs */
5100 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5101 {
5102 void **adr = PDUMP_READ (p, void **);
5103 *adr = (void *) (PDUMP_READ (p, char *) + delta);
5104 }
5105
5106 /* Put back the opaques */
5107 for (i=0; i<((dump_header *)pdump_start)->nb_opaquedmp; i++)
5108 {
5109 struct dumpopaque_info di = PDUMP_READ (p, struct dumpopaque_info);
5110 memcpy (di.data, p, di.size);
5111 p += di.size;
5112 }
5113
5114 /* Put back the lrecord_implementations_table */
5115 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5116 p += sizeof (lrecord_implementations_table);
5117
5118 /* Reinitialize lrecord_markers from lrecord_implementations_table */
5119 for (i=0; i < countof (lrecord_implementations_table); i++)
5120 if (lrecord_implementations_table[i])
5121 lrecord_markers[i] = lrecord_implementations_table[i]->marker;
5122
5123 /* Do the relocations */
5124 pdump_rt_list = p;
5125 count = 2;
5126 for (;;)
5127 {
5128 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5129 if (rt.desc)
5130 {
5131 for (i=0; i < rt.count; i++)
5132 {
5133 char *adr = delta + *(char **)p;
5134 *(char **)p = adr;
5135 pdump_reloc_one (adr, delta, rt.desc);
5136 p += sizeof (char *);
5137 }
5138 } else
5139 if (!(--count))
5140 break;
5141 }
5142
5143 /* Put the pdump_wire variables in place */
5144 count = PDUMP_READ (p, EMACS_INT);
5145
5146 for (i=0; i<count; i++)
5147 {
5148 Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
5149 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5150
5151 if (POINTER_TYPE_P (XTYPE (obj)))
5152 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5153
5154 *var = obj;
5155 }
5156
5157 /* Final cleanups */
5158 /* reorganize hash tables */
5159 p = pdump_rt_list;
5160 for (;;)
5161 {
5162 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5163 if (!rt.desc)
5164 break;
5165 if (rt.desc == hash_table_description)
5166 {
5167 for (i=0; i < rt.count; i++)
5168 pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
5169 break;
5170 } else
5171 p += sizeof (Lisp_Object) * rt.count;
5172 }
5173
5174 /* Put back noninteractive1 to its real value */
5175 noninteractive1 = noninteractive;
5176
5177 return 1;
5178 }
5179
5180 #endif /* PDUMP */
5181