XEmacs 21.2.41 "Polyhymnia".
[chise/xemacs-chise.git.1] / src / dumper.c
1 /* Portable data dumper for XEmacs.
2    Copyright (C) 1999-2000 Olivier Galibert
3
4 This file is part of XEmacs.
5
6 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the
8 Free Software Foundation; either version 2, or (at your option) any
9 later version.
10
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
14 for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING.  If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.  */
20
21 /* Synched up with: Not in FSF. */
22
23 #include <config.h>
24 #include "lisp.h"
25
26 #include "dump-id.h"
27 #include "specifier.h"
28 #include "elhash.h"
29 #include "sysfile.h"
30 #include "console-stream.h"
31 #include "dumper.h"
32
33 #ifdef WIN32_NATIVE
34 #include "nt.h"
35 #else
36 #ifdef HAVE_MMAP
37 #include <sys/mman.h>
38 #endif
39 #endif
40
41 #ifndef SEPCHAR
42 #define SEPCHAR ':'
43 #endif
44
45 typedef struct
46 {
47   void *varaddress;
48   size_t size;
49 } pdump_opaque;
50
51 typedef struct
52 {
53   Dynarr_declare (pdump_opaque);
54 } pdump_opaque_dynarr;
55
56 typedef struct
57 {
58   void **ptraddress;
59   const struct struct_description *desc;
60 } pdump_root_struct_ptr;
61
62 typedef struct
63 {
64   Dynarr_declare (pdump_root_struct_ptr);
65 } pdump_root_struct_ptr_dynarr;
66
67 static pdump_opaque_dynarr *pdump_opaques;
68 static pdump_root_struct_ptr_dynarr *pdump_root_struct_ptrs;
69 static Lisp_Object_ptr_dynarr *pdump_root_objects;
70 static Lisp_Object_ptr_dynarr *pdump_weak_object_chains;
71
72 /* Mark SIZE bytes at non-heap address VARADDRESS for dumping as is,
73    without any bit-twiddling. */
74 void
75 dump_add_opaque (void *varaddress, size_t size)
76 {
77   pdump_opaque info;
78   info.varaddress = varaddress;
79   info.size = size;
80   if (pdump_opaques == NULL)
81     pdump_opaques = Dynarr_new (pdump_opaque);
82   Dynarr_add (pdump_opaques, info);
83 }
84
85 /* Mark the struct described by DESC and pointed to by the pointer at
86    non-heap address VARADDRESS for dumping.
87    All the objects reachable from this pointer will also be dumped. */
88 void
89 dump_add_root_struct_ptr (void *ptraddress, const struct struct_description *desc)
90 {
91   pdump_root_struct_ptr info;
92   info.ptraddress = (void **) ptraddress;
93   info.desc = desc;
94   if (pdump_root_struct_ptrs == NULL)
95     pdump_root_struct_ptrs = Dynarr_new (pdump_root_struct_ptr);
96   Dynarr_add (pdump_root_struct_ptrs, info);
97 }
98
99 /* Mark the Lisp_Object at non-heap address VARADDRESS for dumping.
100    All the objects reachable from this var will also be dumped. */
101 void
102 dump_add_root_object (Lisp_Object *varaddress)
103 {
104   if (pdump_root_objects == NULL)
105     pdump_root_objects = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
106   Dynarr_add (pdump_root_objects, varaddress);
107 }
108
109 /* Mark the list pointed to by the Lisp_Object at VARADDRESS for dumping. */
110 void
111 dump_add_weak_object_chain (Lisp_Object *varaddress)
112 {
113   if (pdump_weak_object_chains == NULL)
114     pdump_weak_object_chains = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
115   Dynarr_add (pdump_weak_object_chains, varaddress);
116 }
117 \f
118
119 typedef struct
120 {
121   const struct lrecord_description *desc;
122   int count;
123 } pdump_reloc_table;
124
125 static char *pdump_rt_list = 0;
126
127 void
128 pdump_objects_unmark (void)
129 {
130   int i;
131   char *p = pdump_rt_list;
132   if (p)
133     for (;;)
134       {
135         pdump_reloc_table *rt = (pdump_reloc_table *)p;
136         p += sizeof (pdump_reloc_table);
137         if (rt->desc)
138           {
139             for (i=0; i<rt->count; i++)
140               {
141                 struct lrecord_header *lh = * (struct lrecord_header **) p;
142                 if (! C_READONLY_RECORD_HEADER_P (lh))
143                   UNMARK_RECORD_HEADER (lh);
144                 p += sizeof (EMACS_INT);
145               }
146           } else
147             break;
148       }
149 }
150
151
152 /* The structure of the file
153  *
154  * 0                    - header
155  * 256                  - dumped objects
156  * stab_offset          - nb_root_struct_ptrs*pair(void *, adr) for pointers to structures
157  *                      - nb_opaques*pair(void *, size) for raw bits to restore
158  *                      - relocation table
159  *                      - wired variable address/value couples with the count preceding the list
160  */
161
162
163 #define PDUMP_SIGNATURE "XEmacsDP"
164 #define PDUMP_SIGNATURE_LEN (sizeof (PDUMP_SIGNATURE) - 1)
165
166 typedef struct
167 {
168   char signature[PDUMP_SIGNATURE_LEN];
169   unsigned int id;
170   EMACS_UINT stab_offset;
171   EMACS_UINT reloc_address;
172   int nb_root_struct_ptrs;
173   int nb_opaques;
174 } pdump_header;
175
176 char *pdump_start, *pdump_end;
177 static size_t pdump_length;
178
179 #ifdef WIN32_NATIVE
180 /* Handle for the dump file */
181 HANDLE pdump_hFile = INVALID_HANDLE_VALUE;
182 /* Handle for the file mapping object for the dump file */
183 HANDLE pdump_hMap = INVALID_HANDLE_VALUE;
184 #endif
185
186 void (*pdump_free) (void);
187
188 static const unsigned char pdump_align_table[256] =
189 {
190   8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
191   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
192   5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
193   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
194   6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
195   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
196   5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
197   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
198   7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
199   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
200   5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
201   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
202   6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
203   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
204   5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
205   4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
206 };
207
208 typedef struct pdump_entry_list_elmt
209 {
210   struct pdump_entry_list_elmt *next;
211   const void *obj;
212   size_t size;
213   int count;
214   int is_lrecord;
215   EMACS_INT save_offset;
216 } pdump_entry_list_elmt;
217
218 typedef struct
219 {
220   pdump_entry_list_elmt *first;
221   int align;
222   int count;
223 } pdump_entry_list;
224
225 typedef struct pdump_struct_list_elmt
226 {
227   pdump_entry_list list;
228   const struct struct_description *sdesc;
229 } pdump_struct_list_elmt;
230
231 typedef struct
232 {
233   pdump_struct_list_elmt *list;
234   int count;
235   int size;
236 } pdump_struct_list;
237
238 static pdump_entry_list pdump_object_table[256];
239 static pdump_entry_list pdump_opaque_data_list;
240 static pdump_struct_list pdump_struct_table;
241
242 static int pdump_alert_undump_object[256];
243
244 static unsigned long cur_offset;
245 static size_t max_size;
246 static int pdump_fd;
247 static void *pdump_buf;
248
249 #define PDUMP_HASHSIZE 200001
250
251 static pdump_entry_list_elmt **pdump_hash;
252
253 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
254 static int
255 pdump_make_hash (const void *obj)
256 {
257   return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
258 }
259
260 static pdump_entry_list_elmt *
261 pdump_get_entry (const void *obj)
262 {
263   int pos = pdump_make_hash (obj);
264   pdump_entry_list_elmt *e;
265
266   assert (obj != 0);
267
268   while ((e = pdump_hash[pos]) != 0)
269     {
270       if (e->obj == obj)
271         return e;
272
273       pos++;
274       if (pos == PDUMP_HASHSIZE)
275         pos = 0;
276     }
277   return 0;
278 }
279
280 static void
281 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
282 {
283   pdump_entry_list_elmt *e;
284   int align;
285   int pos = pdump_make_hash (obj);
286
287   while ((e = pdump_hash[pos]) != 0)
288     {
289       if (e->obj == obj)
290         return;
291
292       pos++;
293       if (pos == PDUMP_HASHSIZE)
294         pos = 0;
295     }
296
297   e = xnew (pdump_entry_list_elmt);
298
299   e->next = list->first;
300   e->obj = obj;
301   e->size = size;
302   e->count = count;
303   e->is_lrecord = is_lrecord;
304   list->first = e;
305
306   list->count += count;
307   pdump_hash[pos] = e;
308
309   align = pdump_align_table[size & 255];
310   if (align < 2 && is_lrecord)
311     align = 2;
312
313   if (align < list->align)
314     list->align = align;
315 }
316
317 static pdump_entry_list *
318 pdump_get_entry_list (const struct struct_description *sdesc)
319 {
320   int i;
321   for (i=0; i<pdump_struct_table.count; i++)
322     if (pdump_struct_table.list[i].sdesc == sdesc)
323       return &pdump_struct_table.list[i].list;
324
325   if (pdump_struct_table.size <= pdump_struct_table.count)
326     {
327       if (pdump_struct_table.size == -1)
328         pdump_struct_table.size = 10;
329       else
330         pdump_struct_table.size = pdump_struct_table.size * 2;
331       pdump_struct_table.list = (pdump_struct_list_elmt *)
332         xrealloc (pdump_struct_table.list,
333                   pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
334     }
335   pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
336   pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
337   pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
338   pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
339
340   return &pdump_struct_table.list[pdump_struct_table.count++].list;
341 }
342
343 static struct
344 {
345   struct lrecord_header *obj;
346   int position;
347   int offset;
348 } backtrace[65536];
349
350 static int depth;
351
352 static void
353 pdump_backtrace (void)
354 {
355   int i;
356   stderr_out ("pdump backtrace :\n");
357   for (i=0;i<depth;i++)
358     {
359       if (!backtrace[i].obj)
360         stderr_out ("  - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
361       else
362         {
363           stderr_out ("  - %s (%d, %d)\n",
364                    LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
365                    backtrace[i].position,
366                    backtrace[i].offset);
367         }
368     }
369 }
370
371 static void pdump_register_object (Lisp_Object obj);
372 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
373
374 static EMACS_INT
375 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
376 {
377   EMACS_INT count;
378   const void *irdata;
379
380   int line = XD_INDIRECT_VAL (code);
381   int delta = XD_INDIRECT_DELTA (code);
382
383   irdata = ((char *)idata) + idesc[line].offset;
384   switch (idesc[line].type)
385     {
386     case XD_SIZE_T:
387       count = *(size_t *)irdata;
388       break;
389     case XD_INT:
390       count = *(int *)irdata;
391       break;
392     case XD_LONG:
393       count = *(long *)irdata;
394       break;
395     case XD_BYTECOUNT:
396       count = *(Bytecount *)irdata;
397       break;
398     default:
399       stderr_out ("Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
400       pdump_backtrace ();
401       abort ();
402     }
403   count += delta;
404   return count;
405 }
406
407 static void
408 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
409 {
410   int pos;
411
412  restart:
413   for (pos = 0; desc[pos].type != XD_END; pos++)
414     {
415       const void *rdata = (const char *)data + desc[pos].offset;
416
417       backtrace[me].position = pos;
418       backtrace[me].offset = desc[pos].offset;
419
420       switch (desc[pos].type)
421         {
422         case XD_SPECIFIER_END:
423           pos = 0;
424           desc = ((const Lisp_Specifier *)data)->methods->extra_description;
425           goto restart;
426         case XD_SIZE_T:
427         case XD_INT:
428         case XD_LONG:
429         case XD_BYTECOUNT:
430         case XD_INT_RESET:
431         case XD_LO_LINK:
432           break;
433         case XD_OPAQUE_DATA_PTR:
434           {
435             EMACS_INT count = desc[pos].data1;
436             if (XD_IS_INDIRECT (count))
437               count = pdump_get_indirect_count (count, desc, data);
438
439             pdump_add_entry (&pdump_opaque_data_list,
440                              *(void **)rdata,
441                              count,
442                              1,
443                              0);
444             break;
445           }
446         case XD_C_STRING:
447           {
448             const char *str = *(const char **)rdata;
449             if (str)
450               pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
451             break;
452           }
453         case XD_DOC_STRING:
454           {
455             const char *str = *(const char **)rdata;
456             if ((EMACS_INT)str > 0)
457               pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
458             break;
459           }
460         case XD_LISP_OBJECT:
461           {
462             const Lisp_Object *pobj = (const Lisp_Object *)rdata;
463
464             assert (desc[pos].data1 == 0);
465
466             backtrace[me].offset = (const char *)pobj - (const char *)data;
467             pdump_register_object (*pobj);
468             break;
469           }
470         case XD_LISP_OBJECT_ARRAY:
471           {
472             int i;
473             EMACS_INT count = desc[pos].data1;
474             if (XD_IS_INDIRECT (count))
475               count = pdump_get_indirect_count (count, desc, data);
476
477             for (i = 0; i < count; i++)
478               {
479                 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
480                 Lisp_Object dobj = *pobj;
481
482                 backtrace[me].offset = (const char *)pobj - (const char *)data;
483                 pdump_register_object (dobj);
484               }
485             break;
486           }
487         case XD_STRUCT_PTR:
488           {
489             EMACS_INT count = desc[pos].data1;
490             const struct struct_description *sdesc = desc[pos].data2;
491             const char *dobj = *(const char **)rdata;
492             if (dobj)
493               {
494                 if (XD_IS_INDIRECT (count))
495                   count = pdump_get_indirect_count (count, desc, data);
496
497                 pdump_register_struct (dobj, sdesc, count);
498               }
499             break;
500           }
501         default:
502           stderr_out ("Unsupported dump type : %d\n", desc[pos].type);
503           pdump_backtrace ();
504           abort ();
505         };
506     }
507 }
508
509 static void
510 pdump_register_object (Lisp_Object obj)
511 {
512   struct lrecord_header *objh;
513
514   if (!POINTER_TYPE_P (XTYPE (obj)))
515     return;
516
517   objh = XRECORD_LHEADER (obj);
518   if (!objh)
519     return;
520
521   if (pdump_get_entry (objh))
522     return;
523
524   if (LHEADER_IMPLEMENTATION (objh)->description)
525     {
526       int me = depth++;
527       if (me>65536)
528         {
529           stderr_out ("Backtrace overflow, loop ?\n");
530           abort ();
531         }
532       backtrace[me].obj = objh;
533       backtrace[me].position = 0;
534       backtrace[me].offset = 0;
535
536       pdump_add_entry (pdump_object_table + objh->type,
537                        objh,
538                        LHEADER_IMPLEMENTATION (objh)->static_size ?
539                        LHEADER_IMPLEMENTATION (objh)->static_size :
540                        LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
541                        1,
542                        1);
543       pdump_register_sub (objh,
544                           LHEADER_IMPLEMENTATION (objh)->description,
545                           me);
546       --depth;
547     }
548   else
549     {
550       pdump_alert_undump_object[objh->type]++;
551       stderr_out ("Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
552       pdump_backtrace ();
553     }
554 }
555
556 static void
557 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
558 {
559   if (data && !pdump_get_entry (data))
560     {
561       int me = depth++;
562       int i;
563       if (me>65536)
564         {
565           stderr_out ("Backtrace overflow, loop ?\n");
566           abort ();
567         }
568       backtrace[me].obj = 0;
569       backtrace[me].position = 0;
570       backtrace[me].offset = 0;
571
572       pdump_add_entry (pdump_get_entry_list (sdesc),
573                        data,
574                        sdesc->size,
575                        count,
576                        0);
577       for (i=0; i<count; i++)
578         {
579           pdump_register_sub (((char *)data) + sdesc->size*i,
580                               sdesc->description,
581                               me);
582         }
583       --depth;
584     }
585 }
586
587 static void
588 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
589 {
590   size_t size = elmt->size;
591   int count = elmt->count;
592   if (desc)
593     {
594       int pos, i;
595       memcpy (pdump_buf, elmt->obj, size*count);
596
597       for (i=0; i<count; i++)
598         {
599           char *cur = ((char *)pdump_buf) + i*size;
600         restart:
601           for (pos = 0; desc[pos].type != XD_END; pos++)
602             {
603               void *rdata = cur + desc[pos].offset;
604               switch (desc[pos].type)
605                 {
606                 case XD_SPECIFIER_END:
607                   desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
608                   goto restart;
609                 case XD_SIZE_T:
610                 case XD_INT:
611                 case XD_LONG:
612                 case XD_BYTECOUNT:
613                   break;
614                 case XD_INT_RESET:
615                   {
616                     EMACS_INT val = desc[pos].data1;
617                     if (XD_IS_INDIRECT (val))
618                       val = pdump_get_indirect_count (val, desc, elmt->obj);
619                     *(int *)rdata = val;
620                     break;
621                   }
622                 case XD_OPAQUE_DATA_PTR:
623                 case XD_C_STRING:
624                 case XD_STRUCT_PTR:
625                   {
626                     void *ptr = *(void **)rdata;
627                     if (ptr)
628                       *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
629                     break;
630                   }
631                 case XD_LO_LINK:
632                   {
633                     Lisp_Object obj = *(Lisp_Object *)rdata;
634                     pdump_entry_list_elmt *elmt1;
635                     for (;;)
636                       {
637                         elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
638                         if (elmt1)
639                           break;
640                         obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
641                       }
642                     *(EMACS_INT *)rdata = elmt1->save_offset;
643                     break;
644                   }
645                 case XD_LISP_OBJECT:
646                   {
647                     Lisp_Object *pobj = (Lisp_Object *) rdata;
648
649                     assert (desc[pos].data1 == 0);
650
651                     if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
652                       *(EMACS_INT *)pobj =
653                         pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
654                     break;
655                   }
656                 case XD_LISP_OBJECT_ARRAY:
657                   {
658                     EMACS_INT num = desc[pos].data1;
659                     int j;
660                     if (XD_IS_INDIRECT (num))
661                       num = pdump_get_indirect_count (num, desc, elmt->obj);
662
663                     for (j=0; j<num; j++)
664                       {
665                         Lisp_Object *pobj = ((Lisp_Object *)rdata) + j;
666                         if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
667                           *(EMACS_INT *)pobj =
668                             pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
669                       }
670                     break;
671                   }
672                 case XD_DOC_STRING:
673                   {
674                     EMACS_INT str = *(EMACS_INT *)rdata;
675                     if (str > 0)
676                       *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
677                     break;
678                   }
679                 default:
680                   stderr_out ("Unsupported dump type : %d\n", desc[pos].type);
681                   abort ();
682                 };
683             }
684         }
685     }
686   write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
687   if (elmt->is_lrecord && ((size*count) & 3))
688     write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
689 }
690
691 static void
692 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
693 {
694   int pos;
695
696  restart:
697   for (pos = 0; desc[pos].type != XD_END; pos++)
698     {
699       void *rdata = (char *)data + desc[pos].offset;
700       switch (desc[pos].type)
701         {
702         case XD_SPECIFIER_END:
703           pos = 0;
704           desc = ((const Lisp_Specifier *)data)->methods->extra_description;
705           goto restart;
706         case XD_SIZE_T:
707         case XD_INT:
708         case XD_LONG:
709         case XD_BYTECOUNT:
710         case XD_INT_RESET:
711           break;
712         case XD_OPAQUE_DATA_PTR:
713         case XD_C_STRING:
714         case XD_STRUCT_PTR:
715         case XD_LO_LINK:
716           {
717             EMACS_INT ptr = *(EMACS_INT *)rdata;
718             if (ptr)
719               *(EMACS_INT *)rdata = ptr+delta;
720             break;
721           }
722         case XD_LISP_OBJECT:
723           {
724             Lisp_Object *pobj = (Lisp_Object *) rdata;
725
726             assert (desc[pos].data1 == 0);
727
728             if (POINTER_TYPE_P (XTYPE (*pobj))
729                 && ! EQ (*pobj, Qnull_pointer))
730               XSETOBJ (*pobj, (char *) XPNTR (*pobj) + delta);
731
732             break;
733           }
734         case XD_LISP_OBJECT_ARRAY:
735           {
736             EMACS_INT num = desc[pos].data1;
737             int j;
738             if (XD_IS_INDIRECT (num))
739               num = pdump_get_indirect_count (num, desc, data);
740
741             for (j=0; j<num; j++)
742               {
743                 Lisp_Object *pobj = (Lisp_Object *) rdata + j;
744
745                 if (POINTER_TYPE_P (XTYPE (*pobj))
746                     && ! EQ (*pobj, Qnull_pointer))
747                   XSETOBJ (*pobj, (char *) XPNTR (*pobj) + delta);
748               }
749             break;
750           }
751         case XD_DOC_STRING:
752           {
753             EMACS_INT str = *(EMACS_INT *)rdata;
754             if (str > 0)
755               *(EMACS_INT *)rdata = str + delta;
756             break;
757           }
758         default:
759           stderr_out ("Unsupported dump type : %d\n", desc[pos].type);
760           abort ();
761         };
762     }
763 }
764
765 static void
766 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
767 {
768   size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
769   elmt->save_offset = cur_offset;
770   if (size>max_size)
771     max_size = size;
772   cur_offset += size;
773 }
774
775 static void
776 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
777 {
778   int align, i;
779   const struct lrecord_description *idesc;
780   pdump_entry_list_elmt *elmt;
781   for (align=8; align>=0; align--)
782     {
783       for (i=0; i<lrecord_type_count; i++)
784         if (pdump_object_table[i].align == align)
785           {
786             elmt = pdump_object_table[i].first;
787             if (!elmt)
788               continue;
789             idesc = lrecord_implementations_table[i]->description;
790             while (elmt)
791               {
792                 f (elmt, idesc);
793                 elmt = elmt->next;
794               }
795           }
796
797       for (i=0; i<pdump_struct_table.count; i++)
798         if (pdump_struct_table.list[i].list.align == align)
799           {
800             elmt = pdump_struct_table.list[i].list.first;
801             idesc = pdump_struct_table.list[i].sdesc->description;
802             while (elmt)
803               {
804                 f (elmt, idesc);
805                 elmt = elmt->next;
806               }
807           }
808
809       elmt = pdump_opaque_data_list.first;
810       while (elmt)
811         {
812           if (pdump_align_table[elmt->size & 255] == align)
813             f (elmt, 0);
814           elmt = elmt->next;
815         }
816     }
817 }
818
819 static void
820 pdump_dump_from_root_struct_ptrs (void)
821 {
822   int i;
823   for (i = 0; i < Dynarr_length (pdump_root_struct_ptrs); i++)
824     {
825       EMACS_INT adr;
826       pdump_root_struct_ptr *info = Dynarr_atp (pdump_root_struct_ptrs, i);
827       write (pdump_fd, &info->ptraddress, sizeof (info->ptraddress));
828       adr = pdump_get_entry (*(info->ptraddress))->save_offset;
829       write (pdump_fd, &adr, sizeof (adr));
830     }
831 }
832
833 static void
834 pdump_dump_opaques (void)
835 {
836   int i;
837   for (i = 0; i < Dynarr_length (pdump_opaques); i++)
838     {
839       pdump_opaque *info = Dynarr_atp (pdump_opaques, i);
840       write (pdump_fd, info, sizeof (*info));
841       write (pdump_fd, info->varaddress, info->size);
842     }
843 }
844
845 static void
846 pdump_dump_rtables (void)
847 {
848   int i;
849   pdump_entry_list_elmt *elmt;
850   pdump_reloc_table rt;
851
852   for (i=0; i<lrecord_type_count; i++)
853     {
854       elmt = pdump_object_table[i].first;
855       if (!elmt)
856         continue;
857       rt.desc = lrecord_implementations_table[i]->description;
858       rt.count = pdump_object_table[i].count;
859       write (pdump_fd, &rt, sizeof (rt));
860       while (elmt)
861         {
862           EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
863           write (pdump_fd, &rdata, sizeof (rdata));
864           elmt = elmt->next;
865         }
866     }
867
868   rt.desc = 0;
869   rt.count = 0;
870   write (pdump_fd, &rt, sizeof (rt));
871
872   for (i=0; i<pdump_struct_table.count; i++)
873     {
874       elmt = pdump_struct_table.list[i].list.first;
875       rt.desc = pdump_struct_table.list[i].sdesc->description;
876       rt.count = pdump_struct_table.list[i].list.count;
877       write (pdump_fd, &rt, sizeof (rt));
878       while (elmt)
879         {
880           EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
881           int j;
882           for (j=0; j<elmt->count; j++)
883             {
884               write (pdump_fd, &rdata, sizeof (rdata));
885               rdata += elmt->size;
886             }
887           elmt = elmt->next;
888         }
889     }
890   rt.desc = 0;
891   rt.count = 0;
892   write (pdump_fd, &rt, sizeof (rt));
893 }
894
895 static void
896 pdump_dump_from_root_objects (void)
897 {
898   size_t count = Dynarr_length (pdump_root_objects) + Dynarr_length (pdump_weak_object_chains);
899   size_t i;
900
901   write (pdump_fd, &count, sizeof (count));
902
903   for (i=0; i<Dynarr_length (pdump_root_objects); i++)
904     {
905       Lisp_Object obj = * Dynarr_at (pdump_root_objects, i);
906       if (POINTER_TYPE_P (XTYPE (obj)))
907         obj = wrap_object ((void *) pdump_get_entry (XRECORD_LHEADER (obj))->save_offset);
908       write (pdump_fd, Dynarr_atp (pdump_root_objects, i), sizeof (Dynarr_atp (pdump_root_objects, i)));
909       write (pdump_fd, &obj, sizeof (obj));
910     }
911
912   for (i=0; i<Dynarr_length (pdump_weak_object_chains); i++)
913     {
914       Lisp_Object obj = * Dynarr_at (pdump_weak_object_chains, i);
915       pdump_entry_list_elmt *elmt;
916
917       for (;;)
918         {
919           const struct lrecord_description *desc;
920           int pos;
921           elmt = pdump_get_entry (XRECORD_LHEADER (obj));
922           if (elmt)
923             break;
924           desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
925           for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
926             assert (desc[pos].type != XD_END);
927
928           obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
929         }
930       obj = wrap_object ((void *) elmt->save_offset);
931
932       write (pdump_fd, Dynarr_atp (pdump_weak_object_chains, i), sizeof (Lisp_Object *));
933       write (pdump_fd, &obj, sizeof (obj));
934     }
935 }
936
937 void
938 pdump (void)
939 {
940   int i;
941   Lisp_Object t_console, t_device, t_frame;
942   int none;
943   pdump_header hd;
944
945   flush_all_buffer_local_cache ();
946
947   /* These appear in a DEFVAR_LISP, which does a staticpro() */
948   t_console = Vterminal_console; Vterminal_console = Qnil;
949   t_frame   = Vterminal_frame;   Vterminal_frame   = Qnil;
950   t_device  = Vterminal_device;  Vterminal_device  = Qnil;
951
952   dump_add_opaque (&lrecord_implementations_table,
953                    lrecord_type_count * sizeof (lrecord_implementations_table[0]));
954   dump_add_opaque (&lrecord_markers,
955                    lrecord_type_count * sizeof (lrecord_markers[0]));
956
957   pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
958
959   for (i=0; i<lrecord_type_count; i++)
960     {
961       pdump_object_table[i].first = 0;
962       pdump_object_table[i].align = 8;
963       pdump_object_table[i].count = 0;
964       pdump_alert_undump_object[i] = 0;
965     }
966   pdump_struct_table.count = 0;
967   pdump_struct_table.size = -1;
968
969   pdump_opaque_data_list.first = 0;
970   pdump_opaque_data_list.align = 8;
971   pdump_opaque_data_list.count = 0;
972   depth = 0;
973
974   for (i=0; i<Dynarr_length (pdump_root_objects); i++)
975     pdump_register_object (* Dynarr_at (pdump_root_objects, i));
976
977   none = 1;
978   for (i=0; i<lrecord_type_count; i++)
979     if (pdump_alert_undump_object[i])
980       {
981         if (none)
982           printf ("Undumpable types list :\n");
983         none = 0;
984         printf ("  - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
985       }
986   if (!none)
987     return;
988
989   for (i=0; i<Dynarr_length (pdump_root_struct_ptrs); i++)
990     {
991       pdump_root_struct_ptr info = Dynarr_at (pdump_root_struct_ptrs, i);
992       pdump_register_struct (*(info.ptraddress), info.desc, 1);
993     }
994
995   memcpy (hd.signature, PDUMP_SIGNATURE, PDUMP_SIGNATURE_LEN);
996   hd.id = dump_id;
997   hd.reloc_address = 0;
998   hd.nb_root_struct_ptrs = Dynarr_length (pdump_root_struct_ptrs);
999   hd.nb_opaques = Dynarr_length (pdump_opaques);
1000
1001   cur_offset = 256;
1002   max_size = 0;
1003
1004   pdump_scan_by_alignment (pdump_allocate_offset);
1005
1006   pdump_buf = xmalloc (max_size);
1007   /* Avoid use of the `open' macro.  We want the real function. */
1008 #undef open
1009   pdump_fd = open (EMACS_PROGNAME ".dmp",
1010                    O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
1011   hd.stab_offset = (cur_offset + 3) & ~3;
1012
1013   write (pdump_fd, &hd, sizeof (hd));
1014   lseek (pdump_fd, 256, SEEK_SET);
1015
1016   pdump_scan_by_alignment (pdump_dump_data);
1017
1018   lseek (pdump_fd, hd.stab_offset, SEEK_SET);
1019
1020   pdump_dump_from_root_struct_ptrs ();
1021   pdump_dump_opaques ();
1022   pdump_dump_rtables ();
1023   pdump_dump_from_root_objects ();
1024
1025   close (pdump_fd);
1026   free (pdump_buf);
1027
1028   free (pdump_hash);
1029
1030   Vterminal_console = t_console;
1031   Vterminal_frame   = t_frame;
1032   Vterminal_device  = t_device;
1033 }
1034
1035 static int
1036 pdump_load_check (void)
1037 {
1038   return (!memcmp (((pdump_header *)pdump_start)->signature,
1039                    PDUMP_SIGNATURE, PDUMP_SIGNATURE_LEN)
1040           && ((pdump_header *)pdump_start)->id == dump_id);
1041 }
1042
1043 static int
1044 pdump_load_finish (void)
1045 {
1046   int i;
1047   char *p;
1048   EMACS_INT delta;
1049   EMACS_INT count;
1050
1051   pdump_end = pdump_start + pdump_length;
1052
1053 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
1054
1055   delta = ((EMACS_INT)pdump_start) - ((pdump_header *)pdump_start)->reloc_address;
1056   p = pdump_start + ((pdump_header *)pdump_start)->stab_offset;
1057
1058   /* Put back the pdump_root_struct_ptrs */
1059   for (i=0; i<((pdump_header *)pdump_start)->nb_root_struct_ptrs; i++)
1060     {
1061       void **adr = PDUMP_READ (p, void **);
1062       *adr = (void *) (PDUMP_READ (p, char *) + delta);
1063     }
1064
1065   /* Put back the pdump_opaques */
1066   for (i=0; i<((pdump_header *)pdump_start)->nb_opaques; i++)
1067     {
1068       pdump_opaque info = PDUMP_READ (p, pdump_opaque);
1069       memcpy (info.varaddress, p, info.size);
1070       p += info.size;
1071     }
1072
1073   /* Do the relocations */
1074   pdump_rt_list = p;
1075   count = 2;
1076   for (;;)
1077     {
1078       pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
1079       if (rt.desc)
1080         {
1081           for (i=0; i < rt.count; i++)
1082             {
1083               char *adr = delta + *(char **)p;
1084               *(char **)p = adr;
1085               pdump_reloc_one (adr, delta, rt.desc);
1086               p += sizeof (char *);
1087             }
1088         } else
1089           if (!(--count))
1090             break;
1091     }
1092
1093   /* Put the pdump_root_objects variables in place */
1094   for (i = PDUMP_READ (p, size_t); i; i--)
1095     {
1096       Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
1097       Lisp_Object  obj = PDUMP_READ (p, Lisp_Object);
1098
1099       if (POINTER_TYPE_P (XTYPE (obj)))
1100         obj = wrap_object ((char *) XPNTR (obj) + delta);
1101
1102       *var = obj;
1103     }
1104
1105   /* Final cleanups */
1106   /*   reorganize hash tables */
1107   p = pdump_rt_list;
1108   for (;;)
1109     {
1110       pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
1111       if (!rt.desc)
1112         break;
1113       if (rt.desc == hash_table_description)
1114         {
1115           for (i=0; i < rt.count; i++)
1116             pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
1117           break;
1118         } else
1119           p += sizeof (Lisp_Object) * rt.count;
1120     }
1121
1122   return 1;
1123 }
1124
1125 #ifdef WIN32_NATIVE
1126 /* Free the mapped file if we decide we don't want it after all */
1127 static void
1128 pdump_file_unmap (void)
1129 {
1130   UnmapViewOfFile (pdump_start);
1131   CloseHandle (pdump_hFile);
1132   CloseHandle (pdump_hMap);
1133 }
1134
1135 static int
1136 pdump_file_get (const char *path)
1137 {
1138
1139   pdump_hFile = CreateFile (path,
1140                             GENERIC_READ + GENERIC_WRITE,  /* Required for copy on write */
1141                             0,                      /* Not shared */
1142                             NULL,                   /* Not inheritable */
1143                             OPEN_EXISTING,
1144                             FILE_ATTRIBUTE_NORMAL,
1145                             NULL);                  /* No template file */
1146   if (pdump_hFile == INVALID_HANDLE_VALUE)
1147     return 0;
1148
1149   pdump_length = GetFileSize (pdump_hFile, NULL);
1150   pdump_hMap = CreateFileMapping (pdump_hFile,
1151                                   NULL,             /* No security attributes */
1152                                   PAGE_WRITECOPY,   /* Copy on write */
1153                                   0,                /* Max size, high half */
1154                                   0,                /* Max size, low half */
1155                                   NULL);            /* Unnamed */
1156   if (pdump_hMap == INVALID_HANDLE_VALUE)
1157     return 0;
1158
1159   pdump_start = MapViewOfFile (pdump_hMap,
1160                                FILE_MAP_COPY, /* Copy on write */
1161                                0,             /* Start at zero */
1162                                0,
1163                                0);            /* Map all of it */
1164   pdump_free = pdump_file_unmap;
1165   return 1;
1166 }
1167
1168 /* pdump_resource_free is called (via the pdump_free pointer) to release
1169    any resources allocated by pdump_resource_get.  Since the Windows API
1170    specs specifically state that you don't need to (and shouldn't) free the
1171    resources allocated by FindResource, LoadResource, and LockResource this
1172    routine does nothing.  */
1173 static void
1174 pdump_resource_free (void)
1175 {
1176 }
1177
1178 static int
1179 pdump_resource_get (void)
1180 {
1181   HRSRC hRes;                   /* Handle to dump resource */
1182   HRSRC hResLoad;               /* Handle to loaded dump resource */
1183
1184   /* See Q126630 which describes how Windows NT and 95 trap writes to
1185      resource sections and duplicate the page to allow the write to proceed.
1186      It also describes how to make the resource section read/write (and hence
1187      private to each process).  Doing this avoids the exceptions and related
1188      overhead, but causes the resource section to be private to each process
1189      that is running XEmacs.  Since the resource section contains little
1190      other than the dumped data, which should be private to each process, we
1191      make the whole resource section read/write so we don't have to copy it. */
1192
1193   hRes = FindResource (NULL, MAKEINTRESOURCE(101), "DUMP");
1194   if (hRes == NULL)
1195     return 0;
1196
1197   /* Found it, use the data in the resource */
1198   hResLoad = LoadResource (NULL, hRes);
1199   if (hResLoad == NULL)
1200     return 0;
1201
1202   pdump_start = LockResource (hResLoad);
1203   if (pdump_start == NULL)
1204     return 0;
1205
1206   pdump_free = pdump_resource_free;
1207   pdump_length = SizeofResource (NULL, hRes);
1208   if (pdump_length <= sizeof (pdump_header))
1209     {
1210       pdump_start = 0;
1211       return 0;
1212     }
1213
1214   return 1;
1215 }
1216
1217 #else /* !WIN32_NATIVE */
1218
1219 static void *pdump_mallocadr;
1220
1221 static void
1222 pdump_file_free (void)
1223 {
1224   xfree (pdump_mallocadr);
1225 }
1226
1227 #ifdef HAVE_MMAP
1228 static void
1229 pdump_file_unmap (void)
1230 {
1231   munmap (pdump_start, pdump_length);
1232 }
1233 #endif
1234
1235 static int
1236 pdump_file_get (const char *path)
1237 {
1238   int fd = open (path, O_RDONLY | OPEN_BINARY);
1239   if (fd<0)
1240     return 0;
1241
1242   pdump_length = lseek (fd, 0, SEEK_END);
1243   if (pdump_length < sizeof (pdump_header))
1244     {
1245       close (fd);
1246       return 0;
1247     }
1248
1249   lseek (fd, 0, SEEK_SET);
1250
1251 #ifdef HAVE_MMAP
1252   pdump_start = (char *) mmap (0, pdump_length, PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
1253   if (pdump_start != (char *) MAP_FAILED)
1254     {
1255       pdump_free = pdump_file_unmap;
1256       close (fd);
1257       return 1;
1258     }
1259 #endif
1260
1261   pdump_mallocadr = xmalloc (pdump_length+255);
1262   pdump_free = pdump_file_free;
1263   pdump_start = (char *)((255 + (unsigned long)pdump_mallocadr) & ~255);
1264   read (fd, pdump_start, pdump_length);
1265
1266   close (fd);
1267   return 1;
1268 }
1269 #endif /* !WIN32_NATIVE */
1270
1271
1272 static int
1273 pdump_file_try (char *exe_path)
1274 {
1275   char *w;
1276
1277   w = exe_path + strlen (exe_path);
1278   do
1279     {
1280       sprintf (w, "-%s-%08x.dmp", EMACS_VERSION, dump_id);
1281       if (pdump_file_get (exe_path))
1282         {
1283           if (pdump_load_check ())
1284             return 1;
1285           pdump_free ();
1286         }
1287
1288       sprintf (w, "-%08x.dmp", dump_id);
1289       if (pdump_file_get (exe_path))
1290         {
1291           if (pdump_load_check ())
1292             return 1;
1293           pdump_free ();
1294         }
1295
1296       sprintf (w, ".dmp");
1297       if (pdump_file_get (exe_path))
1298         {
1299           if (pdump_load_check ())
1300             return 1;
1301           pdump_free ();
1302         }
1303
1304       do
1305         w--;
1306       while (w>exe_path && !IS_DIRECTORY_SEP (*w) && (*w != '-') && (*w != '.'));
1307     }
1308   while (w>exe_path && !IS_DIRECTORY_SEP (*w));
1309   return 0;
1310 }
1311
1312 int
1313 pdump_load (const char *argv0)
1314 {
1315   char exe_path[PATH_MAX];
1316 #ifdef WIN32_NATIVE
1317   GetModuleFileName (NULL, exe_path, PATH_MAX);
1318 #else /* !WIN32_NATIVE */
1319   char *w;
1320   const char *dir, *p;
1321
1322   dir = argv0;
1323   if (dir[0] == '-')
1324     {
1325       /* XEmacs as a login shell, oh goody! */
1326       dir = getenv ("SHELL");
1327     }
1328
1329   p = dir + strlen (dir);
1330   while (p != dir && !IS_ANY_SEP (p[-1])) p--;
1331
1332   if (p != dir)
1333     {
1334       /* invocation-name includes a directory component -- presumably it
1335          is relative to cwd, not $PATH */
1336       strcpy (exe_path, dir);
1337     }
1338   else
1339     {
1340       const char *path = getenv ("PATH");
1341       const char *name = p;
1342       for (;;)
1343         {
1344           p = path;
1345           while (*p && *p != SEPCHAR)
1346             p++;
1347           if (p == path)
1348             {
1349               exe_path[0] = '.';
1350               w = exe_path + 1;
1351             }
1352           else
1353             {
1354               memcpy (exe_path, path, p - path);
1355               w = exe_path + (p - path);
1356             }
1357           if (!IS_DIRECTORY_SEP (w[-1]))
1358             {
1359               *w++ = '/';
1360             }
1361           strcpy (w, name);
1362
1363           /* ### #$%$#^$^@%$^#%@$ ! */
1364 #ifdef access
1365 #undef access
1366 #endif
1367
1368           if (!access (exe_path, X_OK))
1369             break;
1370           if (!*p)
1371             {
1372               /* Oh well, let's have some kind of default */
1373               sprintf (exe_path, "./%s", name);
1374               break;
1375             }
1376           path = p+1;
1377         }
1378     }
1379 #endif /* WIN32_NATIVE */
1380
1381   if (pdump_file_try (exe_path))
1382     {
1383       pdump_load_finish ();
1384       return 1;
1385     }
1386
1387 #ifdef WIN32_NATIVE
1388   if (pdump_resource_get ())
1389     {
1390       if (pdump_load_check ())
1391         {
1392           pdump_load_finish ();
1393           return 1;
1394         }
1395       pdump_free ();
1396     }
1397 #endif
1398
1399   return 0;
1400 }