--- /dev/null
- - Make sure global finalizer list makes it across the dump.
-
+#include <config.h>
+
+#include <errno.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdarg.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <sys/param.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <unistd.h>
+
+#include "blockinput.h"
+#include "buffer.h"
+#include "charset.h"
+#include "coding.h"
+#include "fingerprint.h"
+#include "frame.h"
+#include "getpagesize.h"
+#include "intervals.h"
+#include "lisp.h"
+#include "pdumper.h"
+#include "window.h"
+#include "systime.h"
++#include "thread.h"
+
+#include "dmpstruct.h"
+
+/*
+ TODO:
+
- # define CHECK_STRUCTS 1
+ - Two-pass dumping: first assemble object list, then write all.
++ This way, we can perform arbitrary reordering.
+
+ - Don't emit relocations that happen to set Emacs memory locations
+ to values they will already have.
+
+ - Check at dump time that relocations are properly aligned.
+
+ - Nullify frame_and_buffer_state.
+
+ - Preferred base address for relocation-free non-PIC startup.
+
+ - Compressed dump support.
+
+*/
+
+#ifdef HAVE_PDUMPER
+
+/* CHECK_STRUCTS being true makes the build break if we notice
+ changes to the source defining certain Lisp structures we dump. If
+ you change one of these structures, check that the pdumper code is
+ still valid and update the hash from the dmpstruct.h generated by
+ your new code. */
+#ifndef CHECK_STRUCTS
- /* Copy raw bytes from the dump into Emacs. */
++# define CHECK_STRUCTS 0 // XXX
+#endif
+
+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)
+# pragma GCC diagnostic error "-Wconversion"
+# pragma GCC diagnostic error "-Wshadow"
+# define ALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic push") \
+ _Pragma ("GCC diagnostic ignored \"-Wconversion\"")
+ _Pragma ("GCC diagnostic ignored \"-Wsign-conversion\"")
+# define DISALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic pop")
+#else
+# define ALLOW_IMPLICIT_CONVERSION ((void)0)
+# define DISALLOW_IMPLICIT_CONVERSION ((void)0)
+#endif
+
+#define VM_POSIX 1
+#define VM_MS_WINDOWS 2
+
+#if defined (HAVE_MMAP) && defined (MAP_FIXED)
+# define VM_SUPPORTED VM_POSIX
+# if !defined (MAP_POPULATE) && defined (MAP_PREFAULT_READ)
+# define MAP_POPULATE MAP_PREFAULT_READ
+# elif !defined (MAP_POPULATE)
+# define MAP_POPULATE 0
+# endif
+#elif defined (WINDOWSNT)
+ /* Use a float infinity, to avoid compiler warnings in comparing vs
+ candidates' score. */
+# undef INFINITY
+# define INFINITY __builtin_inff ()
+# include <windows.h>
+# define VM_SUPPORTED VM_MS_WINDOWS
+#else
+# define VM_SUPPORTED 0
+#endif
+
+#define DANGEROUS 0
+
+/* PDUMPER_CHECK_REHASHING being true causes the portable dumper to
+ check, for each hash table it dumps, that the hash table means the
+ same thing after rehashing. */
+#ifndef PDUMPER_CHECK_REHASHING
+# if ENABLE_CHECKING
+# define PDUMPER_CHECK_REHASHING 1
+# else
+# define PDUMPER_CHECK_REHASHING 0
+# endif
+#endif
+
+/* We require an architecture in which all pointers are the same size
+ and have the same layout, where pointers are either 32 or 64 bits
+ long, and where bytes have eight bits --- that is, a
+ general-purpose computer made after 1990. */
+verify (sizeof (ptrdiff_t) == sizeof (void*));
+verify (sizeof (intptr_t) == sizeof (ptrdiff_t));
+verify (sizeof (void (*)(void)) == sizeof (void*));
+verify (sizeof (ptrdiff_t) <= sizeof (Lisp_Object));
+verify (sizeof (ptrdiff_t) <= sizeof (EMACS_INT));
+verify (sizeof (off_t) == sizeof (int32_t) ||
+ sizeof (off_t) == sizeof (int64_t));
+verify (CHAR_BIT == 8);
+
+#define DIVIDE_ROUND_UP(x, y) (((x) + (y) - 1) / (y))
+
+static const char dump_magic[16] = {
+ 'D', 'U', 'M', 'P', 'E', 'D',
+ 'G', 'N', 'U',
+ 'E', 'M', 'A', 'C', 'S'
+};
+
+static pdumper_hook dump_hooks[24];
+static int nr_dump_hooks = 0;
+
+static struct
+{
+ void *mem;
+ int sz;
+} remembered_data[32];
+static int nr_remembered_data = 0;
+
+typedef int32_t dump_off;
+#define DUMP_OFF_T_MIN INT32_MIN
+#define DUMP_OFF_T_MAX INT32_MAX
+
+__attribute__((format (printf,1,2)))
+static void
+dump_trace (const char *fmt, ...)
+{
+ if (0)
+ {
+ va_list args;
+ va_start (args, fmt);
+ vfprintf (stderr, fmt, args);
+ va_end (args);
+ }
+}
+
+static ssize_t dump_read_all (int fd, void *buf, size_t bytes_to_read);
+
+static dump_off
+ptrdiff_t_to_dump_off (ptrdiff_t value)
+{
+ eassert (DUMP_OFF_T_MIN <= value);
+ eassert (value <= DUMP_OFF_T_MAX);
+ return (dump_off) value;
+}
+
+/* Worst-case allocation granularity on any system that might load
+ this dump. */
+static int
+dump_get_page_size (void)
+{
+#if defined (WINDOWSNT) || defined (CYGWIN)
+ return 64 * 1024; /* Worst-case allocation granularity. */
+#else
+ return getpagesize ();
+#endif
+}
+
+#define dump_offsetof(type, member) \
+ (ptrdiff_t_to_dump_off (offsetof (type, member)))
+
+enum dump_reloc_type
+ {
+ /* dump_ptr = dump_ptr + emacs_basis() */
+ RELOC_DUMP_TO_EMACS_PTR_RAW,
+ /* dump_ptr = dump_ptr + dump_base */
+ RELOC_DUMP_TO_DUMP_PTR_RAW,
+ /* dump_lv = make_lisp_ptr (
+ dump_lv + dump_base,
+ type - RELOC_DUMP_TO_DUMP_LV)
+ (Special case for symbols: make_lisp_symbol)
+ Must be second-last. */
+ RELOC_DUMP_TO_DUMP_LV,
+ /* dump_lv = make_lisp_ptr (
+ dump_lv + emacs_basis(),
+ type - RELOC_DUMP_TO_DUMP_LV)
+ (Special case for symbols: make_lisp_symbol.)
+ Must be last. */
+ RELOC_DUMP_TO_EMACS_LV = RELOC_DUMP_TO_DUMP_LV + 8,
+ };
+
+enum emacs_reloc_type
+ {
- /* Set an aligned pointer-sized object in Emacs to a dump offset. */
++ /* Copy raw bytes from the dump into Emacs. The length field in
++ the emacs_reloc is the number of bytes to copy. */
+ RELOC_EMACS_COPY_FROM_DUMP,
+ /* Set a piece of memory in Emacs to a value we store directly in
+ this relocation. The length field contains the number of bytes
+ we actually copy into Emacs. */
+ RELOC_EMACS_IMMEDIATE,
- something also in Emacs. */
++ /* Set an aligned pointer-sized object in Emacs to a pointer into
++ the loaded dump at the given offset. The length field is
++ always the machine word size. */
+ RELOC_EMACS_DUMP_PTR_RAW,
+ /* Set an aligned pointer-sized object in Emacs to point to
- dump. Must be last. */
++ something also in Emacs. The length field is always
++ the machine word size. */
+ RELOC_EMACS_EMACS_PTR_RAW,
+ /* Set an aligned Lisp_Object in Emacs to point to a value in the
- int8_t immediate_i8;
- int16_t immediate_i16;
- int32_t immediate_i32;
++ dump. The length field is the _tag type_ of the Lisp_Object,
++ not a byte count! */
+ RELOC_EMACS_DUMP_LV,
++ /* Set an aligned Lisp_Object in Emacs to point to a value in the
++ Emacs image. The length field is the _tag type_ of the
++ Lisp_Object, not a byte count! */
++ RELOC_EMACS_EMACS_LV,
+ };
+
+#define EMACS_RELOC_TYPE_BITS 3
+#define EMACS_RELOC_LENGTH_BITS \
+ (sizeof (dump_off) * CHAR_BIT - EMACS_RELOC_TYPE_BITS)
+
+struct emacs_reloc
+{
+ ENUM_BF (emacs_reloc_type) type : EMACS_RELOC_TYPE_BITS;
+ dump_off length : EMACS_RELOC_LENGTH_BITS;
+ dump_off emacs_offset;
+ union
+ {
+ dump_off dump_offset;
+ dump_off emacs_offset2;
+ intmax_t immediate;
- indicator (as opposed to a special sentinel) so we can efficiency
+ } u;
+};
+
+/* Set the type of an Emacs relocation.
+
+ Also make sure that the type fits in the bitfield. */
+static void
+emacs_reloc_set_type (struct emacs_reloc *reloc,
+ enum emacs_reloc_type type)
+{
+ reloc->type = type;
+ eassert (reloc->type == type);
+}
+
+struct dump_table_locator
+{
+ /* Offset in dump, in bytes, of the first entry in the dump
+ table. */
+ dump_off offset;
+ /* Number of entries in the dump table. We need an explicit end
- bool_bf dump_object_starts : 1;
++ indicator (as opposed to a special sentinel) so we can efficiently
+ binary search over the relocation entries. */
+ dump_off nr_entries;
+};
+
+#define DUMP_RELOC_TYPE_BITS 4
+#define DUMP_RELOC_ALIGNMENT_BITS 2
+#define DUMP_RELOC_OFFSET_BITS \
+ (sizeof (dump_off) * CHAR_BIT - DUMP_RELOC_TYPE_BITS)
+
+struct dump_reloc
+{
+ uint32_t raw_offset : DUMP_RELOC_OFFSET_BITS;
+ ENUM_BF (dump_reloc_type) type : DUMP_RELOC_TYPE_BITS;
+};
++verify (sizeof (struct dump_reloc) == sizeof (int32_t));
+
+/* Set the type of a dump relocation.
+
+ Also assert that the type fits in the bitfield. */
+static void
+dump_reloc_set_type (struct dump_reloc *reloc, enum dump_reloc_type type)
+{
+ reloc->type = type;
+ eassert (reloc->type == type);
+}
+
+static dump_off
+dump_reloc_get_offset (struct dump_reloc reloc)
+{
+ return reloc.raw_offset << DUMP_RELOC_ALIGNMENT_BITS;
+}
+
+static void
+dump_reloc_set_offset (struct dump_reloc *reloc, dump_off offset)
+{
+ eassert (offset >= 0);
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc->raw_offset = offset >> DUMP_RELOC_ALIGNMENT_BITS;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (dump_reloc_get_offset (*reloc) != offset)
+ error ("dump relocation out of range");
+}
+
+static void dump_fingerprint (const char* label, const uint8_t* xfingerprint) {
+ fprintf (stderr, "%s: ", label);
+ for (int i = 0; i <32; ++i) {
+ fprintf (stderr, "%02x", (unsigned) xfingerprint[i]);
+ }
+ fprintf (stderr, "\n");
+}
+
+/* Format of an Emacs portable dump file. All offsets are relative to
+ the beginning of the file. An Emacs portable dump file is coupled
+ to exactly the Emacs binary that produced it, so details of
+ alignment and endianness are unimportant.
+
+ An Emacs dump file contains the contents of the Lisp heap.
+ On startup, Emacs can start faster by mapping a dump file into
+ memory and using the objects contained inside it instead of
+ performing initialization from scratch.
+
+ The dump file can be loaded at arbitrary locations in memory, so it
+ includes a table of relocations that let Emacs adjust the pointers
+ embedded in the dump file to account for the location where it was
+ actually loaded.
+
+ Dump files can contain pointers to other objects in the dump file
+ or to parts of the Emacs binary. */
+struct dump_header
+{
+ /* File type magic. */
+ char magic[sizeof (dump_magic)];
+
+ /* Associated Emacs binary. */
+ uint8_t fingerprint[32];
+
+ /* Relocation table for the dump file; each entry is a
+ struct dump_reloc. */
+ struct dump_table_locator dump_relocs;
+
+ /* "Relocation" table we abuse to hold information about the
+ location and type of each lisp object in the dump. We need for
+ pdumper_object_type and ultimately for conservative GC
+ correctness. */
+ struct dump_table_locator object_starts;
+
+ /* Relocation table for Emacs; each entry is a struct
+ emacs_reloc. */
+ struct dump_table_locator emacs_relocs;
+
+ /* Start of sub-region of hot region that we can discard after load
+ completes. The discardable region ends at cold_start.
+
+ This region contains objects that we copy into the Emacs image at
+ dump-load time. */
+ dump_off discardable_start;
+
+ /* Start of the region that does not require relocations and that we
+ expect never to be modified. This region can be memory-mapped
+ directly from the backing dump file with the reasonable
+ expectation of taking few copy-on-write faults.
+
+ For correctness, however, this region must be modifible, since in
+ rare cases it is possible to see modifications to these bytes.
+ For example, this region contains string data, and it's
+ technically possible for someone to ASET a string character
+ (although nobody tends to do that).
+
+ The start of the cold region is always aligned on a page
+ boundary. */
+ dump_off cold_start;
+};
+
+/* Double-ended singly linked list. */
+struct dump_tailq
+{
+ Lisp_Object head;
+ Lisp_Object tail;
+ intptr_t length;
+};
+
+/* Queue of objects to dump. */
+struct dump_queue
+{
+ /* Objects with no link weights at all. Kept in dump order. */
+ struct dump_tailq zero_weight_objects;
+ /* Objects with simple link weight: just one entry of type
+ WEIGHT_NORMAL. Score in this special case is non-decreasing as
+ position increases, so we can avoid the need to rescan a big list
+ for each object by storing these objects in order. */
+ struct dump_tailq one_weight_normal_objects;
+ /* Likewise, for objects with one WEIGHT_STRONG weight. */
+ struct dump_tailq one_weight_strong_objects;
+ /* List of objects with complex link weights --- i.e., not one of
+ the above cases. Order is irrelevant, since we scan the whole
+ list every time. Relatively few objects end up here. */
+ struct dump_tailq fancy_weight_objects;
+ /* Hash table of link weights: maps an object to a list of zero or
+ more (BASIS . WEIGHT) pairs. As a special case, an object with
+ zero weight is marked by Qt in the hash table --- this way, we
+ can distinguish objects we've seen but that have no weight from
+ ones that we haven't seen at all. */
+ Lisp_Object link_weights;
+ /* Hash table mapping object to a sequence number --- used to
+ resolve ties. */
+ Lisp_Object sequence_numbers;
+ dump_off next_sequence_number;
+};
+
+enum cold_op
+ {
+ COLD_OP_OBJECT,
+ COLD_OP_STRING,
+ COLD_OP_CHARSET,
+ COLD_OP_BUFFER,
+ };
+
+/* This structure controls what operations we perform inside
+ dump_object. */
+struct dump_flags
+{
+ /* Actually write object contents to the dump. Without this flag
+ set, we still scan objects and enqueue pointed-to objects; making
+ this flag false is useful when we want to process an object's
+ referents normally, but dump an object itself separately,
+ later. */
+ bool_bf dump_object_contents : 1;
+ /* Record object starts. We turn this flag off when writing to the
+ discardable section so that we don't trick conservative GC into
+ thinking we have objects there. Ignored (we never record object
+ starts) if dump_object_contents is false. */
- at all). All values must be greater than or equal to zero. */
- enum dump_object_special_offset {
- DUMP_OBJECT_DEFERRED = -2,
- DUMP_OBJECT_ON_NORMAL_QUEUE = -1,
- DUMP_OBJECT_NOT_SEEN = 0,
- };
++ bool_bf record_object_starts : 1;
+ /* Pack objects tighter than GC memory alignment would normally
+ require. Useful for objects copied into the Emacs image instead
+ of used directly from the loaded dump.
+
+ XXX: actually use
+
+ */
+ bool_bf pack_objects : 1;
+ /* Sometimes we dump objects that we've already scanned for outbound
+ references to other objects. These objects should not cause new
+ objects to enter the object dumping queue. This flag causes Emacs
+ to assert that no new objects are enqueued while dumping. */
+ bool_bf assert_already_seen : 1;
+ /* Punt on unstable hash tables: defer them to ctx->deferred_hash_tables. */
+ bool_bf defer_hash_tables : 1;
+ /* Punt on symbols: defer them to ctx->deferred_symbols. */
+ bool_bf defer_symbols : 1;
++ /* Punt on cold objects: defer them to ctx->cold_queue. */
++ bool_bf defer_cold_objects : 1;
++ /* Punt on copied objects: defer them to ctx->copied_queue. */
++ bool_bf defer_copied_objects : 1;
+};
+
+/* Information we use while we dump. Note that we're not the garbage
+ collector and can operate under looser constraints: specifically,
+ we allocate memory during the dumping process. */
+struct dump_context
+{
+ /* Header we'll write to the dump file when done. */
+ struct dump_header header;
+
+ Lisp_Object old_purify_flag;
+ Lisp_Object old_post_gc_hook;
+
+#ifdef REL_ALLOC
+ bool blocked_ralloc;
+#endif
+
+ /* File descriptor for dumpfile; < 0 if closed. */
+ int fd;
+ /* Name of dump file --- used for error reporting. */
+ Lisp_Object dump_filename;
+ /* Current offset in dump file. */
+ dump_off offset;
+
+ /* Starting offset of current object. */
+ dump_off obj_offset;
+
+ /* Flags currently in effect for dumping. */
+ struct dump_flags flags;
+
+ dump_off end_heap;
+
+ /* Hash mapping objects we've already dumped to their offsets. */
+ Lisp_Object objects_dumped;
+
+ /* Hash mapping objects to where we got them. Used for debugging. */
+ Lisp_Object referrers;
+ Lisp_Object current_referrer;
+ bool have_current_referrer;
+
+ /* Queue of objects to dump. */
+ struct dump_queue dump_queue;
+
+ /* Deferred object lists. */
+ Lisp_Object deferred_hash_tables;
+ Lisp_Object deferred_symbols;
+
+ /* Fixups in the dump file. */
+ Lisp_Object fixups;
++
++ /* Hash table of staticpro values: avoids double relocations. */
++ Lisp_Object staticpro_table;
++
+ /* Hash table mapping symbols to their pre-copy-queue fwd or blv
+ structures (which we dump immediately before the start of the
+ discardable section). */
+ Lisp_Object symbol_aux;
+ /* Queue of copied objects for special treatment. */
+ Lisp_Object copied_queue;
+ /* Queue of cold objects to dump. */
+ Lisp_Object cold_queue;
+
+ /* Relocations in the dump. */
+ Lisp_Object dump_relocs;
++
+ /* Object starts. */
+ Lisp_Object object_starts;
++
+ /* Relocations in Emacs. */
+ Lisp_Object emacs_relocs;
+
+ unsigned number_hot_relocations;
+ unsigned number_discardable_relocations;
+};
+
+/* These special values for use as offsets in dump_remember_object and
+ dump_recall_object indicate that the corresponding object isn't in
+ the dump yet (and so it has no valid offset), but that it's on one
+ of our to-be-dumped-later object queues (or that we haven't seen it
- static void
++ at all). All values must be non-positive, since positive values
++ are physical dump offsets. */
++enum dump_object_special_offset
++ {
++ DUMP_OBJECT_IS_RUNTIME_MAGIC = -6,
++ DUMP_OBJECT_ON_COPIED_QUEUE = -5,
++ DUMP_OBJECT_ON_HASH_TABLE_QUEUE = -4,
++ DUMP_OBJECT_ON_SYMBOL_QUEUE = -3,
++ DUMP_OBJECT_ON_COLD_QUEUE = -2,
++ DUMP_OBJECT_ON_NORMAL_QUEUE = -1,
++ DUMP_OBJECT_NOT_SEEN = 0,
++ };
+
+/* Weights for score scores for object non-locality. */
+enum link_weight_enum
+ {
+ WEIGHT_NONE_VALUE = 0,
+ WEIGHT_NORMAL_VALUE = 1000,
+ WEIGHT_STRONG_VALUE = 1200,
+ };
+
+struct link_weight
+{
++ /* Wrapped in a struct to break unwanted implicit conversion. */
+ enum link_weight_enum value;
+};
+
+#define LINK_WEIGHT_LITERAL(x) ((struct link_weight){.value=(x)})
+#define WEIGHT_NONE LINK_WEIGHT_LITERAL (WEIGHT_NONE_VALUE)
+#define WEIGHT_NORMAL LINK_WEIGHT_LITERAL (WEIGHT_NORMAL_VALUE)
+#define WEIGHT_STRONG LINK_WEIGHT_LITERAL (WEIGHT_STRONG_VALUE)
+
+\f
+/* Dump file creation */
+
+static dump_off dump_object (struct dump_context *ctx, Lisp_Object object);
+static dump_off dump_object_for_offset (
+ struct dump_context *ctx, Lisp_Object object);
+
- /* TODO: assert that emacs_ptr is actually in emacs */
++/* Like the Lisp function `push'. Return NEWELT. */
++static Lisp_Object
+dump_push (Lisp_Object *where, Lisp_Object newelt)
+{
+ *where = Fcons (newelt, *where);
++ return newelt;
+}
+
++/* Like the Lisp function `pop'. */
+static Lisp_Object
+dump_pop (Lisp_Object *where)
+{
+ Lisp_Object ret = XCAR (*where);
+ *where = XCDR (*where);
+ return ret;
+}
+
+static bool
+dump_tracking_referrers_p (struct dump_context *ctx)
+{
+ return !NILP (ctx->referrers);
+}
+
+static void
+dump_set_have_current_referrer (struct dump_context *ctx, bool have)
+{
+#ifdef ENABLE_CHECKING
+ ctx->have_current_referrer = have;
+#endif
+}
+
+/* Remember the reason objects are enqueued.
+
+ Until DUMP_CLEAR_REFERRER is called, any objects enqueued are being
+ enqueued because OBJECT refers to them. It is not legal to enqueue
+ objects without a referer set. We check this constraint
+ at runtime.
+
+ It is illegal to call DUMP_SET_REFERRER twice without an
+ intervening call to DUMP_CLEAR_REFERRER.
+
+ Define as a macro so we can avoid evaluating OBJECT
+ if we dont want referrer tracking. */
+#define DUMP_SET_REFERRER(ctx, object) \
+ do \
+ { \
+ struct dump_context *_ctx = (ctx); \
+ eassert (!_ctx->have_current_referrer); \
+ dump_set_have_current_referrer (_ctx, true); \
+ if (dump_tracking_referrers_p (_ctx)) \
+ ctx->current_referrer = (object); \
+ } \
+ while (0)
+
+/* Unset the referer that DUMP_SET_REFERRER set.
+
+ Named with upper-case letters for symmetry with
+ DUMP_SET_REFERRER. */
+static void
+DUMP_CLEAR_REFERRER (struct dump_context *ctx)
+{
+ eassert (ctx->have_current_referrer);
+ dump_set_have_current_referrer (ctx, false);
+ if (dump_tracking_referrers_p (ctx))
+ ctx->current_referrer = Qnil;
+}
+
+static Lisp_Object
+dump_ptr_referrer (const char *label, void *address)
+{
+ char buf[128];
+ buf[0] = '\0';
+ sprintf (buf, "%s @ %p", label, address);
+ return build_string (buf);
+}
+
+static void
+print_paths_to_root (struct dump_context *ctx, Lisp_Object object);
+
+static void dump_remember_cold_op (struct dump_context *ctx,
+ enum cold_op op,
+ Lisp_Object arg);
+
+_Noreturn
+static void
+error_unsupported_dump_object (struct dump_context *ctx,
+ Lisp_Object object,
+ const char* msg)
+{
+ if (dump_tracking_referrers_p (ctx))
+ print_paths_to_root (ctx, object);
+ error ("unsupported object type in dump: %s", msg);
+}
+
+static uintptr_t
+emacs_basis (void)
+{
+ return (uintptr_t) &Vpurify_flag;
+}
+
++static void *
++emacs_ptr (const ptrdiff_t offset)
++{
++ // TODO: assert somehow that OFFSET is actually inside Emacs
++ return (void *) (emacs_basis () + offset);
++}
++
+static dump_off
+emacs_offset (const void *emacs_ptr)
+{
- invocations --- i.e., is invariant across a dump. */
++ /* TODO: assert that EMACS_PTR is actually in emacs */
+ eassert (emacs_ptr != NULL);
+ intptr_t emacs_ptr_value = (intptr_t) emacs_ptr;
+ ptrdiff_t emacs_ptr_relative = emacs_ptr_value - (intptr_t) emacs_basis ();
+ return ptrdiff_t_to_dump_off (emacs_ptr_relative);
+}
+
+/* Return whether OBJECT is a symbol the storage of which is built
+ into Emacs (and so is invariant across ASLR). */
+static bool
+dump_builtin_symbol_p (Lisp_Object object)
+{
+ if (!SYMBOLP (object))
+ return false;
+ char* bp = (char*) lispsym;
+ struct Lisp_Symbol *s = XSYMBOL (object);
+ char* sp = (char*) s;
+ return bp <= sp && sp < bp + sizeof (lispsym);
+}
+
+/* Return whether OBJECT has the same bit pattern in all Emacs
- type result; \
++ invocations --- i.e., is invariant across a dump. Note that some
++ self-representing objects still need to be dumped!
++*/
+static bool
+dump_object_self_representing_p (Lisp_Object object)
+{
+ bool result;
+ ALLOW_IMPLICIT_CONVERSION;
+ result = INTEGERP (object) || dump_builtin_symbol_p (object);
+ DISALLOW_IMPLICIT_CONVERSION;
+ return result;
+}
+
+#define DEFINE_FROMLISP_FUNC(fn, type) \
+ static type \
+ fn (Lisp_Object value) \
+ { \
- CONS_TO_INTEGER (value, type, result); \
+ ALLOW_IMPLICIT_CONVERSION; \
- return result; \
++ if (FIXNUMP (value)) \
++ return XFIXNUM (value); \
++ eassert (BIGNUMP (value)); \
++ return TYPE_SIGNED (type) \
++ ? bignum_to_intmax (value) \
++ : bignum_to_uintmax (value); \
+ DISALLOW_IMPLICIT_CONVERSION; \
- return INTEGER_TO_CONS (value); \
+ }
+
+#define DEFINE_TOLISP_FUNC(fn, type) \
+ static Lisp_Object \
+ fn (type value) \
+ { \
- /* Return offset at which OBJECT has been dumped, or 0 if OBJECT has
- not been dumped. */
++ return INT_TO_INTEGER (value); \
+ }
+
+DEFINE_FROMLISP_FUNC (intmax_t_from_lisp, intmax_t);
+DEFINE_TOLISP_FUNC (intmax_t_to_lisp, intmax_t);
+DEFINE_FROMLISP_FUNC (dump_off_from_lisp, dump_off);
+DEFINE_TOLISP_FUNC (dump_off_to_lisp, dump_off);
+
+static void
+dump_write (struct dump_context *ctx, const void *buf, dump_off nbyte)
+{
+ eassert (nbyte == 0 || buf != NULL);
+ eassert (ctx->obj_offset == 0);
+ eassert (ctx->flags.dump_object_contents);
+ if (emacs_write (ctx->fd, buf, nbyte) < nbyte)
+ report_file_error ("Could not write to dump file", ctx->dump_filename);
+ ctx->offset += nbyte;
+}
+
+static Lisp_Object
+make_eq_hash_table (void)
+{
+ return CALLN (Fmake_hash_table, QCtest, Qeq);
+}
+
+static void
+dump_tailq_init (struct dump_tailq *tailq)
+{
+ tailq->head = tailq->tail = Qnil;
+ tailq->length = 0;
+}
+
+static intptr_t
+dump_tailq_length (const struct dump_tailq *tailq)
+{
+ return tailq->length;
+}
+
+__attribute__((unused))
+static void
+dump_tailq_prepend (struct dump_tailq *tailq, Lisp_Object value)
+{
+ Lisp_Object link = Fcons (value, tailq->head);
+ tailq->head = link;
+ if (NILP (tailq->tail))
+ tailq->tail = link;
+ tailq->length += 1;
+}
+
+__attribute__((unused))
+static void
+dump_tailq_append (struct dump_tailq *tailq, Lisp_Object value)
+{
+ Lisp_Object link = Fcons (value, Qnil);
+ if (NILP (tailq->head))
+ {
+ eassert (NILP (tailq->tail));
+ tailq->head = tailq->tail = link;
+ }
+ else
+ {
+ eassert (!NILP (tailq->tail));
+ XSETCDR (tailq->tail, link);
+ tailq->tail = link;
+ }
+ tailq->length += 1;
+}
+
+static bool
+dump_tailq_empty_p (struct dump_tailq *tailq)
+{
+ return NILP (tailq->head);
+}
+
+static Lisp_Object
+dump_tailq_peek (struct dump_tailq *tailq)
+{
+ eassert (!dump_tailq_empty_p (tailq));
+ return XCAR (tailq->head);
+}
+
+static Lisp_Object
+dump_tailq_pop (struct dump_tailq *tailq)
+{
+ eassert (!dump_tailq_empty_p (tailq));
+ eassert (tailq->length > 0);
+ tailq->length -= 1;
+ Lisp_Object value = XCAR (tailq->head);
+ tailq->head = XCDR (tailq->head);
+ if (NILP (tailq->head))
+ tailq->tail = Qnil;
+ return value;
+}
+
+static void
+dump_seek (struct dump_context *ctx, dump_off offset)
+{
+ eassert (ctx->obj_offset == 0);
+ if (lseek (ctx->fd, offset, SEEK_SET) < 0)
+ report_file_error ("Setting file position",
+ ctx->dump_filename);
+ ctx->offset = offset;
+}
+
+static void
+dump_write_zero (struct dump_context *ctx, dump_off nbytes)
+{
+ while (nbytes > 0)
+ {
+ uintmax_t zero = 0;
+ dump_off to_write = sizeof (zero);
+ if (to_write > nbytes)
+ to_write = nbytes;
+ dump_write (ctx, &zero, to_write);
+ nbytes -= to_write;
+ }
+}
+
+static void
+dump_align_output (struct dump_context *ctx, int alignment)
+{
+ if (ctx->offset % alignment != 0)
+ dump_write_zero (ctx, alignment - (ctx->offset % alignment));
+}
+
+static dump_off
+dump_object_start (struct dump_context *ctx,
+ int alignment,
+ void *out,
+ dump_off outsz)
+{
++ // XXX: force alignment to natural alignment if GCALIGNMENT is less
++
+ /* We dump only one object at a time, so obj_offset should be
+ invalid. */
+ eassert (ctx->obj_offset == 0);
+ if (ctx->flags.pack_objects)
+ alignment = 1;
+ if (ctx->flags.dump_object_contents)
+ dump_align_output (ctx, alignment);
+ ctx->obj_offset = ctx->offset;
+ memset (out, 0, outsz);
+ return ctx->offset;
+}
+
+static dump_off
+dump_object_finish (struct dump_context *ctx,
+ const void *out,
+ dump_off sz)
+{
+ dump_off offset = ctx->obj_offset;
+ eassert (offset > 0);
+ eassert (offset == ctx->offset); /* No intervening writes. */
+ ctx->obj_offset = 0;
+ if (ctx->flags.dump_object_contents)
+ dump_write (ctx, out, sz);
+ return offset;
+}
+
- return dump_off_from_lisp (Fgethash (object, dumped, make_number (0)));
++/* Return offset at which OBJECT has been dumped, or one of the dump_object_special_offset
++ negative values, or DUMP_OBJECT_NOT_SEEN. */
+static dump_off
+dump_recall_object (struct dump_context *ctx, Lisp_Object object)
+{
+ Lisp_Object dumped = ctx->objects_dumped;
- make_number (0));
++ return dump_off_from_lisp (Fgethash (object, dumped,
++ make_fixnum (DUMP_OBJECT_NOT_SEEN)));
+}
+
+static void
+dump_remember_object (struct dump_context *ctx,
+ Lisp_Object object,
+ dump_off offset)
+{
+ Fputhash (object,
+ dump_off_to_lisp (offset),
+ ctx->objects_dumped);
+}
+
+static void
+dump_note_reachable (struct dump_context *ctx, Lisp_Object object)
+{
+ eassert (ctx->have_current_referrer);
+ if (!dump_tracking_referrers_p (ctx))
+ return;
+ Lisp_Object referrer = ctx->current_referrer;
+ Lisp_Object obj_referrers = Fgethash (object, ctx->referrers, Qnil);
+ if (NILP (Fmemq (referrer, obj_referrers)))
+ Fputhash (object, Fcons (referrer, obj_referrers), ctx->referrers);
+}
+
+/* If this object lives in the Emacs image and not on the heap, return
+ a pointer to the object data. Otherwise, return NULL. */
+static void*
+dump_object_emacs_ptr (Lisp_Object lv)
+{
+ if (SUBRP (lv))
+ return XSUBR (lv);
+ if (dump_builtin_symbol_p (lv))
+ return XSYMBOL (lv);
++ if (XTYPE (lv) == Lisp_Vectorlike &&
++ PSEUDOVECTOR_TYPEP (&XVECTOR (lv)->header, PVEC_THREAD) &&
++ main_thread_p (XTHREAD (lv)))
++ return XTHREAD (lv);
+ return NULL;
+}
+
+static void
+dump_queue_init (struct dump_queue *dump_queue)
+{
+ dump_tailq_init (&dump_queue->zero_weight_objects);
+ dump_tailq_init (&dump_queue->one_weight_normal_objects);
+ dump_tailq_init (&dump_queue->one_weight_strong_objects);
+ dump_tailq_init (&dump_queue->fancy_weight_objects);
+ dump_queue->link_weights = make_eq_hash_table ();
+ dump_queue->sequence_numbers = make_eq_hash_table ();
+ dump_queue->next_sequence_number = 1;
+}
+
+static bool
+dump_queue_empty_p (struct dump_queue *dump_queue)
+{
+ bool is_empty =
+ EQ (Fhash_table_count (dump_queue->sequence_numbers),
- XFASTINT (Fhash_table_count (dump_queue->sequence_numbers))
++ make_fixnum (0));
+ eassert (EQ (Fhash_table_count (dump_queue->sequence_numbers),
+ Fhash_table_count (dump_queue->link_weights)));
+ if (!is_empty)
+ {
+ eassert (
+ !dump_tailq_empty_p (&dump_queue->zero_weight_objects) ||
+ !dump_tailq_empty_p (&dump_queue->one_weight_normal_objects) ||
+ !dump_tailq_empty_p (&dump_queue->one_weight_strong_objects) ||
+ !dump_tailq_empty_p (&dump_queue->fancy_weight_objects));
+ }
+ else
+ {
+ /* If we're empty, we can still have a few stragglers on one of
+ the above queues. */
+ }
+
+ return is_empty;
+}
+
+static void
+dump_queue_push_weight (Lisp_Object *weight_list,
+ dump_off basis,
+ struct link_weight weight)
+{
+ if (EQ (*weight_list, Qt))
+ *weight_list = Qnil;
+ dump_push (weight_list, Fcons (dump_off_to_lisp (basis),
+ dump_off_to_lisp (weight.value)));
+}
+
+static void
+dump_queue_enqueue (struct dump_queue *dump_queue,
+ Lisp_Object object,
+ dump_off basis,
+ struct link_weight weight)
+{
+ Lisp_Object weights = Fgethash (object, dump_queue->link_weights, Qnil);
+ Lisp_Object orig_weights = weights;
+ // N.B. want to find the last item of a given weight in each queue
+ // due to prepend use.
+ bool use_single_queues = true;
+ if (NILP (weights))
+ {
+ /* Object is new. */
+ dump_trace ("new object %016x weight=%u\n",
+ (unsigned) XLI (object),
+ (unsigned) weight.value);
+
+ if (weight.value == WEIGHT_NONE.value)
+ {
+ eassert (weight.value == 0);
+ dump_tailq_prepend (&dump_queue->zero_weight_objects, object);
+ weights = Qt;
+ }
+ else if (!use_single_queues)
+ {
+ dump_tailq_prepend (&dump_queue->fancy_weight_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else if (weight.value == WEIGHT_NORMAL.value)
+ {
+ dump_tailq_prepend (&dump_queue->one_weight_normal_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else if (weight.value == WEIGHT_STRONG.value)
+ {
+ dump_tailq_prepend (&dump_queue->one_weight_strong_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ else
+ {
+ emacs_abort ();
+ }
+
+ Fputhash (object,
+ dump_off_to_lisp(dump_queue->next_sequence_number++),
+ dump_queue->sequence_numbers);
+ }
+ else
+ {
+ /* Object was already on the queue. It's okay for an object to
+ be on multiple queues so long as we maintain order
+ invariants: attempting to dump an object multiple times is
+ harmless, and most of the time, an object is only referenced
+ once before being dumped, making this code path uncommon. */
+ if (weight.value != WEIGHT_NONE.value)
+ {
+ if (EQ (weights, Qt))
+ {
+ /* Object previously had a zero weight. Once we
+ incorporate the link weight attached to this call,
+ the object will have a single weight. Put the object
+ on the appropriate single-weight queue. */
+ weights = Qnil;
+ if (!use_single_queues)
+ dump_tailq_prepend (&dump_queue->fancy_weight_objects, object);
+ else if (weight.value == WEIGHT_NORMAL.value)
+ dump_tailq_prepend (
+ &dump_queue->one_weight_normal_objects, object);
+ else if (weight.value == WEIGHT_STRONG.value)
+ dump_tailq_prepend (
+ &dump_queue->one_weight_strong_objects, object);
+ else
+ emacs_abort ();
+ }
+ else if (use_single_queues && NILP (XCDR (weights)))
+ dump_tailq_prepend (&dump_queue->fancy_weight_objects, object);
+ dump_queue_push_weight (&weights, basis, weight);
+ }
+ }
+
+ if (!EQ (weights, orig_weights))
+ Fputhash (object, weights, dump_queue->link_weights);
+}
+
+static float
+dump_calc_link_score (dump_off basis,
+ dump_off link_basis,
+ dump_off link_weight)
+{
+ float distance = (float)(basis - link_basis);
+ eassert (distance >= 0);
+ float link_score = powf (distance, -0.2f);
+ return powf (link_score, (float) link_weight / 1000.0f);
+}
+
+/* Compute the score score for a queued object.
+
+ OBJECT is the object to query, which must currently be queued for
+ dumping. BASIS is the offset at which we would be
+ dumping the object; score is computed relative to BASIS and the
+ various BASIS values supplied to dump_add_link_weight --- the
+ further an object is from its referrers, the greater the
+ score. */
+static float
+dump_queue_compute_score (struct dump_queue *dump_queue,
+ Lisp_Object object,
+ dump_off basis)
+{
+ float score = 0;
+ Lisp_Object object_link_weights =
+ Fgethash (object, dump_queue->link_weights, Qnil);
+ if (EQ (object_link_weights, Qt))
+ object_link_weights = Qnil;
+ while (!NILP (object_link_weights))
+ {
+ Lisp_Object basis_weight_pair = dump_pop (&object_link_weights);
+ dump_off link_basis = dump_off_from_lisp (XCAR (basis_weight_pair));
+ dump_off link_weight = dump_off_from_lisp (XCDR (basis_weight_pair));
+ score += dump_calc_link_score (basis, link_basis, link_weight);
+ }
+ return score;
+}
+
+/* Scan the fancy part of the dump queue.
+
+ BASIS is the position at which to evaluate the score function,
+ usually ctx->offset.
+
+ If we have at least one entry in the queue, return the pointer (in
+ the singly-linked list) to the cons containing the object via
+ *OUT_HIGHEST_SCORE_CONS_PTR and return its score.
+
+ If the queue is empty, set *OUT_HIGHEST_SCORE_CONS_PTR to NULL
+ and return negative infinity. */
+static float
+dump_queue_scan_fancy (struct dump_queue *dump_queue,
+ dump_off basis,
+ Lisp_Object **out_highest_score_cons_ptr)
+{
+ Lisp_Object *cons_ptr = &dump_queue->fancy_weight_objects.head;
+ Lisp_Object *highest_score_cons_ptr = NULL;
+ float highest_score = -INFINITY;
+ bool first = true;
+
+ while (!NILP (*cons_ptr))
+ {
+ Lisp_Object queued_object = XCAR (*cons_ptr);
+ float score = dump_queue_compute_score (
+ dump_queue, queued_object, basis);
+ if (first || score >= highest_score)
+ {
+ highest_score_cons_ptr = cons_ptr;
+ highest_score = score;
+ if (first)
+ first = false;
+ }
+ cons_ptr = &XCONS (*cons_ptr)->u.s.u.cdr;
+ }
+
+ *out_highest_score_cons_ptr = highest_score_cons_ptr;
+ return highest_score;
+}
+
+/* Return the sequence number of OBJECT.
+
+ Return -1 if object doesn't have a sequence number. This situation
+ can occur when we've double-queued an object. If this happens, we
+ discard the errant object and try again. */
+static dump_off
+dump_queue_sequence (struct dump_queue *dump_queue,
+ Lisp_Object object)
+{
+ Lisp_Object n = Fgethash (object, dump_queue->sequence_numbers, Qnil);
+ return NILP (n) ? -1 : dump_off_from_lisp (n);
+}
+
+/* Find score and sequence at head of a one-weight object queue.
+
+ Transparently discard stale objects from head of queue. BASIS
+ is the baseness for score computation.
+
+ We organize these queues so that score is strictly decreasing, so
+ examining the head is sufficient. */
+static void
+dump_queue_find_score_of_one_weight_queue (
+ struct dump_queue *dump_queue,
+ dump_off basis,
+ struct dump_tailq *one_weight_queue,
+ float *out_score,
+ int *out_sequence)
+{
+ /* Transparently discard stale objects from the head of this queue. */
+ do
+ {
+ if (dump_tailq_empty_p (one_weight_queue))
+ {
+ *out_score = -INFINITY;
+ *out_sequence = 0;
+ }
+ else
+ {
+ Lisp_Object head = dump_tailq_peek (one_weight_queue);
+ *out_sequence = dump_queue_sequence (dump_queue, head);
+ if (*out_sequence < 0)
+ dump_tailq_pop (one_weight_queue);
+ else
+ *out_score =
+ dump_queue_compute_score (dump_queue, head, basis);
+ }
+ }
+ while (*out_sequence < 0);
+}
+
+/* Pop the next object to dump from the dump queue.
+
+ BASIS is the dump offset at which to evaluate score.
+
+ The object returned is the queued object with the greatest score;
+ by side effect, the object is removed from the dump queue.
+ The dump queue must not be empty. */
+static Lisp_Object
+dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis)
+{
+ eassert (EQ (Fhash_table_count (dump_queue->sequence_numbers),
+ Fhash_table_count (dump_queue->link_weights)));
+
+ eassert (
- (unsigned) XFASTINT (Fhash_table_count (dump_queue->link_weights)));
++ XFIXNUM (Fhash_table_count (dump_queue->sequence_numbers))
+ <= (dump_tailq_length (&dump_queue->fancy_weight_objects) +
+ dump_tailq_length (&dump_queue->zero_weight_objects) +
+ dump_tailq_length (&dump_queue->one_weight_normal_objects) +
+ dump_tailq_length (&dump_queue->one_weight_strong_objects)));
+
+ bool dump_object_counts = true;
+ if (dump_object_counts)
+ dump_trace (
+ "dump_queue_dequeue basis=%d fancy=%u zero=%u "
+ "normal=%u strong=%u hash=%u\n",
+ basis,
+ (unsigned) dump_tailq_length (&dump_queue->fancy_weight_objects),
+ (unsigned) dump_tailq_length (&dump_queue->zero_weight_objects),
+ (unsigned) dump_tailq_length (&dump_queue->one_weight_normal_objects),
+ (unsigned) dump_tailq_length (&dump_queue->one_weight_strong_objects),
- if (!dump_object_self_representing_p (object) ||
- dump_object_emacs_ptr (object))
++ (unsigned) XFIXNUM (Fhash_table_count (dump_queue->link_weights)));
+
+ static const int nr_candidates = 3;
+ struct candidate {
+ float score;
+ dump_off sequence;
+ } candidates[nr_candidates];
+
+ Lisp_Object *fancy_cons = NULL;
+ candidates[0].sequence = 0;
+ do
+ {
+ if (candidates[0].sequence < 0)
+ *fancy_cons = XCDR (*fancy_cons); /* Discard stale object. */
+ candidates[0].score = dump_queue_scan_fancy (
+ dump_queue,
+ basis,
+ &fancy_cons);
+ candidates[0].sequence =
+ candidates[0].score > -INFINITY
+ ? dump_queue_sequence (dump_queue, XCAR (*fancy_cons))
+ : 0;
+ }
+ while (candidates[0].sequence < 0);
+
+ dump_queue_find_score_of_one_weight_queue (
+ dump_queue,
+ basis,
+ &dump_queue->one_weight_normal_objects,
+ &candidates[1].score,
+ &candidates[1].sequence);
+
+ dump_queue_find_score_of_one_weight_queue (
+ dump_queue,
+ basis,
+ &dump_queue->one_weight_strong_objects,
+ &candidates[2].score,
+ &candidates[2].sequence);
+
+ int best = -1;
+ for (int i = 0; i < nr_candidates; ++i)
+ {
+ eassert (candidates[i].sequence >= 0);
+ if (candidates[i].score > -INFINITY &&
+ (best < 0 ||
+ candidates[i].score > candidates[best].score ||
+ (candidates[i].score == candidates[best].score
+ && candidates[i].sequence < candidates[best].sequence)))
+ best = i;
+ }
+
+ Lisp_Object result;
+ const char *src;
+ if (best < 0)
+ {
+ src = "zero";
+ result = dump_tailq_pop (&dump_queue->zero_weight_objects);
+ }
+ else if (best == 0)
+ {
+ src = "fancy";
+ result = dump_tailq_pop (&dump_queue->fancy_weight_objects);
+ }
+ else if (best == 1)
+ {
+ src = "normal";
+ result = dump_tailq_pop (&dump_queue->one_weight_normal_objects);
+ }
+ else if (best == 2)
+ {
+ src = "strong";
+ result = dump_tailq_pop (&dump_queue->one_weight_strong_objects);
+ }
+ else
+ emacs_abort ();
+
+ dump_trace (" result score=%f src=%s object=%016x\n",
+ best < 0 ? -1.0 : (double) candidates[best].score,
+ src,
+ (unsigned) XLI (result));
+
+ {
+ Lisp_Object weights = Fgethash (result, dump_queue->link_weights, Qnil);
+ while (!NILP (weights) && CONSP (weights))
+ {
+ Lisp_Object basis_weight_pair = dump_pop (&weights);
+ dump_off link_basis =
+ dump_off_from_lisp (XCAR (basis_weight_pair));
+ dump_off link_weight =
+ dump_off_from_lisp (XCDR (basis_weight_pair));
+ dump_trace (
+ " link_basis=%d distance=%d weight=%d contrib=%f\n",
+ link_basis,
+ basis - link_basis,
+ link_weight,
+ (double) dump_calc_link_score (
+ basis, link_basis, link_weight));
+ }
+ }
+
+ Fremhash (result, dump_queue->link_weights);
+ Fremhash (result, dump_queue->sequence_numbers);
+ return result;
+}
+
++/* Return whether we need to write OBJECT to the dump file. */
++static bool
++dump_object_needs_dumping_p (Lisp_Object object)
++{
++ /* Some objects, like symbols, are self-representing because they
++ have invariant bit patterns, but sometimes these objects have
++ associated data too, and these data-carrying objects need to be
++ included in the dump despite all references to them being
++ bitwise-invariant. */
++ return !dump_object_self_representing_p (object) ||
++ dump_object_emacs_ptr (object);
++}
++
+static void
+dump_enqueue_object (struct dump_context *ctx,
+ Lisp_Object object,
+ struct link_weight weight)
+{
- bool cold = BOOL_VECTOR_P (object) || FLOATP (object);
++ if (dump_object_needs_dumping_p (object))
+ {
+ dump_off state = dump_recall_object (ctx, object);
+ bool already_dumped_object = state > DUMP_OBJECT_NOT_SEEN;
+ if (ctx->flags.assert_already_seen)
+ eassert (already_dumped_object);
+ if (!already_dumped_object)
+ {
- dump_remember_object (ctx, object, DUMP_OBJECT_ON_NORMAL_QUEUE);
- if (cold)
- dump_remember_cold_op (ctx, COLD_OP_OBJECT, object);
+ if (state == DUMP_OBJECT_NOT_SEEN)
+ {
- if (!cold &&
- state <= DUMP_OBJECT_NOT_SEEN &&
- state != DUMP_OBJECT_DEFERRED)
++ state = DUMP_OBJECT_ON_NORMAL_QUEUE;
++ dump_remember_object (ctx, object, state);
+ }
- /* Always make sure that we have a referrer. */
++ /* Note that we call dump_queue_enqueue even if the object
++ is already on the normal queue: multiple enqueue calls
++ can increase the object's weight. */
++ if (state == DUMP_OBJECT_ON_NORMAL_QUEUE)
+ dump_queue_enqueue (&ctx->dump_queue,
+ object,
+ ctx->offset,
+ weight);
+ }
+ }
- dump_push (&ctx->cold_queue, Fcons (make_number (op), arg));
++ /* Always remember the path to this object. */
+ dump_note_reachable (ctx, object);
+}
+
+static void
+print_paths_to_root_1 (struct dump_context *ctx,
+ Lisp_Object object,
+ int level)
+{
+ Lisp_Object referrers = Fgethash (object, ctx->referrers, Qnil);
+ while (!NILP (referrers))
+ {
+ Lisp_Object referrer = XCAR (referrers);
+ referrers = XCDR (referrers);
+ Lisp_Object repr = Fprin1_to_string (referrer, Qnil);
+ for (int i = 0; i < level; ++i)
+ fputc (' ', stderr);
+ fprintf (stderr, "%s\n", SDATA (repr));
+ print_paths_to_root_1 (ctx, referrer, level + 1);
+ }
+}
+
+static void
+print_paths_to_root (struct dump_context *ctx, Lisp_Object object)
+{
+ print_paths_to_root_1 (ctx, object, 0);
+}
+
+static void
+dump_remember_cold_op (struct dump_context *ctx,
+ enum cold_op op,
+ Lisp_Object arg)
+{
+ if (ctx->flags.dump_object_contents)
- case Lisp_Misc:
++ dump_push (&ctx->cold_queue, Fcons (make_fixnum (op), arg));
+}
+
+/* Add a dump relocation that points into Emacs.
+
+ Add a relocation that updates the pointer stored at DUMP_OFFSET to
+ point into the Emacs binary upon dump load. The pointer-sized
+ value at DUMP_OFFSET in the dump file should contain a number
+ relative to emacs_basis(). */
+static void
+dump_reloc_dump_to_emacs_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset)
+{
+ if (ctx->flags.dump_object_contents)
+ dump_push (&ctx->dump_relocs,
+ list2 (dump_off_to_lisp (RELOC_DUMP_TO_EMACS_PTR_RAW),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points a Lisp_Object back at the dump.
+
+ Add a relocation that updates the Lisp_Object at DUMP_OFFSET in the
+ dump to point to another object in the dump. The Lisp_Object-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to the start of the dump. */
+static void
+dump_reloc_dump_to_dump_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ enum Lisp_Type type)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ int reloc_type;
+ switch (type)
+ {
+ case Lisp_Symbol:
- case Lisp_Misc:
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ reloc_type = RELOC_DUMP_TO_DUMP_LV + type;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ dump_push (&ctx->dump_relocs,
+ list2 (dump_off_to_lisp (reloc_type),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points a raw pointer back at the dump.
+
+ Add a relocation that updates the raw pointer at DUMP_OFFSET in the
+ dump to point to another object in the dump. The pointer-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to the start of the dump. */
+static void
+dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset)
+{
+ if (ctx->flags.dump_object_contents)
+ dump_push (&ctx->dump_relocs,
+ list2 (dump_off_to_lisp (RELOC_DUMP_TO_DUMP_PTR_RAW),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add a dump relocation that points to a Lisp object in Emacs.
+
+ Add a relocation that updates the Lisp_Object at DUMP_OFFSET in the
+ dump to point to a lisp object in Emacs. The Lisp_Object-sized
+ value at DUMP_OFFSET in the dump file should contain the offset of
+ the target object relative to emacs_basis(). TYPE is the type of
+ Lisp value. */
+static void
+dump_reloc_dump_to_emacs_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ enum Lisp_Type type)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ int reloc_type;
+ switch (type)
+ {
- list4 (make_number (RELOC_EMACS_COPY_FROM_DUMP),
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ reloc_type = RELOC_DUMP_TO_EMACS_LV + type;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ dump_push (&ctx->dump_relocs,
+ list2 (dump_off_to_lisp (reloc_type),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add an Emacs relocation that copies arbitrary bytes from the dump.
+
+ When the dump is loaded, Emacs copies SIZE bytes from OFFSET in
+ dump to LOCATION in the Emacs data section. This copying happens
+ after other relocations, so it's all right to, say, copy a
+ Lisp_Object (since by the time we copy the Lisp_Object, it'll have
+ been adjusted to account for the location of the running Emacs and
+ dump file). */
+static void
+dump_emacs_reloc_copy_from_dump (struct dump_context *ctx,
+ dump_off dump_offset,
+ void* emacs_ptr,
+ dump_off size)
+{
+ eassert (size >= 0);
+ eassert (size < (1 << EMACS_RELOC_LENGTH_BITS));
+
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ if (size == 0)
+ return;
+
++ eassert (dump_offset >= 0);
+ dump_push (&ctx->emacs_relocs,
- list4 (make_number (RELOC_EMACS_IMMEDIATE),
++ list4 (make_fixnum (RELOC_EMACS_COPY_FROM_DUMP),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (dump_offset),
+ dump_off_to_lisp (size)));
+}
+
+/* Add an Emacs relocation that sets values to arbitrary bytes.
+
+ When the dump is loaded, Emacs copies SIZE bytes from the
+ relocation itself to the adjusted location inside Emacs EMACS_PTR.
+ SIZE is the number of bytes to copy. See struct emacs_reloc for
+ the maximum size that this mechanism can support. The value comes
+ from VALUE_PTR.
+ */
+static void
+dump_emacs_reloc_immediate (struct dump_context *ctx,
+ const void *emacs_ptr,
+ const void *value_ptr,
+ dump_off size)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ intmax_t value = 0;
+ eassert (size <= sizeof (value));
+ memcpy (&value, value_ptr, size);
+ dump_push (&ctx->emacs_relocs,
- list3 (make_number (RELOC_EMACS_DUMP_PTR_RAW),
++ list4 (make_fixnum (RELOC_EMACS_IMMEDIATE),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ intmax_t_to_lisp (value),
+ dump_off_to_lisp (size)));
+}
+
+#define DEFINE_EMACS_IMMEDIATE_FN(fnname, type) \
+ static void \
+ fnname (struct dump_context *ctx, \
+ const type *emacs_ptr, \
+ type value) \
+ { \
+ dump_emacs_reloc_immediate ( \
+ ctx, emacs_ptr, &value, sizeof (value)); \
+ }
+
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_lv, Lisp_Object);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_ptrdiff_t, ptrdiff_t);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_emacs_int, EMACS_INT);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_int, int);
+DEFINE_EMACS_IMMEDIATE_FN (dump_emacs_reloc_immediate_bool, bool);
+
+/* Add an emacs relocation that makes a raw pointer in Emacs point
+ into the dump. */
+static void
+dump_emacs_reloc_to_dump_ptr_raw (struct dump_context *ctx,
+ const void* emacs_ptr,
+ dump_off dump_offset)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->emacs_relocs,
- dump_emacs_reloc_to_dump_lv (struct dump_context *ctx,
- Lisp_Object *emacs_ptr,
- Lisp_Object value)
++ list3 (make_fixnum (RELOC_EMACS_DUMP_PTR_RAW),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (dump_offset)));
+}
+
+/* Add an emacs relocation that points into the dump.
+
+ When the dump is loaded, the Lisp_Object at EMACS_ROOT in Emacs to
+ point to VALUE. VALUE can be any Lisp value; this function
+ automatically queues the value for dumping if necessary. */
+static void
- list3 (dump_off_to_lisp (RELOC_EMACS_DUMP_LV + XTYPE (value)),
++dump_emacs_reloc_to_lv (struct dump_context *ctx,
++ Lisp_Object *emacs_ptr,
++ Lisp_Object value)
+{
+ if (dump_object_self_representing_p (value))
+ dump_emacs_reloc_immediate_lv (ctx, emacs_ptr, value);
+ else
+ {
+ if (ctx->flags.dump_object_contents)
++ /* Conditionally use RELOC_EMACS_EMACS_LV or
++ RELOC_EMACS_DUMP_LV depending on where the target object
++ lives. We could just have decode_emacs_reloc pick the
++ right type, but we might as well maintain the invariant
++ that the types on ctx->emacs_relocs correspond to the types
++ of emacs_relocs we actually emit. */
+ dump_push (
+ &ctx->emacs_relocs,
- list3 (make_number (RELOC_EMACS_EMACS_PTR_RAW),
++ list3 (make_fixnum (dump_object_emacs_ptr (value)
++ ? RELOC_EMACS_EMACS_LV
++ : RELOC_EMACS_DUMP_LV),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ value));
+ dump_enqueue_object (ctx, value, WEIGHT_NONE);
+ }
+}
+
+/* Add an emacs relocation that makes a raw pointer in Emacs point
+ back into the Emacs image. */
+static void
+dump_emacs_reloc_to_emacs_ptr_raw (struct dump_context *ctx,
+ void* emacs_ptr,
+ void *target_emacs_ptr)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->emacs_relocs,
- make_number (fixup_subtype == LV_FIXUP_LISP_OBJECT
++ list3 (make_fixnum (RELOC_EMACS_EMACS_PTR_RAW),
+ dump_off_to_lisp (emacs_offset (emacs_ptr)),
+ dump_off_to_lisp (emacs_offset (target_emacs_ptr))));
+}
+
+/* Add an Emacs relocation that makes a raw pointer in Emacs point to
+ a different part of Emacs. */
+
+enum dump_fixup_type
+ {
+ DUMP_FIXUP_LISP_OBJECT,
+ DUMP_FIXUP_LISP_OBJECT_RAW,
+ DUMP_FIXUP_PTR_DUMP_RAW,
+ };
+
+enum dump_lv_fixup_type
+ {
+ LV_FIXUP_LISP_OBJECT,
+ LV_FIXUP_RAW_POINTER,
+ };
+
+/* Make something in the dump point to a lisp object.
+
+ CTX is a dump context. DUMP_OFFSET is the location in the dump to
+ fix. VALUE is the object to which the location in the dump
+ should point.
+
+ If FIXUP_SUBTYPE is LV_FIXUP_LISP_OBJECT, we expect a Lisp_Object
+ at DUMP_OFFSET. If it's LV_FIXUP_RAW_POINTER, we expect a pointer.
+ */
+static void
+dump_remember_fixup_lv (struct dump_context *ctx,
+ dump_off dump_offset,
+ Lisp_Object value,
+ enum dump_lv_fixup_type fixup_subtype)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_push (&ctx->fixups,
+ list3 (
- make_number (DUMP_FIXUP_PTR_DUMP_RAW),
++ make_fixnum (fixup_subtype == LV_FIXUP_LISP_OBJECT
+ ? DUMP_FIXUP_LISP_OBJECT
+ : DUMP_FIXUP_LISP_OBJECT_RAW),
+ dump_off_to_lisp (dump_offset),
+ value));
+}
+
+/* Remember to fix up the dump file such that the pointer-sized value
+ at DUMP_OFFSET points to NEW_DUMP_OFFSET in the dump file and to
+ its absolute address at runtime. */
+static void
+dump_remember_fixup_ptr_raw (struct dump_context *ctx,
+ dump_off dump_offset,
+ dump_off new_dump_offset)
+{
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ /* We should not be generating relocations into the
+ to-be-copied-into-Emacs dump region. */
+ eassert (ctx->header.discardable_start == 0 ||
+ new_dump_offset < ctx->header.discardable_start ||
+ (ctx->header.cold_start != 0 &&
+ new_dump_offset >= ctx->header.cold_start));
+
+ dump_push (&ctx->fixups,
+ list3 (
- dump_emacs_reloc_to_dump_lv (ctx, root_ptr, *root_ptr);
++ make_fixnum (DUMP_FIXUP_PTR_DUMP_RAW),
+ dump_off_to_lisp (dump_offset),
+ dump_off_to_lisp (new_dump_offset)));
+}
+
+static void
+dump_root_visitor (Lisp_Object *root_ptr, enum gc_root_type type, void *data)
+{
+ struct dump_context *ctx = data;
+ Lisp_Object value = *root_ptr;
+ if (type == GC_ROOT_C_SYMBOL)
+ {
+ eassert (dump_builtin_symbol_p (value));
+ /* Remember to dump the object itself later along with all the
+ rest of the copied-to-Emacs objects. */
+ DUMP_SET_REFERRER (ctx, build_string ("built-in symbol list"));
+ dump_enqueue_object (ctx, value, WEIGHT_NONE);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ else
+ {
++ if (type == GC_ROOT_STATICPRO)
++ Fputhash (dump_off_to_lisp (emacs_offset (root_ptr)),
++ Qt,
++ ctx->staticpro_table);
+ if (root_ptr != &Vinternal_interpreter_environment)
+ {
+ DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("emacs root", root_ptr));
- if (ptr_raw_type == NULL)
++ dump_emacs_reloc_to_lv (ctx, root_ptr, *root_ptr);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ }
+}
+
+/* Kick off the dump process by queuing up the static GC roots. */
+static void
+dump_roots (struct dump_context *ctx)
+{
+ struct gc_root_visitor visitor;
+ memset (&visitor, 0, sizeof (visitor));
+ visitor.visit = dump_root_visitor;
+ visitor.data = ctx;
+ visit_static_gc_roots (visitor);
+}
+
+static dump_off
+field_relpos (const void *in_start, const void *in_field)
+{
+ ptrdiff_t in_start_val = (ptrdiff_t) in_start;
+ ptrdiff_t in_field_val = (ptrdiff_t) in_field;
+ eassert (in_start_val <= in_field_val);
+ ptrdiff_t relpos = in_field_val - in_start_val;
+ eassert (relpos < 1024); /* Sanity check. */
+ return (dump_off) relpos;
+}
+
+static void
+cpyptr (void *out, const void *in)
+{
+ memcpy (out, in, sizeof (void *));
+}
+
+/* Convenience macro for regular assignment. */
+#define DUMP_FIELD_COPY(out, in, name) \
+ do \
+ { \
+ (out)->name = (in)->name; \
+ } \
+ while (0)
+
+static void
+dump_field_lv_or_rawptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ /* opt */ const enum Lisp_Type *ptr_raw_type,
+ struct link_weight weight)
+{
+ eassert (ctx->obj_offset > 0);
+
+ Lisp_Object value;
+ dump_off relpos = field_relpos (in_start, in_field);
+ void *out_field = (char *) out + relpos;
- case Lisp_Misc:
++ bool is_ptr_raw = (ptr_raw_type != NULL);
++
++ if (!is_ptr_raw)
+ {
+ memcpy (&value, in_field, sizeof (value));
+ if (dump_object_self_representing_p (value))
+ {
+ memcpy (out_field, &value, sizeof (value));
+ return;
+ }
+ }
+ else
+ {
+ void *ptrval;
+ cpyptr (&ptrval, in_field);
+ if (ptrval == NULL)
+ return; /* Nothing to do. */
+ switch (*ptr_raw_type)
+ {
+ case Lisp_Symbol:
+ value = make_lisp_symbol (ptrval);
+ break;
- bool is_ptr_raw = (ptr_raw_type != NULL);
-
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ value = make_lisp_ptr (ptrval, *ptr_raw_type);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+
- intptr_t abs_emacs_ptr;
- cpyptr (&abs_emacs_ptr, in_field);
- ptrdiff_t rel_emacs_ptr = abs_emacs_ptr - (intptr_t) emacs_basis ();
+ /* Now value is the Lisp_Object to which we want to point whether or
+ not the field is a raw pointer (in which case we just synthesized
+ the Lisp_Object outselves) or a Lisp_Object (in which case we
+ just copied the thing). Add a fixup or relocation. */
+
+ intptr_t out_value;
+ dump_off out_field_offset = ctx->obj_offset + relpos;
+ dump_off target_offset = dump_recall_object (ctx, value);
+ if (DANGEROUS &&
+ target_offset > 0 && dump_object_emacs_ptr (value) == NULL)
+ {
+ /* We've already dumped the referenced object, so we can emit
+ the value and a relocation directly instead of indirecting
+ through a fixup. */
+ out_value = target_offset;
+ if (is_ptr_raw)
+ dump_reloc_dump_to_dump_ptr_raw (ctx, out_field_offset);
+ else
+ dump_reloc_dump_to_dump_lv (ctx, out_field_offset, XTYPE (value));
+ }
+ else
+ {
+ /* We don't know about the target object yet, so add a fixup.
+ When we process the fixup, we'll have dumped the target
+ object. */
+ out_value = (intptr_t) 0xDEADF00D;
+ dump_remember_fixup_lv (ctx,
+ out_field_offset,
+ value,
+ ( is_ptr_raw
+ ? LV_FIXUP_RAW_POINTER
+ : LV_FIXUP_LISP_OBJECT ));
+ dump_enqueue_object (ctx, value, weight);
+ }
+
+ memcpy (out_field, &out_value, sizeof (out_value));
+}
+
+/* Set a pointer field on an output object during dump.
+
+ CTX is the dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to the field in that object. TYPE is the type of pointer
+ to which IN_FIELD points.
+ */
+static void
+dump_field_lv_rawptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ enum Lisp_Type type,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, &type, weight);
+}
+
+/* Set a Lisp_Object field on an output object during dump.
+
+ CTX is a dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to a Lisp_Object field in that object.
+
+ Arrange for the dump to contain fixups and relocations such that,
+ at load time, the given field of the output object contains a valid
+ Lisp_Object pointing to the same notional object that *IN_FIELD
+ contains now.
+
+ See idomatic usage below. */
+static void
+dump_field_lv (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const Lisp_Object *in_field,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, NULL, weight);
+}
+
+/* Note that we're going to add a manual fixup for the given field
+ later. */
+static void
+dump_field_fixup_later (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ // TODO: more error checking
+ (void) field_relpos (in_start, in_field);
+}
+
+/* Mark an output object field, which is as wide as a poiner, as being
+ fixed up to point to a specific offset in the dump. */
+static void
+dump_field_ptr_to_dump_offset (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ dump_off target_dump_offset)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_off relpos = field_relpos (in_start, in_field);
+ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->obj_offset + relpos);
+ intptr_t outval = target_dump_offset;
+ memcpy ((char*) out + relpos, &outval, sizeof (outval));
+}
+
+/* Mark a field as pointing to a place inside Emacs.
+
+ CTX is the dump context. OUT points to the out-object for the
+ current dump function. IN_START points to the start of the object
+ being dumped. IN_FIELD points to the field inside the object being
+ dumped that we're dumping. The contents of this field (which
+ should be as wide as a pointer) are the Emacs pointer to dump.
+
+ */
+static void
+dump_field_emacs_ptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
- dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->obj_offset + relpos);
+ dump_off relpos = field_relpos (in_start, in_field);
++ void *abs_emacs_ptr;
++ cpyptr (&abs_emacs_ptr, in_field);
++ intptr_t rel_emacs_ptr = 0;
++ if (abs_emacs_ptr)
++ {
++ rel_emacs_ptr = emacs_offset ((void *)abs_emacs_ptr);
++ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->obj_offset + relpos);
++ }
+ cpyptr ((char*) out + relpos, &rel_emacs_ptr);
- dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
- DUMP_FIELD_COPY (&out, marker, type);
- eassert (marker->gcmarkbit == 0);
- (void) marker->spacer; /* Do not write padding. */
++}
++
++static void
++dump_object_start_pseudovector (
++ struct dump_context *ctx,
++ union vectorlike_header *out_hdr,
++ dump_off out_size,
++ const union vectorlike_header *in_hdr)
++{
++ const struct Lisp_Vector *in = (const struct Lisp_Vector *) in_hdr;
++ struct Lisp_Vector *out = (struct Lisp_Vector *) out_hdr;
++ ptrdiff_t vec_size = vector_nbytes ((struct Lisp_Vector *) in);
++ eassert (vec_size >= out_size);
++ eassert (vec_size - out_size <= sizeof (EMACS_INT));
++
++ dump_object_start (ctx, GCALIGNMENT, out, (dump_off) vec_size);
++ DUMP_FIELD_COPY (out, in, header);
++ ptrdiff_t size = in->header.size;
++ eassert (size & PSEUDOVECTOR_FLAG);
++}
++
++static void
++dump_pseudovector_lisp_fields (
++ struct dump_context *ctx,
++ union vectorlike_header *out_hdr,
++ const union vectorlike_header *in_hdr)
++{
++ const struct Lisp_Vector *in = (const struct Lisp_Vector *) in_hdr;
++ struct Lisp_Vector *out = (struct Lisp_Vector *) out_hdr;
++ ptrdiff_t size = in->header.size;
++ eassert (size & PSEUDOVECTOR_FLAG);
++ size &= PSEUDOVECTOR_SIZE_MASK;
++ for (ptrdiff_t i = 0; i < size; ++i)
++ dump_field_lv (ctx, out, in, &in->contents[i], WEIGHT_STRONG);
+}
+
+static dump_off
+dump_cons (struct dump_context *ctx, const struct Lisp_Cons *cons)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Cons_F25EE3E42E)
+# error "Lisp_Cons changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Cons out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ dump_field_lv (ctx, &out, cons, &cons->u.s.car, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, cons, &cons->u.s.u.cdr, WEIGHT_NORMAL);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_interval_tree (struct dump_context *ctx,
+ INTERVAL tree,
+ dump_off parent_offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_interval_9110163DA0)
+# error "interval changed. See CHECK_STRUCTS comment."
+#endif
+ // TODO: output tree breadth-first?
+ struct interval out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, tree, total_length);
+ DUMP_FIELD_COPY (&out, tree, position);
+ if (tree->left)
+ dump_field_fixup_later (ctx, &out, tree, &tree->left);
+ if (tree->right)
+ dump_field_fixup_later (ctx, &out, tree, &tree->right);
+ if (!tree->up_obj)
+ {
+ eassert (parent_offset != 0);
+ dump_field_ptr_to_dump_offset (
+ ctx, &out,
+ tree, &tree->up.interval,
+ parent_offset);
+ }
+ else
+ dump_field_lv (ctx, &out, tree, &tree->up.obj, WEIGHT_STRONG);
+ DUMP_FIELD_COPY (&out, tree, up_obj);
+ eassert (tree->gcmarkbit == 0);
+ DUMP_FIELD_COPY (&out, tree, write_protect);
+ DUMP_FIELD_COPY (&out, tree, visible);
+ DUMP_FIELD_COPY (&out, tree, front_sticky);
+ DUMP_FIELD_COPY (&out, tree, rear_sticky);
+ dump_field_lv (ctx, &out, tree, &tree->plist, WEIGHT_STRONG);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (tree->left)
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct interval, left),
+ dump_interval_tree (ctx, tree->left, offset));
+ if (tree->right)
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct interval, right),
+ dump_interval_tree (ctx, tree->right, offset));
+ return offset;
+}
+
+static dump_off
+dump_string (struct dump_context *ctx, const struct Lisp_String *string)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Symbol_EB06C0D9EA)
+# error "Lisp_String changed. See CHECK_STRUCTS comment."
+#endif
+ /* If we have text properties, write them _after_ the string so that
+ at runtime, the prefetcher and cache will DTRT. (We access the
+ string before its properties.).
+
+ There's special code to dump string data contiguously later on.
+ we seldom write to string data and never relocate it, so lumping
+ it together at the end of the dump saves on COW faults.
+
+ If, however, the string's size_byte field is -1, the string data
+ is actually a pointer to Emacs data segment, so we can do even
+ better by emitting a relocation instead of bothering to copy the
+ string data. */
+ struct Lisp_String out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, string, u.s.size);
+ DUMP_FIELD_COPY (&out, string, u.s.size_byte);
+ if (string->u.s.intervals)
+ dump_field_fixup_later (ctx, &out, string, &string->u.s.intervals);
+
+ if (string->u.s.size_byte == -2)
+ /* String literal in Emacs rodata. */
+ dump_field_emacs_ptr (ctx, &out, string, &string->u.s.data);
+ else
+ {
+ dump_field_fixup_later (ctx, &out, string, &string->u.s.data);
+ dump_remember_cold_op (ctx,
+ COLD_OP_STRING,
+ make_lisp_ptr ((void*) string, Lisp_String));
+ }
+
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (string->u.s.intervals)
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct Lisp_String, u.s.intervals),
+ dump_interval_tree (ctx, string->u.s.intervals, 0));
+
+ return offset;
+}
+
+static dump_off
+dump_marker (struct dump_context *ctx, const struct Lisp_Marker *marker)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Marker_3C824B47DB)
+# error "Lisp_Marker changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Marker out;
- Lisp_Misc,
++ dump_object_start_pseudovector (ctx, &out.header,
++ sizeof (out), &marker->header);
++ dump_pseudovector_lisp_fields (ctx, &out.header, &marker->header);
++
+ DUMP_FIELD_COPY (&out, marker, need_adjustment);
+ DUMP_FIELD_COPY (&out, marker, insertion_type);
+ if (marker->buffer)
+ {
+ dump_field_lv_rawptr (
+ ctx, &out,
+ marker, &marker->buffer,
+ Lisp_Vectorlike,
+ WEIGHT_NORMAL);
+ dump_field_lv_rawptr (
+ ctx, &out,
+ marker, &marker->next,
- dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
- DUMP_FIELD_COPY (&out, overlay, type);
- eassert (overlay->gcmarkbit == 0);
- (void) overlay->spacer; /* Do not write padding. */
- dump_field_lv_rawptr (ctx, &out, overlay, &overlay->next, Lisp_Misc,
++ Lisp_Vectorlike,
+ WEIGHT_STRONG);
+ DUMP_FIELD_COPY (&out, marker, charpos);
+ DUMP_FIELD_COPY (&out, marker, bytepos);
+ }
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_overlay (struct dump_context *ctx, const struct Lisp_Overlay *overlay)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Overlay_CD6BBB22F3)
+# error "Lisp_Overlay changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Overlay out;
- dump_field_lv (ctx, &out, overlay, &overlay->start, WEIGHT_STRONG);
- dump_field_lv (ctx, &out, overlay, &overlay->end, WEIGHT_STRONG);
- dump_field_lv (ctx, &out, overlay, &overlay->plist, WEIGHT_STRONG);
- return dump_object_finish (ctx, &out, sizeof (out));
- }
-
- static dump_off
- dump_save_value (struct dump_context *ctx,
- const struct Lisp_Save_Value *ptr)
- {
- #if CHECK_STRUCTS && !defined (HASH_Lisp_Save_Value_9DB4B1A97C)
- # error "Lisp_Save_Value changed. See CHECK_STRUCTS comment."
- #endif
- #if CHECK_STRUCTS && !defined (HASH_Lisp_Save_Type_5202541810)
- # error "Lisp_Save_Type changed. See CHECK_STRUCTS comment."
- #endif
- struct Lisp_Save_Value out;
- dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
- DUMP_FIELD_COPY (&out, ptr, type);
- eassert(ptr->gcmarkbit == 0);
- (void) ptr->spacer; /* Do not write padding. */
- DUMP_FIELD_COPY (&out, ptr, save_type);
- for (int i = 0; i < SAVE_VALUE_SLOTS; i++)
- {
- switch (save_type (&out, i))
- {
- case SAVE_UNUSED:
- break;
- case SAVE_INTEGER:
- DUMP_FIELD_COPY (&out, ptr, data[i].integer);
- break;
- case SAVE_FUNCPOINTER:
- dump_field_emacs_ptr (ctx, &out, ptr, &ptr->data[i].funcpointer);
- break;
- case SAVE_OBJECT:
- dump_field_lv (ctx, &out, ptr, &ptr->data[i].object, WEIGHT_STRONG);
- break;
- case SAVE_POINTER:
- error_unsupported_dump_object(
- ctx, make_lisp_ptr ((void *) ptr, Lisp_Misc), "SAVE_POINTER");
- default:
- emacs_abort ();
- }
- }
++ dump_object_start_pseudovector (ctx, &out.header,
++ sizeof (out), &overlay->header);
++ dump_pseudovector_lisp_fields (ctx, &out.header, &overlay->header);
++ dump_field_lv_rawptr (ctx, &out, overlay, &overlay->next,
++ Lisp_Vectorlike,
+ WEIGHT_STRONG);
- dump_field_lv_rawptr (ctx, out, finalizer, field, Lisp_Misc,
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static void
+dump_field_finalizer_ref (struct dump_context *ctx,
+ void *out,
+ const struct Lisp_Finalizer *finalizer,
+ struct Lisp_Finalizer *const *field)
+{
+ if (*field == &finalizers || *field == &doomed_finalizers)
+ dump_field_emacs_ptr (ctx, out, finalizer, field);
+ else
- dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
- DUMP_FIELD_COPY (&out, finalizer, base.type);
- eassert (finalizer->base.gcmarkbit == 0);
- (void) finalizer->base.spacer; /* Do not write padding. */
++ dump_field_lv_rawptr (ctx, out, finalizer, field,
++ Lisp_Vectorlike,
+ WEIGHT_NORMAL);
+}
+
+static dump_off
+dump_finalizer (struct dump_context *ctx,
+ const struct Lisp_Finalizer *finalizer)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Finalizer_514A6407BC)
+# error "Lisp_Finalizer changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Finalizer out;
- dump_field_lv (ctx, &out, finalizer, &finalizer->function,
- WEIGHT_NORMAL);
++ dump_object_start_pseudovector (ctx, &out.header,
++ sizeof (out), &finalizer->header);
++ /* Do _not_ call dump_object_start_pseudovector here: we dump the
++ only Lisp field, finalizer->function, manually, so we can give it
++ a low weight. */
++ dump_field_lv (ctx, &out, finalizer, &finalizer->function, WEIGHT_NONE);
+ dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->prev);
+ dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->next);
- static dump_off
- dump_misc_any (struct dump_context *ctx, struct Lisp_Misc_Any *misc_any)
- {
- #if CHECK_STRUCTS && !defined (HASH_Lisp_Misc_Any_8909174119)
- # error "Lisp_Misc_Any changed. See CHECK_STRUCTS comment."
- #endif
- #if CHECK_STRUCTS && !defined (HASH_Lisp_Misc_Type_FC6C8DD619)
- # error "Lisp_Misc_Type changed. See CHECK_STRUCTS comment."
- #endif
- dump_off result;
-
- switch (misc_any->type)
- {
- case Lisp_Misc_Marker:
- result = dump_marker (ctx, (struct Lisp_Marker *) misc_any);
- break;
-
- case Lisp_Misc_Overlay:
- result = dump_overlay (ctx, (struct Lisp_Overlay *) misc_any);
- break;
-
- case Lisp_Misc_Save_Value:
- result = dump_save_value (ctx, (struct Lisp_Save_Value *) misc_any);
- break;
-
- case Lisp_Misc_Finalizer:
- result = dump_finalizer (ctx, (struct Lisp_Finalizer *) misc_any);
- break;
-
- #ifdef HAVE_MODULES
- case Lisp_Misc_User_Ptr:
- error_unsupported_dump_object(
- ctx,
- make_lisp_ptr (misc_any, Lisp_Misc),
- "module user ptr");
- break;
- #endif
-
- default:
- emacs_abort ();
- }
-
- return result;
- }
-
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
- dump_emacs_reloc_to_dump_lv (ctx, objfwd->objvar, *objfwd->objvar);
+static dump_off
+dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_938B4A25C3)
+# error "Lisp_Float changed. See CHECK_STRUCTS comment."
+#endif
+ eassert (ctx->header.cold_start);
+ struct Lisp_Float out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, lfloat, u.data);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_int (struct dump_context *ctx, const struct Lisp_Intfwd *intfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Intfwd_1225FA32CC)
+# error "Lisp_Intfwd changed. See CHECK_STRUCTS comment."
+#endif
+ dump_emacs_reloc_immediate_emacs_int (ctx, intfwd->intvar, *intfwd->intvar);
+ struct Lisp_Intfwd out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, intfwd, type);
+ dump_field_emacs_ptr (ctx, &out, intfwd, &intfwd->intvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_bool (struct dump_context *ctx, const struct Lisp_Boolfwd *boolfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Boolfwd_0EA1C7ADCC)
+# error "Lisp_Boolfwd changed. See CHECK_STRUCTS comment."
+#endif
+ dump_emacs_reloc_immediate_bool (ctx, boolfwd->boolvar, *boolfwd->boolvar);
+ struct Lisp_Boolfwd out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, boolfwd, type);
+ dump_field_emacs_ptr (ctx, &out, boolfwd, &boolfwd->boolvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_obj (struct dump_context *ctx, const struct Lisp_Objfwd *objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Objfwd_45D3E513DC)
+# error "Lisp_Objfwd changed. See CHECK_STRUCTS comment."
+#endif
- Fgethash (symbol, symbol_aux, make_number (0)));
++ if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (objfwd->objvar)),
++ ctx->staticpro_table,
++ Qnil)))
++ dump_emacs_reloc_to_lv (ctx, objfwd->objvar, *objfwd->objvar);
+ struct Lisp_Objfwd out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, objfwd, type);
+ dump_field_emacs_ptr (ctx, &out, objfwd, &objfwd->objvar);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_buffer_obj (struct dump_context *ctx,
+ const struct Lisp_Buffer_Objfwd *buffer_objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Buffer_Objfwd_611EBD13FF)
+# error "Lisp_Buffer_Objfwd changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Objfwd out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, buffer_objfwd, type);
+ DUMP_FIELD_COPY (&out, buffer_objfwd, offset);
+ dump_field_lv (ctx, &out, buffer_objfwd, &buffer_objfwd->predicate,
+ WEIGHT_NORMAL);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd_kboard_obj (struct dump_context *ctx,
+ const struct Lisp_Kboard_Objfwd *kboard_objfwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Kboard_Objfwd_CAA7E71069)
+# error "Lisp_Intfwd changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Kboard_Objfwd out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, kboard_objfwd, type);
+ DUMP_FIELD_COPY (&out, kboard_objfwd, offset);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_fwd (struct dump_context *ctx, union Lisp_Fwd *fwd)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Fwd_5227B18E87)
+# error "Lisp_Fwd changed. See CHECK_STRUCTS comment."
+#endif
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Fwd_Type_9CBA6EE55E)
+# error "Lisp_Fwd_Type changed. See CHECK_STRUCTS comment."
+#endif
+ dump_off offset;
+
+ switch (XFWDTYPE (fwd))
+ {
+ case Lisp_Fwd_Int:
+ offset = dump_fwd_int (ctx, &fwd->u_intfwd);
+ break;
+ case Lisp_Fwd_Bool:
+ offset = dump_fwd_bool (ctx, &fwd->u_boolfwd);
+ break;
+ case Lisp_Fwd_Obj:
+ offset = dump_fwd_obj (ctx, &fwd->u_objfwd);
+ break;
+ case Lisp_Fwd_Buffer_Obj:
+ offset = dump_fwd_buffer_obj (ctx, &fwd->u_buffer_objfwd);
+ break;
+ case Lisp_Fwd_Kboard_Obj:
+ offset = dump_fwd_kboard_obj (ctx, &fwd->u_kboard_objfwd);
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ return offset;
+}
+
+static dump_off
+dump_blv (struct dump_context *ctx,
+ const struct Lisp_Buffer_Local_Value *blv)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Buffer_Local_Value_2B3BD67753)
+# error "Lisp_Buffer_Local_Value changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Local_Value out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, blv, local_if_set);
+ DUMP_FIELD_COPY (&out, blv, found);
+ if (blv->fwd)
+ dump_field_fixup_later (ctx, &out, blv, &blv->fwd);
+ dump_field_lv (ctx, &out, blv, &blv->where, WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, blv, &blv->defcell, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, blv, &blv->valcell, WEIGHT_STRONG);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (blv->fwd)
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct Lisp_Buffer_Local_Value, fwd),
+ dump_fwd (ctx, blv->fwd));
+ return offset;
+}
+
+static dump_off
+dump_recall_symbol_aux (struct dump_context *ctx, Lisp_Object symbol)
+{
+ Lisp_Object symbol_aux = ctx->symbol_aux;
+ if (NILP (symbol_aux))
+ return 0;
+ return dump_off_from_lisp (
- dump_symbol (struct dump_context *ctx, struct Lisp_Symbol *symbol)
++ Fgethash (symbol, symbol_aux, make_fixnum (0)));
+}
+
+static void
+dump_remember_symbol_aux (struct dump_context *ctx,
+ Lisp_Object symbol,
+ dump_off offset)
+{
+ Fputhash (symbol, dump_off_to_lisp (offset), ctx->symbol_aux);
+}
+
+static void
+dump_pre_dump_symbol (
+ struct dump_context *ctx,
+ struct Lisp_Symbol *symbol)
+{
+ Lisp_Object symbol_lv = make_lisp_symbol (symbol);
+ eassert (!dump_recall_symbol_aux (ctx, symbol_lv));
+ DUMP_SET_REFERRER (ctx, symbol_lv);
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_LOCALIZED:
+ dump_remember_symbol_aux (
+ ctx,
+ symbol_lv,
+ dump_blv (ctx, symbol->u.s.val.blv));
+ break;
+ case SYMBOL_FORWARDED:
+ dump_remember_symbol_aux (
+ ctx,
+ symbol_lv,
+ dump_fwd (ctx, symbol->u.s.val.fwd));
+ break;
+ default:
+ break;
+ }
+ DUMP_CLEAR_REFERRER (ctx);
+}
+
+static dump_off
- /* Scan everything to which this symbol refers. */
- struct dump_flags old_flags = ctx->flags;
- ctx->flags.dump_object_contents = false;
- ctx->flags.defer_symbols = false;
- dump_symbol (ctx, symbol);
- ctx->flags = old_flags;
- return DUMP_OBJECT_DEFERRED;
++dump_symbol (struct dump_context *ctx,
++ Lisp_Object object,
++ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Symbol_EB06C0D9EA)
+# error "Lisp_Symbol changed. See CHECK_STRUCTS comment."
+#endif
+#if CHECK_STRUCTS && !defined (HASH_symbol_redirect_ADB4F5B113)
+# error "symbol_redirect changed. See CHECK_STRUCTS comment."
+#endif
++
+ if (ctx->flags.defer_symbols)
+ {
- dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
++ if (offset != DUMP_OBJECT_ON_SYMBOL_QUEUE)
++ {
++ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE ||
++ offset == DUMP_OBJECT_NOT_SEEN);
++ DUMP_CLEAR_REFERRER (ctx);
++ struct dump_flags old_flags = ctx->flags;
++ ctx->flags.dump_object_contents = false;
++ ctx->flags.defer_symbols = false;
++ dump_object (ctx, object);
++ ctx->flags = old_flags;
++ DUMP_SET_REFERRER (ctx, object);
++
++ offset = DUMP_OBJECT_ON_SYMBOL_QUEUE;
++ dump_remember_object (ctx, object, offset);
++ dump_push (&ctx->deferred_symbols, object);
++ }
++ return offset;
+ }
+
++ struct Lisp_Symbol *symbol = XSYMBOL (object);
+ struct Lisp_Symbol out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ eassert (symbol->u.s.gcmarkbit == 0);
+ DUMP_FIELD_COPY (&out, symbol, u.s.redirect);
+ DUMP_FIELD_COPY (&out, symbol, u.s.trapped_write);
+ DUMP_FIELD_COPY (&out, symbol, u.s.interned);
+ DUMP_FIELD_COPY (&out, symbol, u.s.declared_special);
+ DUMP_FIELD_COPY (&out, symbol, u.s.pinned);
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.name, WEIGHT_STRONG);
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.val.value,
+ WEIGHT_NORMAL);
+ break;
+ case SYMBOL_VARALIAS:
+ dump_field_lv_rawptr (ctx, &out, symbol,
+ &symbol->u.s.val.alias, Lisp_Symbol,
+ WEIGHT_NORMAL);
+ break;
+ case SYMBOL_LOCALIZED:
+ dump_field_fixup_later (ctx, &out, symbol, &symbol->u.s.val.blv);
+ break;
+ case SYMBOL_FORWARDED:
+ dump_field_fixup_later (ctx, &out, symbol, &symbol->u.s.val.fwd);
+ break;
+ default:
+ emacs_abort ();
+ }
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.function, WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, symbol, &symbol->u.s.plist, WEIGHT_NORMAL);
+ dump_field_lv_rawptr (ctx, &out, symbol, &symbol->u.s.next, Lisp_Symbol,
+ WEIGHT_STRONG);
+
- static void
- dump_object_start_pseudovector (
- struct dump_context *ctx,
- union vectorlike_header *out_hdr,
- dump_off out_size,
- const union vectorlike_header *in_hdr)
- {
- const struct Lisp_Vector *in = (const struct Lisp_Vector *) in_hdr;
- struct Lisp_Vector *out = (struct Lisp_Vector *) out_hdr;
- ptrdiff_t vec_size = vector_nbytes ((struct Lisp_Vector *) in);
- eassert (vec_size >= out_size);
- eassert (vec_size - out_size <= sizeof (EMACS_INT));
-
- dump_object_start (ctx, GCALIGNMENT, out, (dump_off) vec_size);
- DUMP_FIELD_COPY (out, in, header);
- ptrdiff_t size = in->header.size;
- eassert (size & PSEUDOVECTOR_FLAG);
- size &= PSEUDOVECTOR_SIZE_MASK;
- for (ptrdiff_t i = 0; i < size; ++i)
- dump_field_lv (ctx, out, in, &in->contents[i], WEIGHT_STRONG);
- }
-
++ offset = dump_object_finish (ctx, &out, sizeof (out));
+ dump_off aux_offset;
+
+ switch (symbol->u.s.redirect)
+ {
+ case SYMBOL_LOCALIZED:
+ aux_offset = dump_recall_symbol_aux (ctx, make_lisp_symbol (symbol));
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct Lisp_Symbol, u.s.val.blv),
+ (aux_offset
+ ? aux_offset
+ : dump_blv (ctx, symbol->u.s.val.blv)));
+ break;
+ case SYMBOL_FORWARDED:
+ aux_offset = dump_recall_symbol_aux (ctx, make_lisp_symbol (symbol));
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct Lisp_Symbol, u.s.val.fwd),
+ (aux_offset
+ ? aux_offset
+ : dump_fwd (ctx, symbol->u.s.val.fwd)));
+ break;
+ default:
+ break;
+ }
+ return offset;
+}
+
+static dump_off
+dump_vectorlike_generic (
+ struct dump_context *ctx,
+ const union vectorlike_header *header)
+{
+#if CHECK_STRUCTS && !defined (HASH_vectorlike_header_8409709BAF)
+# error "vectorlike_header changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Vector *v = (const struct Lisp_Vector *) header;
+ ptrdiff_t size = header->size;
+ enum pvec_type pvectype = PSEUDOVECTOR_TYPE (v);
+ dump_off offset;
+
+ if (size & PSEUDOVECTOR_FLAG)
+ {
+ /* Assert that the pseudovector contains only Lisp values ---
+ but see the PVEC_SUB_CHAR_TABLE special case below. We allow
+ one extra word of non-lisp data when Lisp_Object is shorter
+ than GCALIGN (e.g., on 32-bit builds) to account for
+ GCALIGN-enforcing struct padding. We can't distinguish
+ between padding and some undumpable data member this way, but
+ we'll count on sizeof(Lisp_Object) >= GCALIGN builds to catch
+ this class of problem.
+ */
+ eassert (
+ ((size & PSEUDOVECTOR_REST_MASK) >> PSEUDOVECTOR_REST_BITS)
+ <= (sizeof (Lisp_Object) < GCALIGNMENT) ? 1 : 0);
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+
+ dump_align_output (ctx, GCALIGNMENT);
+ dump_off prefix_start_offset = ctx->offset;
+
+ dump_off skip;
+ if (pvectype == PVEC_SUB_CHAR_TABLE)
+ {
+ /* PVEC_SUB_CHAR_TABLE has a special case because it's a
+ variable-length vector (unlike other pseudovectors) and has
+ its non-Lisp data _before_ the variable-length Lisp part. */
+ const struct Lisp_Sub_Char_Table *sct =
+ (const struct Lisp_Sub_Char_Table *) header;
+ struct Lisp_Sub_Char_Table out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, sct, header.size);
+ DUMP_FIELD_COPY (&out, sct, depth);
+ DUMP_FIELD_COPY (&out, sct, min_char);
+ offset = dump_object_finish (ctx, &out, sizeof (out));
+ skip = SUB_CHAR_TABLE_OFFSET;
+ }
+ else
+ {
+ union vectorlike_header out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, header, size);
+ offset = dump_object_finish (ctx, &out, sizeof (out));
+ skip = 0;
+ }
+
+ /* dump_object_start isn't what records conservative-GC object
+ starts --- dump_object_1 does --- so the hack below of using
+ dump_object_start for each vector word doesn't cause GC problems
+ at runtime. */
+
+ dump_off prefix_size = ctx->offset - prefix_start_offset;
+ eassert (prefix_size > 0);
+ dump_off skip_start = ptrdiff_t_to_dump_off (
+ (char*) &v->contents[skip] - (char*) v);
+ eassert (skip_start >= prefix_size);
+ dump_write_zero (ctx, skip_start - prefix_size);
+ for (dump_off i = skip; i < size; ++i)
+ {
+ Lisp_Object out;
+ const Lisp_Object *vslot = &v->contents[i];
+ eassert (ctx->offset % sizeof (out) == 0);
+ dump_object_start (ctx, 1, &out, sizeof (out));
+ dump_field_lv (ctx, &out, vslot, vslot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof (out));
+ }
+
+ if (sizeof (Lisp_Object) < GCALIGNMENT)
+ dump_write_zero (ctx, GCALIGNMENT - (ctx->offset % GCALIGNMENT));
+
+ return offset;
+}
+
- make_number (0)));
+/* Determine whether the hash table's hash order is stable
+ across dump and load. If it is, we don't have to trigger
+ a rehash on access. */
+static bool
+dump_hash_table_stable_p (const struct Lisp_Hash_Table *hash)
+{
+ bool is_eql = hash->test.hashfn == hashfn_eql;
+ bool is_equal = hash->test.hashfn == hashfn_equal;
+ ptrdiff_t size = HASH_TABLE_SIZE (hash);
+ for (ptrdiff_t i = 0; i < size; ++i)
+ if (!NILP (HASH_HASH (hash, i)))
+ {
+ Lisp_Object key = HASH_KEY (hash, i);
+ bool key_stable = (dump_builtin_symbol_p (key) ||
+ INTEGERP (key) ||
+ (is_equal && STRINGP (key)) ||
+ ((is_equal || is_eql) && FLOATP (key)));
+ if (!key_stable)
+ return false;
+ }
+
+ return true;
+}
+
+/* Return a list of (KEY . VALUE) pairs in the given hash table. */
+static Lisp_Object
+hash_table_contents (Lisp_Object table)
+{
+ Lisp_Object contents = Qnil;
+ struct Lisp_Hash_Table *h = XHASH_TABLE (table);
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ if (!NILP (HASH_HASH (h, i)))
+ dump_push (&contents, Fcons (HASH_KEY (h, i), HASH_VALUE (h, i)));
+ return Fnreverse (contents);
+}
+
+/* Copy the given hash table, rehash it, and make sure that we can
+ look up all the values in the original. */
+static void
+check_hash_table_rehash (Lisp_Object table_orig)
+{
+ hash_rehash_if_needed (XHASH_TABLE (table_orig));
+ Lisp_Object table_rehashed = Fcopy_hash_table (table_orig);
+ eassert (XHASH_TABLE (table_rehashed)->count >= 0);
+ XHASH_TABLE (table_rehashed)->count *= -1;
+ eassert (XHASH_TABLE (table_rehashed)->count <= 0);
+ hash_rehash_if_needed (XHASH_TABLE (table_rehashed));
+ eassert (XHASH_TABLE (table_rehashed)->count >= 0);
+ Lisp_Object expected_contents = hash_table_contents (table_orig);
+ while (!NILP (expected_contents))
+ {
+ Lisp_Object key_value_pair = dump_pop (&expected_contents);
+ Lisp_Object key = XCAR (key_value_pair);
+ Lisp_Object expected_value = XCDR (key_value_pair);
+ Lisp_Object found_value = Fgethash (
+ key,
+ table_rehashed,
+ Qdump_emacs_portable__sort_predicate_copied /* arbitrary */);
+ eassert (EQ (expected_value, found_value));
+ Fremhash (key, table_rehashed);
+ }
+
+ eassert (EQ (Fhash_table_count (table_rehashed),
- const struct Lisp_Hash_Table *hash_in)
++ make_fixnum (0)));
+}
+
+static dump_off
+dump_hash_table (struct dump_context *ctx,
- /* We still want to dump the actual keys and values now. */
- dump_enqueue_object (ctx, hash_in->key_and_value, WEIGHT_NONE);
- /* We'll get to the rest later. */
- dump_push (&ctx->deferred_hash_tables,
- make_lisp_ptr ((void*)hash_in, Lisp_Vectorlike));
- return DUMP_OBJECT_DEFERRED;
++ Lisp_Object object,
++ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Hash_Table_400EA529E0)
+# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment."
+#endif
++ const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object);
+ bool is_stable = dump_hash_table_stable_p (hash_in);
+ /* If the hash table is likely to be modified in memory (either
+ because we need to rehash, and thus toggle hash->count, or
+ because we need to assemble a list of weak tables) punt the hash
+ table to the end of the dump, where we can lump all such hash
+ tables together. */
+ if (!(is_stable || !NILP (hash_in->weak)) &&
+ ctx->flags.defer_hash_tables)
+ {
- buffer->display_count_ = make_number (0);
++ if (offset != DUMP_OBJECT_ON_HASH_TABLE_QUEUE)
++ {
++ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE ||
++ offset == DUMP_OBJECT_NOT_SEEN);
++ /* We still want to dump the actual keys and values now. */
++ dump_enqueue_object (ctx, hash_in->key_and_value, WEIGHT_NONE);
++ /* We'll get to the rest later. */
++ offset = DUMP_OBJECT_ON_HASH_TABLE_QUEUE;
++ dump_remember_object (ctx, object, offset);
++ dump_push (&ctx->deferred_hash_tables, object);
++ }
++ return offset;
+ }
+
+ if (PDUMPER_CHECK_REHASHING)
+ check_hash_table_rehash (make_lisp_ptr ((void*)hash_in, Lisp_Vectorlike));
+
+ struct Lisp_Hash_Table hash_munged = *hash_in;
+ struct Lisp_Hash_Table *hash = &hash_munged;
+
+ /* Remember to rehash this hash table on first access. After a
+ dump reload, the hash table values will have changed, so we'll
+ need to rebuild the index.
+
+ TODO: for EQ and EQL hash tables, it should be possible to rehash
+ here using the preferred load address of the dump, eliminating
+ the need to rehash-on-access if we can load the dump where we
+ want. */
+ if (hash->count > 0 && !is_stable)
+ hash->count = -hash->count;
+
+ struct Lisp_Hash_Table out;
+ dump_object_start_pseudovector (
+ ctx, &out.header, sizeof (out), &hash->header);
++ dump_pseudovector_lisp_fields (ctx, &out.header, &hash->header);
++ /* TODO: dump the hash bucket vectors synchronously here to keep
++ them as close to the hash table as possible. */
+ DUMP_FIELD_COPY (&out, hash, count);
+ DUMP_FIELD_COPY (&out, hash, next_free);
+ DUMP_FIELD_COPY (&out, hash, pure);
+ DUMP_FIELD_COPY (&out, hash, rehash_threshold);
+ DUMP_FIELD_COPY (&out, hash, rehash_size);
+ dump_field_lv (ctx, &out, hash, &hash->key_and_value, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, hash, &hash->test.name, WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, hash, &hash->test.user_hash_function,
+ WEIGHT_STRONG);
+ dump_field_lv (ctx, &out, hash, &hash->test.user_cmp_function,
+ WEIGHT_STRONG);
+ dump_field_emacs_ptr (ctx, &out, hash, &hash->test.cmpfn);
+ dump_field_emacs_ptr (ctx, &out, hash, &hash->test.hashfn);
+ eassert (hash->next_weak == NULL);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static dump_off
+dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
+{
+#if CHECK_STRUCTS && !defined (HASH_buffer_E8695CAE09)
+# error "buffer changed. See CHECK_STRUCTS comment."
+#endif
+ struct buffer munged_buffer = *in_buffer;
+ struct buffer *buffer = &munged_buffer;
+
+ /* Clear some buffer state for correctness upon load. */
+ if (buffer->base_buffer == NULL)
+ buffer->window_count = 0;
+ else
+ eassert (buffer->window_count == -1);
+ buffer->last_selected_window_ = Qnil;
- Lisp_Misc, WEIGHT_NORMAL);
++ buffer->display_count_ = make_fixnum (0);
+ buffer->clip_changed = 0;
+ buffer->last_window_start = -1;
+ buffer->point_before_scroll_ = Qnil;
+
+ dump_off base_offset = 0;
+ if (buffer->base_buffer)
+ {
+ eassert (buffer->base_buffer->base_buffer == NULL);
+ base_offset = dump_object_for_offset (
+ ctx,
+ make_lisp_ptr (buffer->base_buffer, Lisp_Vectorlike));
+ }
+
+ eassert ((base_offset == 0 && buffer->text == &in_buffer->own_text) ||
+ (base_offset > 0 && buffer->text != &in_buffer->own_text));
+
+ struct buffer out;
+ dump_object_start_pseudovector (
+ ctx, &out.header, sizeof (out), &buffer->header);
++ dump_pseudovector_lisp_fields (ctx, &out.header, &buffer->header);
+ if (base_offset == 0)
+ base_offset = ctx->obj_offset;
+ eassert (base_offset > 0);
+ if (buffer->base_buffer == NULL)
+ {
+ eassert (base_offset == ctx->obj_offset);
+
+ if (BUFFER_LIVE_P (buffer))
+ {
+ dump_field_fixup_later (ctx, &out, buffer, &buffer->own_text.beg);
+ dump_remember_cold_op (
+ ctx,
+ COLD_OP_BUFFER,
+ make_lisp_ptr ((void*) in_buffer, Lisp_Vectorlike));
+ }
+ else
+ eassert (buffer->own_text.beg == NULL);
+
+ DUMP_FIELD_COPY (&out, buffer, own_text.gpt);
+ DUMP_FIELD_COPY (&out, buffer, own_text.z);
+ DUMP_FIELD_COPY (&out, buffer, own_text.gpt_byte);
+ DUMP_FIELD_COPY (&out, buffer, own_text.z_byte);
+ DUMP_FIELD_COPY (&out, buffer, own_text.gap_size);
+ DUMP_FIELD_COPY (&out, buffer, own_text.modiff);
+ DUMP_FIELD_COPY (&out, buffer, own_text.chars_modiff);
+ DUMP_FIELD_COPY (&out, buffer, own_text.save_modiff);
+ DUMP_FIELD_COPY (&out, buffer, own_text.overlay_modiff);
+ DUMP_FIELD_COPY (&out, buffer, own_text.compact);
+ DUMP_FIELD_COPY (&out, buffer, own_text.beg_unchanged);
+ DUMP_FIELD_COPY (&out, buffer, own_text.end_unchanged);
+ DUMP_FIELD_COPY (&out, buffer, own_text.unchanged_modified);
+ DUMP_FIELD_COPY (&out, buffer, own_text.overlay_unchanged_modified);
+ if (buffer->own_text.intervals)
+ dump_field_fixup_later (ctx, &out, buffer, &buffer->own_text.intervals);
+ dump_field_lv_rawptr (ctx, &out, buffer, &buffer->own_text.markers,
- Lisp_Misc, WEIGHT_NORMAL);
++ Lisp_Vectorlike, WEIGHT_NORMAL);
+ DUMP_FIELD_COPY (&out, buffer, own_text.inhibit_shrinking);
+ DUMP_FIELD_COPY (&out, buffer, own_text.redisplay);
+ }
+
+ eassert (ctx->obj_offset > 0);
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ ctx->obj_offset + dump_offsetof (struct buffer, text),
+ base_offset + dump_offsetof (struct buffer, own_text));
+
+ dump_field_lv_rawptr (ctx, &out, buffer, &buffer->next,
+ Lisp_Vectorlike, WEIGHT_NORMAL);
+ DUMP_FIELD_COPY (&out, buffer, pt);
+ DUMP_FIELD_COPY (&out, buffer, pt_byte);
+ DUMP_FIELD_COPY (&out, buffer, begv);
+ DUMP_FIELD_COPY (&out, buffer, begv_byte);
+ DUMP_FIELD_COPY (&out, buffer, zv);
+ DUMP_FIELD_COPY (&out, buffer, zv_byte);
+
+ if (buffer->base_buffer)
+ {
+ eassert (ctx->obj_offset != base_offset);
+ dump_field_ptr_to_dump_offset (
+ ctx, &out, buffer, &buffer->base_buffer,
+ base_offset);
+ }
+
+ DUMP_FIELD_COPY (&out, buffer, indirections);
+ DUMP_FIELD_COPY (&out, buffer, window_count);
+
+ memcpy (&out.local_flags,
+ &buffer->local_flags,
+ sizeof (out.local_flags));
+ DUMP_FIELD_COPY (&out, buffer, modtime);
+ DUMP_FIELD_COPY (&out, buffer, modtime_size);
+ DUMP_FIELD_COPY (&out, buffer, auto_save_modified);
+ DUMP_FIELD_COPY (&out, buffer, display_error_modiff);
+ DUMP_FIELD_COPY (&out, buffer, auto_save_failure_time);
+ DUMP_FIELD_COPY (&out, buffer, last_window_start);
+
+ /* Not worth serializing these caches. TODO: really? */
+ out.newline_cache = NULL;
+ out.width_run_cache = NULL;
+ out.bidi_paragraph_cache = NULL;
+
+ DUMP_FIELD_COPY (&out, buffer, prevent_redisplay_optimizations_p);
+ DUMP_FIELD_COPY (&out, buffer, clip_changed);
+
+ dump_field_lv_rawptr (ctx, &out, buffer, &buffer->overlays_before,
- Lisp_Misc, WEIGHT_NORMAL);
++ Lisp_Vectorlike, WEIGHT_NORMAL);
+
+ dump_field_lv_rawptr (ctx, &out, buffer, &buffer->overlays_after,
- dump_vectorlike (struct dump_context *ctx, const struct Lisp_Vector *v)
++ Lisp_Vectorlike, WEIGHT_NORMAL);
+
+ DUMP_FIELD_COPY (&out, buffer, overlay_center);
+ dump_field_lv (ctx, &out, buffer, &buffer->undo_list_,
+ WEIGHT_STRONG);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (!buffer->base_buffer && buffer->own_text.intervals)
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ offset + dump_offsetof (struct buffer, own_text.intervals),
+ dump_interval_tree (ctx, buffer->own_text.intervals, 0));
+
+ return offset;
+}
+
+static dump_off
+dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Vector_2FA5E2F339)
+# error "Lisp_Vector changed. See CHECK_STRUCTS comment."
+#endif
+ /* No relocation needed, so we don't need dump_object_start. */
+ dump_align_output (ctx, GCALIGNMENT);
+ eassert (ctx->offset >= ctx->header.cold_start);
+ dump_off offset = ctx->offset;
+ ptrdiff_t nbytes = vector_nbytes ((struct Lisp_Vector *) v);
+ if (nbytes > DUMP_OFF_T_MAX)
+ error ("vector too large");
+ dump_write (ctx, v, ptrdiff_t_to_dump_off (nbytes));
+ return offset;
+}
+
+static dump_off
+dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_B0DEEE4344)
+# error "Lisp_Subr changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Subr out;
+ dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, subr, header.size);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
+ DUMP_FIELD_COPY (&out, subr, min_args);
+ DUMP_FIELD_COPY (&out, subr, max_args);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
+ DUMP_FIELD_COPY (&out, subr, doc);
+ return dump_object_finish (ctx, &out, sizeof (out));
+}
+
+static void
+fill_pseudovec (union vectorlike_header *header, Lisp_Object item)
+{
+ struct Lisp_Vector *v = (struct Lisp_Vector *) header;
+ eassert (v->header.size & PSEUDOVECTOR_FLAG);
+ ptrdiff_t size = v->header.size & PSEUDOVECTOR_SIZE_MASK;
+ for (ptrdiff_t idx = 0; idx < size; idx++)
+ v->contents[idx] = item;
+}
+
+static dump_off
+dump_nilled_pseudovec (struct dump_context *ctx,
+ const union vectorlike_header *in)
+{
+ if (vector_nbytes ((struct Lisp_Vector *) in) > DUMP_OFF_T_MAX)
+ error ("pseudovector too large");
+ dump_off nbytes = ptrdiff_t_to_dump_off (
+ vector_nbytes ((struct Lisp_Vector *) in));
+ union vectorlike_header *in_nilled = alloca (nbytes);
+ memset (in_nilled, 0, nbytes);
+ in_nilled->size = in->size;
+ fill_pseudovec (in_nilled, Qnil);
+ union vectorlike_header *out = alloca (nbytes);
+ memset (out, 0, nbytes);
+ dump_object_start_pseudovector (ctx, out, nbytes, in_nilled);
++ dump_pseudovector_lisp_fields (ctx, out, in_nilled);
+ return dump_object_finish (ctx, out, nbytes);
+}
+
+static dump_off
- dump_off offset;
- Lisp_Object lv = make_lisp_ptr ((void *) v, Lisp_Vectorlike);
++dump_vectorlike (struct dump_context *ctx,
++ Lisp_Object lv,
++ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_pvec_type_69A8BF53D8)
+# error "pvec_type changed. See CHECK_STRUCTS comment."
+#endif
- offset = dump_hash_table (ctx, (struct Lisp_Hash_Table *) v);
++ const struct Lisp_Vector *v = XVECTOR (lv);
+ switch (PSEUDOVECTOR_TYPE (v))
+ {
+ case PVEC_FONT:
+ /* There are three kinds of font objects that all use PVEC_FONT,
+ distinguished by their size. Font specs and entities are
+ harmless data carriers that we can dump like other Lisp
+ objects. Fonts themselves are window-system-specific and
+ need to be recreated on each startup. */
+ if ((v->header.size & PSEUDOVECTOR_SIZE_MASK) != FONT_SPEC_MAX &&
+ (v->header.size & PSEUDOVECTOR_SIZE_MASK) != FONT_ENTITY_MAX)
+ error_unsupported_dump_object(ctx, lv, "font");
+ FALLTHROUGH;
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_COMPILED:
+ case PVEC_CHAR_TABLE:
+ case PVEC_SUB_CHAR_TABLE:
+ case PVEC_RECORD:
+ offset = dump_vectorlike_generic (ctx, &v->header);
+ break;
+ case PVEC_BOOL_VECTOR:
+ offset = dump_bool_vector(ctx, v);
+ break;
+ case PVEC_HASH_TABLE:
- offset = dump_buffer (ctx, (struct buffer *) v);
++ offset = dump_hash_table (ctx, lv, offset);
+ break;
+ case PVEC_BUFFER:
- offset = dump_subr (ctx, (const struct Lisp_Subr *) v);
++ offset = dump_buffer (ctx, XBUFFER (lv));
+ break;
+ case PVEC_SUBR:
- error_unsupported_dump_object (ctx, lv, "threading object");
++ offset = dump_subr (ctx, XSUBR (lv));
+ break;
+ case PVEC_FRAME:
+ case PVEC_WINDOW:
+ case PVEC_PROCESS:
+ case PVEC_TERMINAL:
+ offset = dump_nilled_pseudovec (ctx, &v->header);
+ break;
++ case PVEC_MARKER:
++ offset = dump_marker (ctx, XMARKER (lv));
++ break;
++ case PVEC_OVERLAY:
++ offset = dump_overlay (ctx, XOVERLAY (lv));
++ break;
++ case PVEC_FINALIZER:
++ offset = dump_finalizer (ctx, XFINALIZER (lv));
++ break;
+ case PVEC_WINDOW_CONFIGURATION:
+ error_unsupported_dump_object (ctx, lv, "window configuration");
+ case PVEC_OTHER:
+ error_unsupported_dump_object (ctx, lv, "other?!");
+ case PVEC_XWIDGET:
+ error_unsupported_dump_object (ctx, lv, "xwidget");
+ case PVEC_XWIDGET_VIEW:
+ error_unsupported_dump_object (ctx, lv, "xwidget view");
++ case PVEC_BIGNUM:
++ error_unsupported_dump_object (ctx, lv, "bignum");
++ case PVEC_MISC_PTR:
++#ifdef HAVE_MODULES
++ case PVEC_USER_PTR:
++#endif
++ error_unsupported_dump_object (ctx, lv, "smuggled pointers");
+ case PVEC_THREAD:
++ if (main_thread_p (v))
++ {
++ eassert (dump_object_emacs_ptr (lv));
++ return DUMP_OBJECT_IS_RUNTIME_MAGIC;
++ }
++ error_unsupported_dump_object (ctx, lv, "thread");
+ case PVEC_MUTEX:
++ error_unsupported_dump_object (ctx, lv, "mutex");
+ case PVEC_CONDVAR:
- /* Internal guts of dump_object().
++ error_unsupported_dump_object (ctx, lv, "condvar");
+ case PVEC_MODULE_FUNCTION:
+ error_unsupported_dump_object (ctx, lv, "module function");
+ default:
+ error_unsupported_dump_object(ctx, lv, "weird pseudovector");
+ }
+
+ return offset;
+}
+
- This function has the same contract as dump_object(), except that
- it doesn't defer copying dumped objects (instead, dumping them
- immediately) and always returns a valid offset.
++/* Add an object to the dump.
++
++ CTX is the dump context; OBJECT is the object to add. Normally,
++ return OFFSET, the location (in bytes, from the start of the dump
++ file) where we wrote the object. Valid OFFSETs are always greater
++ than zero.
++
++ If we've already dumped an object, return the location where we put
++ it: dump_object is idempotent.
+
- Called directly by dump_copied_objects() to bypass dump_object()'s
- check for copied objects.
++ The object must refer to an actual pointer-ish object of some sort.
++ Some self-representing objects are immediate values rather than
++ tagged pointers to Lisp heap structures and so have no individual
++ representation in the Lisp heap dump.
+
- dump_object_1 (struct dump_context *ctx, Lisp_Object object)
++ May also return one of the DUMP_OBJECT_ON_*_QUEUE constants if we
++ "dumped" the object by remembering to process it specially later.
++ In this case, we don't have a valid offset.
++ Call dump_object_for_offset if you need a valid offset for
++ an object.
+ */
+static dump_off
- {
- /* Object already dumped. */
- }
- else
- {
- /* Object needs to be dumped. */
- DUMP_SET_REFERRER (ctx, object);
- switch (XTYPE (object))
- {
- case Lisp_String:
- offset = dump_string (ctx, XSTRING (object));
- break;
- case Lisp_Vectorlike:
- offset = dump_vectorlike (ctx, XVECTOR (object));
- break;
- case Lisp_Symbol:
- offset = dump_symbol (ctx, XSYMBOL (object));
- break;
- case Lisp_Misc:
- offset = dump_misc_any (ctx, XMISCANY (object));
- break;
- case Lisp_Cons:
- offset = dump_cons (ctx, XCONS (object));
- break;
- case Lisp_Float:
- offset = dump_float (ctx, XFLOAT (object));
- break;
- case_Lisp_Int:
- eassert ("should not be dumping int: is self-representing" && 0);
- abort ();
- default:
- emacs_abort ();
- }
- DUMP_CLEAR_REFERRER (ctx);
++dump_object (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_C9E246F617)
+# error "Lisp_Type changed. See CHECK_STRUCTS comment."
+#endif
+#ifdef ENABLE_CHECKING
+ /* Vdead is extern only when ENABLE_CHECKING. */
+ eassert (!EQ (object, Vdead));
+#endif
++
+ dump_off offset = dump_recall_object (ctx, object);
+ if (offset > 0)
- /* offset can be < 0 if we've deferred an object --- e.g., a
- hash table. */
- if (ctx->flags.dump_object_contents && offset > 0)
++ return offset; /* Object already dumped. */
+
- eassert (offset % (1<<DUMP_RELOC_ALIGNMENT_BITS) == 0);
++ bool cold = BOOL_VECTOR_P (object) || FLOATP (object);
++ if (cold && ctx->flags.defer_cold_objects)
++ {
++ if (offset != DUMP_OBJECT_ON_COLD_QUEUE)
+ {
- if (ctx->flags.dump_object_starts)
- dump_push (&ctx->object_starts,
- list2 (dump_off_to_lisp (XTYPE (object)),
- dump_off_to_lisp (offset)));
++ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE ||
++ offset == DUMP_OBJECT_NOT_SEEN);
++ offset = DUMP_OBJECT_ON_COLD_QUEUE;
+ dump_remember_object (ctx, object, offset);
- return offset;
- }
-
- /* Add an object to the dump.
-
- CTX is the dump context; OBJECT is the object to add. Normally,
- return OFFSET, the location (in bytes, from the start of the dump
- file) where we wrote the object. Valid OFFSETs are always greater
- than zero.
-
- If we've already dumped an object, return the location where we put
- it: dump_object is idempotent.
-
- The object may not be self-representing. Self-representing objects
- are immediate values rather than tagged pointers to Lisp heap
- structures and so have no individual representation in the Lisp
- heap dump.
-
- May also return DUMP_OBJECT_DEFERRED if we "dumped" the
- object by remembering to process it specially later. In this case,
- we don't have a valid offset. Call dump_object_for_offset if you
- need a valid offset for an object.
- */
- static dump_off
- dump_object (struct dump_context *ctx, Lisp_Object object)
- {
- dump_off result;
-
- if (dump_object_emacs_ptr (object) == NULL)
- {
- eassert (!dump_object_self_representing_p (object));
- result = dump_object_1 (ctx, object);
- }
- else
++ dump_remember_cold_op (ctx, COLD_OP_OBJECT, object);
+ }
++ return offset;
+ }
+
- /* Objects that are part of the Emacs image need to be copied
- into that image from the dump image, so handle them
- specially. */
- result = dump_recall_object (ctx, object);
-
- /* We should not have written a copied object normally due to
- the above constraint. This object must either be on some
- queue or not yet seen. */
- eassert (result == DUMP_OBJECT_NOT_SEEN ||
- result == DUMP_OBJECT_ON_NORMAL_QUEUE ||
- result == DUMP_OBJECT_DEFERRED);
- if (result != DUMP_OBJECT_DEFERRED)
++ void* obj_in_emacs = dump_object_emacs_ptr (object);
++ if (obj_in_emacs && ctx->flags.defer_copied_objects)
+ {
- /* Remember to dump this object in the special copied
- objects section. */
- dump_push (&ctx->copied_queue, object);
- result = DUMP_OBJECT_DEFERRED;
- dump_remember_object (ctx, object, result);
-
- /* But scan the object for objects to which it refers. */
++ if (offset != DUMP_OBJECT_ON_COPIED_QUEUE)
+ {
- dump_object_1 (ctx, object);
++ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE ||
++ offset == DUMP_OBJECT_NOT_SEEN);
++ /* Even though we're not going to dump this object right
++ away, we still want to scan and enqueue its
++ referents. */
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.dump_object_contents = false;
- return result;
++ ctx->flags.defer_copied_objects = false;
++ dump_object (ctx, object);
+ ctx->flags = old_flags;
++
++ offset = DUMP_OBJECT_ON_COPIED_QUEUE;
++ dump_remember_object (ctx, object, offset);
++ dump_push (&ctx->copied_queue, object);
+ }
++ return offset;
+ }
+
- dump_emacs_reloc_immediate_int (
- ctx, &charset_table_used, charset_table_used);
- dump_emacs_reloc_immediate_ptrdiff_t (
- ctx, &charset_table_size, charset_table_used);
++ /* Object needs to be dumped. */
++ DUMP_SET_REFERRER (ctx, object);
++ switch (XTYPE (object))
++ {
++ case Lisp_String:
++ offset = dump_string (ctx, XSTRING (object));
++ break;
++ case Lisp_Vectorlike:
++ offset = dump_vectorlike (ctx, object, offset);
++ break;
++ case Lisp_Symbol:
++ offset = dump_symbol (ctx, object, offset);
++ break;
++ case Lisp_Cons:
++ offset = dump_cons (ctx, XCONS (object));
++ break;
++ case Lisp_Float:
++ offset = dump_float (ctx, XFLOAT (object));
++ break;
++ case_Lisp_Int:
++ eassert ("should not be dumping int: is self-representing" && 0);
++ abort ();
++ default:
++ emacs_abort ();
++ }
++ DUMP_CLEAR_REFERRER (ctx);
++
++ /* offset can be < 0 if we've deferred an object. */
++ if (ctx->flags.dump_object_contents && offset > 0)
++ {
++ eassert (offset % (1<<DUMP_RELOC_ALIGNMENT_BITS) == 0);
++ dump_remember_object (ctx, object, offset);
++ if (ctx->flags.record_object_starts)
++ dump_push (&ctx->object_starts,
++ list2 (dump_off_to_lisp (XTYPE (object)),
++ dump_off_to_lisp (offset)));
++ }
++
++ return offset;
+}
+
+/* Like dump_object(), but assert that we get a valid offset. */
+static dump_off
+dump_object_for_offset (struct dump_context *ctx, Lisp_Object object)
+{
+ dump_off offset = dump_object (ctx, object);
+ eassert (offset > 0);
+ return offset;
+}
+
+static dump_off
+dump_charset (struct dump_context *ctx, int cs_i)
+{
+#if CHECK_STRUCTS && !defined (HASH_charset_317C49E291)
+# error "charset changed. See CHECK_STRUCTS comment."
+#endif
+ const struct charset *cs = charset_table + cs_i;
+ struct charset out;
+ dump_object_start (ctx, sizeof (int), &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, cs, id);
+ DUMP_FIELD_COPY (&out, cs, hash_index);
+ DUMP_FIELD_COPY (&out, cs, dimension);
+ memcpy (out.code_space, &cs->code_space, sizeof (cs->code_space));
+ if (cs->code_space_mask)
+ dump_field_fixup_later (ctx, &out, cs, &cs->code_space_mask);
+ DUMP_FIELD_COPY (&out, cs, code_linear_p);
+ DUMP_FIELD_COPY (&out, cs, iso_chars_96);
+ DUMP_FIELD_COPY (&out, cs, ascii_compatible_p);
+ DUMP_FIELD_COPY (&out, cs, supplementary_p);
+ DUMP_FIELD_COPY (&out, cs, compact_codes_p);
+ DUMP_FIELD_COPY (&out, cs, unified_p);
+ DUMP_FIELD_COPY (&out, cs, iso_final);
+ DUMP_FIELD_COPY (&out, cs, iso_revision);
+ DUMP_FIELD_COPY (&out, cs, emacs_mule_id);
+ DUMP_FIELD_COPY (&out, cs, method);
+ DUMP_FIELD_COPY (&out, cs, min_code);
+ DUMP_FIELD_COPY (&out, cs, max_code);
+ DUMP_FIELD_COPY (&out, cs, char_index_offset);
+ DUMP_FIELD_COPY (&out, cs, min_char);
+ DUMP_FIELD_COPY (&out, cs, max_char);
+ DUMP_FIELD_COPY (&out, cs, invalid_code);
+ memcpy (out.fast_map, &cs->fast_map, sizeof (cs->fast_map));
+ DUMP_FIELD_COPY (&out, cs, code_offset);
+ dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
+ if (cs->code_space_mask)
+ dump_remember_cold_op (ctx, COLD_OP_CHARSET,
+ Fcons (dump_off_to_lisp (cs_i),
+ dump_off_to_lisp (offset)));
+ return offset;
+}
+
+static dump_off
+dump_charset_table (struct dump_context *ctx)
+{
+ dump_align_output (ctx, GCALIGNMENT);
+ dump_off offset = ctx->offset;
+ for (int i = 0; i < charset_table_used; ++i)
+ dump_charset (ctx, i);
+ dump_emacs_reloc_to_dump_ptr_raw (ctx, &charset_table, offset);
- dump_object_for_offset (ctx, make_lisp_ptr (value, Lisp_Misc)));
+ return offset;
+}
+
+static void
+dump_finalizer_list_head_ptr (struct dump_context *ctx,
+ struct Lisp_Finalizer **ptr)
+{
+ struct Lisp_Finalizer *value = *ptr;
+ if (value != &finalizers && value != &doomed_finalizers)
+ dump_emacs_reloc_to_dump_ptr_raw (
+ ctx, ptr,
- Fsort (Fnreverse (
- ctx->copied_queue),
++ dump_object_for_offset (ctx,
++ make_lisp_ptr (value, Lisp_Vectorlike)));
+}
+
+static void
+dump_metadata_for_pdumper (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_dump_hooks; ++i)
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &dump_hooks[i], dump_hooks[i]);
+ dump_emacs_reloc_immediate_int (ctx, &nr_dump_hooks, nr_dump_hooks);
+
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ dump_emacs_reloc_to_emacs_ptr_raw (
+ ctx,
+ &remembered_data[i].mem,
+ remembered_data[i].mem);
+ dump_emacs_reloc_immediate_int (
+ ctx,
+ &remembered_data[i].sz,
+ remembered_data[i].sz);
+ }
+ dump_emacs_reloc_immediate_int (
+ ctx,
+ &nr_remembered_data,
+ nr_remembered_data);
+}
+
+/* Sort the list of copied objects in CTX. */
+static void
+dump_sort_copied_objects (struct dump_context *ctx)
+{
+ /* Sort the objects into the order in which they'll appear in the
+ Emacs: this way, on startup, we'll do both the IO from the dump
+ file and the copy into Emacs in-order, where prefetch will be
+ most effective. */
+ ctx->copied_queue =
- dump_copied_objects (struct dump_context *ctx)
++ Fsort (Fnreverse (ctx->copied_queue),
+ Qdump_emacs_portable__sort_predicate_copied);
+}
+
+/* Dump parts of copied objects we need at runtime. */
+static void
+dump_hot_parts_of_discardable_objects (struct dump_context *ctx)
+{
+ Lisp_Object copied_queue = ctx->copied_queue;
+ while (!NILP (copied_queue))
+ {
+ Lisp_Object copied = dump_pop (&copied_queue);
+ if (SYMBOLP (copied))
+ {
+ eassert (dump_builtin_symbol_p (copied));
+ dump_pre_dump_symbol (ctx, XSYMBOL (copied));
+ }
+ }
+}
+
+static void
- The overfall result is that to the greatest extent possible while
++dump_drain_copied_objects (struct dump_context *ctx)
+{
+ Lisp_Object copied_queue = ctx->copied_queue;
+ ctx->copied_queue = Qnil;
++
++ struct dump_flags old_flags = ctx->flags;
++
++ /* We should have already fully scanned these objects, so assert
++ that we're not adding more entries to the dump queue. */
++ ctx->flags.assert_already_seen = true;
++
++ /* Now we want to actually dump the copied objects, not just record
++ them. */
++ ctx->flags.defer_copied_objects = false;
++
++ /* Objects that we memcpy into Emacs shouldn't get object-start
++ records (which conservative GC looks at): we usually discard this
++ memory after we're finished memcpying, and even if we don't, the
++ "real" objects in this section all live in the Emacs image, not
++ in the dump. */
++ ctx->flags.record_object_starts = false;
++
+ /* Dump the objects and generate a copy relocation for each. Don't
+ bother trying to reduce the number of copy relocations we
+ generate: we'll merge adjacent copy relocations upon output.
-
- /* We should have already fully scanned these objects, so assert
- that we're not adding more entries to the dump queue. */
- struct dump_flags old_flags = ctx->flags;
- ctx->flags.assert_already_seen = true;
- dump_off start_offset = dump_object_1 (ctx, copied);
- ctx->flags = old_flags;
-
- dump_off size = ctx->offset - start_offset;
- dump_emacs_reloc_copy_from_dump (ctx, start_offset, optr, size);
++ The overall result is that to the greatest extent possible while
+ maintaining strictly increasing address order, we copy into Emacs
+ in nice big chunks. */
+ while (!NILP (copied_queue))
+ {
+ Lisp_Object copied = dump_pop (&copied_queue);
+ void *optr = dump_object_emacs_ptr (copied);
+ eassert (optr != NULL);
- int cs_i = XFASTINT (XCAR (data));
++ /* N.B. start_offset is beyond any padding we insert. */
++ dump_off start_offset = dump_object (ctx, copied);
++ if (start_offset != DUMP_OBJECT_IS_RUNTIME_MAGIC)
++ {
++ dump_off size = ctx->offset - start_offset;
++ dump_emacs_reloc_copy_from_dump (ctx, start_offset, optr, size);
++ }
+ }
++
++ ctx->flags = old_flags;
+}
+
+static void
+dump_cold_string (struct dump_context *ctx, Lisp_Object string)
+{
+ /* Dump string contents. */
+ dump_off string_offset = dump_recall_object (ctx, string);
+ eassert (string_offset > 0);
+ if (SBYTES (string) > DUMP_OFF_T_MAX - 1)
+ error ("string too large");
+ dump_off total_size = ptrdiff_t_to_dump_off (SBYTES (string) + 1);
+ eassert (total_size > 0);
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ string_offset + dump_offsetof (struct Lisp_String, u.s.data),
+ ctx->offset);
+ dump_write (ctx, XSTRING (string)->u.s.data, total_size);
+}
+
+static void
+dump_cold_charset (struct dump_context *ctx, Lisp_Object data)
+{
+ /* Dump charset lookup tables. */
+ ALLOW_IMPLICIT_CONVERSION;
- dump_cold_data (struct dump_context *ctx)
++ int cs_i = XFIXNUM (XCAR (data));
+ DISALLOW_IMPLICIT_CONVERSION;
+ dump_off cs_dump_offset = dump_off_from_lisp (XCDR (data));
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ cs_dump_offset + dump_offsetof (struct charset, code_space_mask),
+ ctx->offset);
+ struct charset *cs = charset_table + cs_i;
+ dump_write (ctx, cs->code_space_mask, 256);
+}
+
+static void
+dump_cold_buffer (struct dump_context *ctx, Lisp_Object data)
+{
+ /* Dump buffer text. */
+ dump_off buffer_offset = dump_recall_object (ctx, data);
+ eassert (buffer_offset > 0);
+ struct buffer *b = XBUFFER (data);
+ eassert (b->text == &b->own_text);
+ /* Zero the gap so we don't dump uninitialized bytes. */
+ memset (BUF_GPT_ADDR (b), 0, BUF_GAP_SIZE (b));
+ /* See buffer.c for this calculation. */
+ ptrdiff_t nbytes =
+ BUF_Z_BYTE (b)
+ - BUF_BEG_BYTE (b)
+ + BUF_GAP_SIZE (b)
+ + 1;
+ if (nbytes > DUMP_OFF_T_MAX)
+ error ("buffer too large");
+ dump_remember_fixup_ptr_raw (
+ ctx,
+ buffer_offset + dump_offsetof (struct buffer, own_text.beg),
+ ctx->offset);
+ dump_write (ctx, b->own_text.beg, ptrdiff_t_to_dump_off (nbytes));
+}
+
+static void
- struct dump_flags old_flags = ctx->flags;
++dump_drain_cold_data (struct dump_context *ctx)
+{
+ Lisp_Object cold_queue = Fnreverse (ctx->cold_queue);
+ ctx->cold_queue = Qnil;
+
++ struct dump_flags old_flags = ctx->flags;
++
+ /* We should have already scanned all objects to which our cold
+ objects refer, so die if an object points to something we haven't
+ seen. */
- enum cold_op op = (enum cold_op) XFASTINT (XCAR (item));
+ ctx->flags.assert_already_seen = true;
+
++ /* Actually dump cold objects instead of deferring them. */
++ ctx->flags.defer_cold_objects = false;
++
+ while (!NILP (cold_queue))
+ {
+ Lisp_Object item = dump_pop (&cold_queue);
- case Lisp_Misc:
++ enum cold_op op = (enum cold_op) XFIXNUM (XCAR (item));
+ Lisp_Object data = XCDR (item);
+ switch (op)
+ {
+ case COLD_OP_STRING:
+ dump_cold_string (ctx, data);
+ break;
+ case COLD_OP_CHARSET:
+ dump_cold_charset (ctx, data);
+ break;
+ case COLD_OP_BUFFER:
+ dump_cold_buffer (ctx, data);
+ break;
+ case COLD_OP_OBJECT:
+ /* Objects that we can put in the cold section
+ must not refer to other objects. */
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+ eassert (ctx->flags.dump_object_contents);
+ dump_object (ctx, data);
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+
+ ctx->flags = old_flags;
+}
+
+static void
+read_ptr_raw_and_lv (const void *mem,
+ enum Lisp_Type type,
+ void **out_ptr,
+ Lisp_Object *out_lv)
+{
+ memcpy (out_ptr, mem, sizeof (*out_ptr));
+ if (*out_ptr != NULL)
+ {
+ switch (type)
+ {
+ case Lisp_Symbol:
+ *out_lv = make_lisp_symbol (*out_ptr);
+ break;
- dump_user_remembered_data_hot (struct dump_context *ctx)
+ case Lisp_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ *out_lv = make_lisp_ptr (*out_ptr, type);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+}
+
+/* Enqueue for dumping objects referenced by static non-Lisp_Object
+ pointers inside Emacs. */
+static void
- dump_user_remembered_data_cold (struct dump_context *ctx)
++dump_drain_user_remembered_data_hot (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ void *mem = remembered_data[i].mem;
+ int sz = remembered_data[i].sz;
+ if (sz <= 0)
+ {
+ enum Lisp_Type type = -sz;
+ void *value;
+ Lisp_Object lv;
+ read_ptr_raw_and_lv (mem, type, &value, &lv);
+ if (value != NULL)
+ {
+ DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("user data", mem));
+ dump_enqueue_object (ctx, lv, WEIGHT_NONE);
+ DUMP_CLEAR_REFERRER (ctx);
+ }
+ }
+ }
+}
+
+/* Dump user-specified non-relocated data. */
+static void
- and issue a copy relocation. */
++dump_drain_user_remembered_data_cold (struct dump_context *ctx)
+{
+ for (int i = 0; i < nr_remembered_data; ++i)
+ {
+ void *mem = remembered_data[i].mem;
+ int sz = remembered_data[i].sz;
+ if (sz > 0)
+ {
+ /* Scalar: try to inline the value into the relocation if
+ it's small enough; if it's bigger than we can fit in a
+ relocation, we have to copy the data into the dump proper
- dumped by dump_user_remembered_data_hot. */
++ and emit a copy relocation. */
+ if (sz <= sizeof (intmax_t))
+ dump_emacs_reloc_immediate (ctx, mem, mem, sz);
+ else
+ {
+ dump_emacs_reloc_copy_from_dump (ctx, ctx->offset, mem, sz);
+ dump_write (ctx, mem, sz);
+ }
+ }
+ else
+ {
+ /* *mem is a raw pointer to a Lisp object of some sort.
+ The object to which it points should have already been
-
++ dumped by dump_drain_user_remembered_data_hot. */
+ void *value;
+ Lisp_Object lv;
+ enum Lisp_Type type = -sz;
+ read_ptr_raw_and_lv (mem, type, &value, &lv);
+ if (value == NULL)
+ /* We can't just ignore NULL: the variable might have
+ transitioned from non-NULL to NULL, and we want to
+ record this fact. */
+ dump_emacs_reloc_immediate_ptrdiff_t (ctx, mem, 0);
+ else
+ {
+ if (dump_object_emacs_ptr (lv) != NULL)
+ {
+ /* We have situation like this:
+
+ static Lisp_Symbol *foo;
+ ...
+ foo = XSYMBOL(Qt);
+ ...
+ pdumper_remember_lv_ptr_raw (&foo, Lisp_Symbol);
+
+ Built-in symbols like Qt aren't in the dump!
+ They're actually in Emacs proper. We need a
+ special case to point this value back at Emacs
+ instead of to something in the dump that
+ isn't there.
+
+ An analogous situation applies to subrs, since
+ Lisp_Subr structures always live in Emacs, not
+ the dump.
- static void
- dump_do_fixup (struct dump_context *ctx, Lisp_Object fixup)
- {
- enum dump_fixup_type type =
- (enum dump_fixup_type) XFASTINT (XCAR (fixup));
- fixup = XCDR (fixup);
- dump_off dump_fixup_offset = dump_off_from_lisp (XCAR (fixup));
- fixup = XCDR (fixup);
- Lisp_Object arg = XCAR (fixup);
- eassert (NILP (XCDR (fixup)));
- dump_seek (ctx, dump_fixup_offset);
- intptr_t dump_value;
- bool do_write = true;
- switch (type)
- {
- case DUMP_FIXUP_LISP_OBJECT:
- case DUMP_FIXUP_LISP_OBJECT_RAW:
- /* Dump wants a pointer to a Lisp object.
- If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in
- the dump; otherwise, a Lisp_Object. */
- if (SUBRP (arg))
- {
- dump_value = emacs_offset (XSUBR (arg));
- if (type == DUMP_FIXUP_LISP_OBJECT)
- dump_reloc_dump_to_emacs_lv (ctx, ctx->offset, XTYPE (arg));
- else
- dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
- }
- else if (dump_builtin_symbol_p (arg))
- {
- eassert (dump_object_self_representing_p (arg));
- /* These symbols are part of Emacs, so point there. If we
- want a Lisp_Object, we're set. If we want a raw pointer,
- we need to emit a relocation. */
- if (type == DUMP_FIXUP_LISP_OBJECT)
- {
- do_write = false;
- dump_write (ctx, &arg, sizeof (arg));
- }
- else
- {
- dump_value = emacs_offset (XSYMBOL (arg));
- dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
- }
- }
- else
- {
- eassert (dump_object_emacs_ptr (arg) == NULL);
- dump_value = dump_recall_object (ctx, arg);
- if (dump_value <= 0)
- error ("fixup object not dumped");
- if (type == DUMP_FIXUP_LISP_OBJECT)
- dump_reloc_dump_to_dump_lv (ctx, ctx->offset, XTYPE (arg));
- else
- dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
- }
- break;
- case DUMP_FIXUP_PTR_DUMP_RAW:
- /* Dump wants a raw pointer to something that's not a lisp
- object. It knows the exact location it wants, so just
- believe it. */
- dump_value = dump_off_from_lisp (arg);
- dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
- break;
- default:
- emacs_abort ();
- }
- if (do_write)
- dump_write (ctx, &dump_value, sizeof (dump_value));
- }
-
+ */
+ dump_emacs_reloc_to_emacs_ptr_raw (
+ ctx, mem, dump_object_emacs_ptr (lv));
+ }
+ else
+ {
+ eassert (!dump_object_self_representing_p (lv));
+ dump_off dump_offset = dump_recall_object (ctx, lv);
+ if (dump_offset <= 0)
+ error ("raw-pointer object not dumped?!");
+ dump_emacs_reloc_to_dump_ptr_raw (ctx, mem, dump_offset);
+ }
+ }
+ }
+ }
+}
+
+static void
+dump_unwind_cleanup (void *data)
+{
+ struct dump_context *ctx = data;
+ if (ctx->fd >= 0)
+ emacs_close (ctx->fd);
+#ifdef REL_ALLOC
+ if (ctx->blocked_ralloc)
+ r_alloc_inhibit_buffer_relocation (0);
+#endif
+ Vpurify_flag = ctx->old_purify_flag;
+}
+
- static void
- dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+/* Return DUMP_OFFSET, making sure it is within the heap. */
+static dump_off
+dump_check_dump_off (struct dump_context *ctx, dump_off dump_offset)
+{
+ eassert (dump_offset > 0);
+ if (ctx)
+ eassert (dump_offset < ctx->end_heap);
+ return dump_offset;
+}
+
+static void
+dump_check_emacs_off (dump_off emacs_off)
+{
+ eassert (labs (emacs_off) <= 60*1024*1024);
+}
+
- dump_object_start (ctx, 1, &reloc, sizeof (reloc));
++static struct dump_reloc
++dump_decode_dump_reloc (Lisp_Object lreloc)
+{
+ struct dump_reloc reloc;
- (enum dump_reloc_type) XFASTINT (dump_pop (&lreloc)));
+ dump_reloc_set_type (
+ &reloc,
- dump_check_dump_off (ctx, dump_reloc_get_offset (reloc));
- eassert (NILP (lreloc));
- dump_object_finish (ctx, &reloc, sizeof (reloc));
++ (enum dump_reloc_type) XFIXNUM (dump_pop (&lreloc)));
+ eassert (reloc.type <= RELOC_DUMP_TO_EMACS_LV + Lisp_Float);
+ dump_reloc_set_offset (&reloc, dump_off_from_lisp (dump_pop (&lreloc)));
++ eassert (NILP (lreloc));
++ return reloc;
++}
++
++static void
++dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc)
++{
++ struct dump_reloc reloc;
++ dump_object_start (ctx, 1, &reloc, sizeof (reloc));
++ reloc = dump_decode_dump_reloc (lreloc);
++ dump_check_dump_off (ctx, dump_reloc_get_offset (reloc));
++ dump_object_finish (ctx, &reloc, sizeof (reloc));
+ if (dump_reloc_get_offset (reloc) < ctx->header.discardable_start)
+ ctx->number_hot_relocations += 1;
+ else
+ ctx->number_discardable_relocations += 1;
++}
+
- int type = XFASTINT (dump_pop (&lreloc));
++#ifdef ENABLE_CHECKING
++static Lisp_Object
++dump_check_overlap_dump_reloc (Lisp_Object lreloc_a,
++ Lisp_Object lreloc_b)
++{
++ struct dump_reloc reloc_a = dump_decode_dump_reloc (lreloc_a);
++ struct dump_reloc reloc_b = dump_decode_dump_reloc (lreloc_b);
++ eassert (dump_reloc_get_offset (reloc_a) <
++ dump_reloc_get_offset (reloc_b));
++ return Qnil;
+}
++#endif
+
++/* Translate a Lisp Emacs-relocation descriptor (a list whose first
++ element is one of the EMACS_RELOC_* values, encoded as a fixnum)
++ into an emacs_reloc structure value suitable for writing to the
++ dump file.
++*/
+static struct emacs_reloc
+decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ struct emacs_reloc reloc;
+ memset (&reloc, 0, sizeof (reloc));
+ ALLOW_IMPLICIT_CONVERSION;
- default:
- {
- eassert (RELOC_EMACS_DUMP_LV <= type);
- eassert (type <= RELOC_EMACS_DUMP_LV + Lisp_Float);
- emacs_reloc_set_type (&reloc, RELOC_EMACS_DUMP_LV);
- ALLOW_IMPLICIT_CONVERSION;
- reloc.length = type - RELOC_EMACS_DUMP_LV;
- DISALLOW_IMPLICIT_CONVERSION;
- eassert (reloc.length == type - RELOC_EMACS_DUMP_LV);
- Lisp_Object target_value = dump_pop (&lreloc);
- /* If the object is self-representing,
- dump_emacs_reloc_to_dump_lv didn't do its job.
- dump_emacs_reloc_to_dump_lv should have added a
- RELOC_EMACS_IMMEDIATE relocation instead. */
- eassert (!dump_object_self_representing_p (target_value));
- reloc.u.dump_offset = dump_recall_object (ctx, target_value);
- if (reloc.u.dump_offset <= 0)
- {
- Lisp_Object repr = Fprin1_to_string (target_value, Qnil);
- error ("relocation target was not dumped: %s", SDATA (repr));
- }
- dump_check_dump_off (ctx, reloc.u.dump_offset);
- }
- break;
++ int type = XFIXNUM (dump_pop (&lreloc));
+ DISALLOW_IMPLICIT_CONVERSION;
+ reloc.emacs_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_emacs_off (reloc.emacs_offset);
+ switch (type)
+ {
+ case RELOC_EMACS_COPY_FROM_DUMP:
+ {
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_dump_off (ctx, reloc.u.dump_offset);
+ dump_off length = dump_off_from_lisp (dump_pop (&lreloc));
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc.length = length;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (reloc.length != length)
+ error ("relocation copy length too large");
+ }
+ break;
+ case RELOC_EMACS_IMMEDIATE:
+ {
+ emacs_reloc_set_type (&reloc, type);
+ intmax_t value = intmax_t_from_lisp (dump_pop (&lreloc));
+ dump_off size = dump_off_from_lisp (dump_pop (&lreloc));
+ reloc.u.immediate = value;
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc.length = size;
+ DISALLOW_IMPLICIT_CONVERSION;
+ eassert (reloc.length == size);
+ }
+ break;
- if (XFASTINT (XCAR (lreloc_a)) != RELOC_EMACS_COPY_FROM_DUMP ||
- XFASTINT (XCAR (lreloc_b)) != RELOC_EMACS_COPY_FROM_DUMP)
+ case RELOC_EMACS_EMACS_PTR_RAW:
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.emacs_offset2 = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_emacs_off (reloc.u.emacs_offset2);
+ break;
+ case RELOC_EMACS_DUMP_PTR_RAW:
+ emacs_reloc_set_type (&reloc, type);
+ reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc));
+ dump_check_dump_off (ctx, reloc.u.dump_offset);
+ break;
++ case RELOC_EMACS_DUMP_LV:
++ case RELOC_EMACS_EMACS_LV:
++ {
++ emacs_reloc_set_type (&reloc, type);
++ Lisp_Object target_value = dump_pop (&lreloc);
++ /* If the object is self-representing,
++ dump_emacs_reloc_to_lv didn't do its job.
++ dump_emacs_reloc_to_lv should have added a
++ RELOC_EMACS_IMMEDIATE relocation instead. */
++ eassert (!dump_object_self_representing_p (target_value));
++ int tag_type = XTYPE (target_value);
++ ALLOW_IMPLICIT_CONVERSION;
++ reloc.length = tag_type;
++ DISALLOW_IMPLICIT_CONVERSION;
++ eassert (reloc.length == tag_type);
++
++ if (type == RELOC_EMACS_EMACS_LV)
++ {
++ void *obj_in_emacs = dump_object_emacs_ptr (target_value);
++ eassert (obj_in_emacs);
++ reloc.u.emacs_offset2 = emacs_offset (obj_in_emacs);
++ }
++ else
++ {
++ eassert (!dump_object_emacs_ptr (target_value));
++ reloc.u.dump_offset = dump_recall_object (ctx, target_value);
++ if (reloc.u.dump_offset <= 0)
++ {
++ Lisp_Object repr = Fprin1_to_string (target_value, Qnil);
++ error ("relocation target was not dumped: %s", SDATA (repr));
++ }
++ dump_check_dump_off (ctx, reloc.u.dump_offset);
++ }
++ }
++ break;
++ default:
++ eassume (!"not reached");
+ }
+
++ /* We should have consumed the whole relocation descriptor. */
+ eassert (NILP (lreloc));
++
+ return reloc;
+}
+
+static void
+dump_emit_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ struct emacs_reloc reloc;
+ dump_object_start (ctx, 1, &reloc, sizeof (reloc));
+ reloc = decode_emacs_reloc (ctx, lreloc);
+ dump_object_finish (ctx, &reloc, sizeof (reloc));
+}
+
+static Lisp_Object
+dump_merge_emacs_relocs (Lisp_Object lreloc_a, Lisp_Object lreloc_b)
+{
+ /* Combine copy relocations together if they're copying from
+ adjacent chunks to adjacent chunks. */
+
- return list4 (make_number (RELOC_EMACS_COPY_FROM_DUMP),
++#ifdef ENABLE_CHECKING
++ {
++ dump_off off_a = dump_off_from_lisp (XCAR (XCDR (lreloc_a)));
++ dump_off off_b = dump_off_from_lisp (XCAR (XCDR (lreloc_b)));
++ eassert (off_a <= off_b); /* Catch sort errors. */
++ eassert (off_a < off_b); /* Catch duplicate relocations. */
++ }
++#endif
++
++ if (XFIXNUM (XCAR (lreloc_a)) != RELOC_EMACS_COPY_FROM_DUMP ||
++ XFIXNUM (XCAR (lreloc_b)) != RELOC_EMACS_COPY_FROM_DUMP)
+ return Qnil;
+
+ struct emacs_reloc reloc_a = decode_emacs_reloc (NULL, lreloc_a);
+ struct emacs_reloc reloc_b = decode_emacs_reloc (NULL, lreloc_b);
+
+ eassert (reloc_a.type == RELOC_EMACS_COPY_FROM_DUMP);
+ eassert (reloc_b.type == RELOC_EMACS_COPY_FROM_DUMP);
+
+ if (reloc_a.emacs_offset + reloc_a.length != reloc_b.emacs_offset)
+ return Qnil;
+
+ if (reloc_a.u.dump_offset + reloc_a.length != reloc_b.u.dump_offset)
+ return Qnil;
+
+ dump_off new_length = reloc_a.length + reloc_b.length;
+ ALLOW_IMPLICIT_CONVERSION;
+ reloc_a.length = new_length;
+ DISALLOW_IMPLICIT_CONVERSION;
+ if (reloc_a.length != new_length)
+ return Qnil; /* Overflow */
+
- void (*handler)(struct dump_context *, Lisp_Object),
- Lisp_Object (*merger)(Lisp_Object a, Lisp_Object b),
++ return list4 (make_fixnum (RELOC_EMACS_COPY_FROM_DUMP),
+ dump_off_to_lisp (reloc_a.emacs_offset),
+ dump_off_to_lisp (reloc_a.u.dump_offset),
+ dump_off_to_lisp (reloc_a.length));
+}
+
++typedef void (*drain_reloc_handler)(struct dump_context *, Lisp_Object);
++typedef Lisp_Object (*drain_reloc_merger)(Lisp_Object a, Lisp_Object b);
++
+static void
+drain_reloc_list (struct dump_context *ctx,
- dump_do_fixup (ctx, dump_pop (&fixups));
++ drain_reloc_handler handler,
++ drain_reloc_merger merger,
+ Lisp_Object *reloc_list,
+ struct dump_table_locator *out_locator)
+{
+ Lisp_Object relocs = Fsort (Fnreverse (*reloc_list),
+ Qdump_emacs_portable__sort_predicate);
+ *reloc_list = Qnil;
+ dump_align_output (ctx, sizeof (dump_off));
+ struct dump_table_locator locator;
+ memset (&locator, 0, sizeof (locator));
+ locator.offset = ctx->offset;
+ for (; !NILP (relocs); locator.nr_entries += 1)
+ {
+ Lisp_Object reloc = dump_pop (&relocs);
+ Lisp_Object merged;
+ while (merger != NULL &&
+ !NILP (relocs) &&
+ ((merged = merger (reloc, XCAR (relocs))), !NILP (merged)))
+ {
+ reloc = merged;
+ relocs = XCDR (relocs);
+ }
+ handler (ctx, reloc);
+ }
+ *out_locator = locator;
+}
+
++static void
++dump_do_fixup (struct dump_context *ctx,
++ Lisp_Object fixup,
++ Lisp_Object prev_fixup)
++{
++ enum dump_fixup_type type =
++ (enum dump_fixup_type) XFIXNUM (XCAR (fixup));
++ fixup = XCDR (fixup);
++ dump_off dump_fixup_offset = dump_off_from_lisp (XCAR (fixup));
++
++#ifdef ENABLE_CHECKING
++ if (!NILP (prev_fixup))
++ {
++ dump_off prev_dump_fixup_offset =
++ dump_off_from_lisp (XCAR (XCDR (prev_fixup)));
++ eassert (dump_fixup_offset - prev_dump_fixup_offset
++ >= sizeof (void*));
++ }
++#endif
++
++ fixup = XCDR (fixup);
++ Lisp_Object arg = XCAR (fixup);
++ eassert (NILP (XCDR (fixup)));
++ dump_seek (ctx, dump_fixup_offset);
++ intptr_t dump_value;
++ bool do_write = true;
++ switch (type)
++ {
++ case DUMP_FIXUP_LISP_OBJECT:
++ case DUMP_FIXUP_LISP_OBJECT_RAW:
++ /* Dump wants a pointer to a Lisp object.
++ If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in
++ the dump; otherwise, a Lisp_Object. */
++ if (SUBRP (arg))
++ {
++ dump_value = emacs_offset (XSUBR (arg));
++ if (type == DUMP_FIXUP_LISP_OBJECT)
++ dump_reloc_dump_to_emacs_lv (ctx, ctx->offset, XTYPE (arg));
++ else
++ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
++ }
++ else if (dump_builtin_symbol_p (arg))
++ {
++ eassert (dump_object_self_representing_p (arg));
++ /* These symbols are part of Emacs, so point there. If we
++ want a Lisp_Object, we're set. If we want a raw pointer,
++ we need to emit a relocation. */
++ if (type == DUMP_FIXUP_LISP_OBJECT)
++ {
++ do_write = false;
++ dump_write (ctx, &arg, sizeof (arg));
++ }
++ else
++ {
++ dump_value = emacs_offset (XSYMBOL (arg));
++ dump_reloc_dump_to_emacs_ptr_raw (ctx, ctx->offset);
++ }
++ }
++ else
++ {
++ eassert (dump_object_emacs_ptr (arg) == NULL);
++ dump_value = dump_recall_object (ctx, arg);
++ if (dump_value <= 0)
++ error ("fixup object not dumped");
++ if (type == DUMP_FIXUP_LISP_OBJECT)
++ dump_reloc_dump_to_dump_lv (ctx, ctx->offset, XTYPE (arg));
++ else
++ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
++ }
++ break;
++ case DUMP_FIXUP_PTR_DUMP_RAW:
++ /* Dump wants a raw pointer to something that's not a lisp
++ object. It knows the exact location it wants, so just
++ believe it. */
++ dump_value = dump_off_from_lisp (arg);
++ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->offset);
++ break;
++ default:
++ emacs_abort ();
++ }
++ if (do_write)
++ dump_write (ctx, &dump_value, sizeof (dump_value));
++}
++
+static void
+dump_do_fixups (struct dump_context *ctx)
+{
+ dump_off saved_offset = ctx->offset;
+ Lisp_Object fixups = Fsort (Fnreverse (ctx->fixups),
+ Qdump_emacs_portable__sort_predicate);
++ Lisp_Object prev_fixup = Qnil;
+ ctx->fixups = Qnil;
+ while (!NILP (fixups))
- ctx->flags.dump_object_starts = true;
++ {
++ Lisp_Object fixup = dump_pop (&fixups);
++ dump_do_fixup (ctx, fixup, prev_fixup);
++ prev_fixup = fixup;
++ }
+ dump_seek (ctx, saved_offset);
+}
+
++static void
++dump_drain_normal_queue (struct dump_context *ctx)
++{
++ while (!dump_queue_empty_p (&ctx->dump_queue))
++ dump_object (ctx, dump_queue_dequeue (&ctx->dump_queue, ctx->offset));
++}
++
++static void
++dump_drain_deferred_hash_tables (struct dump_context *ctx)
++{
++ struct dump_flags old_flags = ctx->flags;
++
++ /* Now we want to actually write the hash tables. */
++ ctx->flags.defer_hash_tables = false;
++
++ Lisp_Object deferred_hash_tables = Fnreverse (ctx->deferred_hash_tables);
++ ctx->deferred_hash_tables = Qnil;
++ while (!NILP (deferred_hash_tables))
++ dump_object (ctx, dump_pop (&deferred_hash_tables));
++ ctx->flags = old_flags;
++}
++
++static void
++dump_drain_deferred_symbols (struct dump_context *ctx)
++{
++ struct dump_flags old_flags = ctx->flags;
++
++ /* Now we want to actually write the symbols. */
++ ctx->flags.defer_symbols = false;
++
++ Lisp_Object deferred_symbols = Fnreverse (ctx->deferred_symbols);
++ ctx->deferred_symbols = Qnil;
++ while (!NILP (deferred_symbols))
++ dump_object (ctx, dump_pop (&deferred_symbols));
++ ctx->flags = old_flags;
++}
++
+DEFUN ("dump-emacs-portable",
+ Fdump_emacs_portable, Sdump_emacs_portable,
+ 1, 2, 0,
+ doc: /* Dump current state of Emacs into dump file FILENAME.
+If TRACK-REFERRERS is non-nil, keep additional debugging information
+that can help track down the provenance of unsupported object
+types. */)
+ (Lisp_Object filename, Lisp_Object track_referrers)
+{
+ eassert (initialized);
+
+ if (will_dump_with_unexec_p ())
+ error ("This Emacs instance was started under the assumption "
+ "that it would be dumped with unexec, not the portable "
+ "dumper. Dumping with the portable dumper may produce "
+ "unexpected results.");
+
++ // XXX: check that we have no other threads running
+ if (!main_thread_p (current_thread))
+ error ("Function can be called only on main thread");
+
+ /* Clear out any detritus in memory. */
+ do {
+ number_finalizers_run = 0;
+ Fgarbage_collect ();
+ } while (number_finalizers_run);
+
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ /* Bind `command-line-processed' to nil before dumping,
+ so that the dumped Emacs will process its command line
+ and set up to work with X windows if appropriate. */
+ Lisp_Object symbol = intern ("command-line-processed");
+ specbind (symbol, Qnil);
+
+ CHECK_STRING (filename);
+ filename = Fexpand_file_name (filename, Qnil);
+ filename = ENCODE_FILE (filename);
+
+ struct dump_context ctx_buf;
+ struct dump_context *ctx = &ctx_buf;
+ memset (ctx, 0, sizeof (*ctx));
+ ctx->fd = -1;
+
+ ctx->objects_dumped = make_eq_hash_table ();
+ dump_queue_init (&ctx->dump_queue);
+ ctx->deferred_hash_tables = Qnil;
+ ctx->deferred_symbols = Qnil;
++
+ ctx->fixups = Qnil;
++ ctx->staticpro_table = CALLN (Fmake_hash_table);
+ ctx->symbol_aux = Qnil;
+ ctx->copied_queue = Qnil;
+ ctx->cold_queue = Qnil;
+ ctx->dump_relocs = Qnil;
+ ctx->object_starts = Qnil;
+ ctx->emacs_relocs = Qnil;
+
+ /* Ordinarily, dump_object should remember where it saw objects and
+ actually write the object contents to the dump file. In special
+ circumstances below, we temporarily change this default
+ behavior. */
+ ctx->flags.dump_object_contents = true;
- // ctx->flags.defer_symbols = true;
++ ctx->flags.record_object_starts = true;
+
+ /* We want to consolidate certain object types that we know are very likely
+ to be modified. */
+ ctx->flags.defer_hash_tables = true;
- dump_user_remembered_data_hot (ctx);
++ // ctx->flags.defer_symbols = true; XXX
++
++ /* These objects go into special sections. */
++ ctx->flags.defer_cold_objects = true;
++ ctx->flags.defer_copied_objects = true;
+
+ ctx->current_referrer = Qnil;
+ if (!NILP (track_referrers))
+ ctx->referrers = make_eq_hash_table ();
+
+ ctx->dump_filename = filename;
+
+ record_unwind_protect_ptr (dump_unwind_cleanup, ctx);
+ block_input ();
+
+#ifdef REL_ALLOC
+ r_alloc_inhibit_buffer_relocation (1);
+ ctx->blocked_ralloc = true;
+#endif
+
+ ctx->old_purify_flag = Vpurify_flag;
+ Vpurify_flag = Qnil;
+
+ /* Make sure various weird things are less likely to happen. */
+ ctx->old_post_gc_hook = Vpost_gc_hook;
+ Vpost_gc_hook = Qnil;
+
+ ctx->fd = emacs_open (SSDATA (filename),
+ O_RDWR | O_TRUNC | O_CREAT, 0666);
+ if (ctx->fd < 0)
+ report_file_error ("Opening dump output", filename);
+ verify (sizeof (ctx->header.magic) == sizeof (dump_magic));
+ memcpy (&ctx->header.magic, dump_magic, sizeof (dump_magic));
+ ctx->header.magic[0] = '!'; /* Note that dump is incomplete. */
+
+ verify (sizeof (fingerprint) == sizeof (ctx->header.fingerprint));
+ memcpy (ctx->header.fingerprint, fingerprint, sizeof (fingerprint));
+
+ const dump_off header_start = ctx->offset;
+ dump_fingerprint ("dumping fingerprint", ctx->header.fingerprint);
+ dump_write (ctx, &ctx->header, sizeof (ctx->header));
+ const dump_off header_end = ctx->offset;
+
+ const dump_off hot_start = ctx->offset;
+ /* Start the dump process by processing the static roots and
+ queuing up the objects to which they refer. */
+ dump_roots (ctx);
+
+ dump_charset_table (ctx);
+ dump_finalizer_list_head_ptr (ctx, &finalizers.prev);
+ dump_finalizer_list_head_ptr (ctx, &finalizers.next);
+ dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.prev);
+ dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.next);
- objects to the queue by side effect during dumping. */
- while (!dump_queue_empty_p (&ctx->dump_queue))
- dump_object (ctx, dump_queue_dequeue (&ctx->dump_queue, ctx->offset));
- eassert (dump_queue_empty_p (&ctx->dump_queue));
-
- /* We may have deferred some objects. */
- ctx->flags.defer_hash_tables = false;
- ctx->deferred_hash_tables = Fnreverse (ctx->deferred_hash_tables);
- while (!NILP (ctx->deferred_hash_tables))
- dump_object (ctx, dump_pop (&ctx->deferred_hash_tables));
- while (!dump_queue_empty_p (&ctx->dump_queue))
- dump_object (ctx, dump_queue_dequeue (&ctx->dump_queue, ctx->offset));
- eassert (dump_queue_empty_p (&ctx->dump_queue));
-
- /* We may have deferred some symbols. */
- ctx->flags.defer_symbols = false;
- ctx->deferred_symbols = Fnreverse (ctx->deferred_symbols);
- while (!NILP (ctx->deferred_symbols))
- dump_object (ctx, dump_pop (&ctx->deferred_symbols));
- while (!dump_queue_empty_p (&ctx->dump_queue))
- dump_object (ctx, dump_queue_dequeue (&ctx->dump_queue, ctx->offset));
- eassert (dump_queue_empty_p (&ctx->dump_queue));
++ dump_drain_user_remembered_data_hot (ctx);
+
+ /* We've already remembered all the objects to which GC roots point,
+ but we have to manually save the list of GC roots itself. */
+ dump_metadata_for_pdumper (ctx);
+ for (int i = 0; i < staticidx; ++i)
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &staticvec[i], staticvec[i]);
+ dump_emacs_reloc_immediate_int (ctx, &staticidx, staticidx);
+
+ /* Dump until while we keep finding objects to dump. We add new
- const dump_off hot_end = ctx->offset;
++ objects to the queue by side effect during dumping.
++ We accumulate some types of objects in special lists to get more
++ locality for these object types at runtime. */
++ do {
++ dump_drain_deferred_hash_tables (ctx);
++ dump_drain_deferred_symbols (ctx);
++ dump_drain_normal_queue (ctx);
++ } while (!dump_queue_empty_p (&ctx->dump_queue) ||
++ !NILP (ctx->deferred_hash_tables) ||
++ !NILP (ctx->deferred_symbols));
+
+ dump_sort_copied_objects (ctx);
++
++ /* While we copy built-in symbols into the Emacs image, these
++ built-in structures refer to non-Lisp heap objects that must live
++ in the dump; we stick these auxiliary data structures at the end
++ of the hot section and use a special hash table to remember them.
++ The actual symbol dump will pick them up below. */
+ ctx->symbol_aux = make_eq_hash_table ();
+ dump_hot_parts_of_discardable_objects (ctx);
- the Emacs data section instead of just used directly. */
- ctx->header.discardable_start = ctx->offset;
- ctx->flags.dump_object_starts = false;
+
+ /* Emacs, after initial dump loading, can forget about the portion
+ of the dump that runs from here to the start of the cold section.
+ This section consists of objects that need to be memcpy()ed into
- dump_copied_objects (ctx);
++ the Emacs data section instead of just used directly.
++
++ We don't need to align hot_end: the loader knows to actually
++ start discarding only at the next page boundary if the loader
++ implements discarding using page manipulation. */
++ const dump_off hot_end = ctx->offset;
++ ctx->header.discardable_start = hot_end;
+
- eassert (NILP (ctx->copied_queue));
++ dump_drain_copied_objects (ctx);
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
- /* Resume recording object starts, since the cold section will stick
- around. */
- ctx->flags.dump_object_starts = true;
-
++
+ dump_off discardable_end = ctx->offset;
+ dump_align_output (ctx, dump_get_page_size ());
+ ctx->header.cold_start = ctx->offset;
+
- dump_cold_data (ctx);
- /* dump_user_remembered_data_cold needs to be after dump_cold_data
- in case dump_cold_data dumps a lisp object to which C code
- points. dump_user_remembered_data_cold assumes that all lisp
+ /* Start the cold section. This section contains bytes that should
+ never change and so can be direct-mapped from the dump without
+ special processing. */
- dump_user_remembered_data_cold (ctx);
++ dump_drain_cold_data (ctx);
++ /* dump_drain_user_remembered_data_cold needs to be after
++ dump_drain_cold_data in case dump_drain_cold_data dumps a lisp
++ object to which C code points.
++ dump_drain_user_remembered_data_cold assumes that all lisp
+ objects have been dumped. */
- ctx, dump_emit_dump_reloc, NULL,
++ dump_drain_user_remembered_data_cold (ctx);
+
+ /* After this point, the dump file contains no data that can be part
+ of the Lisp heap. */
+ ctx->end_heap = ctx->offset;
+
+ /* Make remembered modifications to the dump file itself. */
+ dump_do_fixups (ctx);
+
++ drain_reloc_merger emacs_reloc_merger =
++#ifdef ENABLE_CHECKING
++ dump_check_overlap_dump_reloc
++#else
++ NULL
++#endif
++ ;
++
+ /* Emit instructions for Emacs to execute when loading the dump.
+ Note that this relocation information ends up in the cold section
+ of the dump. */
+ drain_reloc_list (
- ctx, dump_emit_dump_reloc, NULL,
++ ctx,
++ dump_emit_dump_reloc,
++ emacs_reloc_merger,
+ &ctx->dump_relocs,
+ &ctx->header.dump_relocs);
+ unsigned number_hot_relocations = ctx->number_hot_relocations;
+ ctx->number_hot_relocations = 0;
+ unsigned number_discardable_relocations = ctx->number_discardable_relocations;
+ ctx->number_discardable_relocations = 0;
+ drain_reloc_list (
- ctx, dump_emit_emacs_reloc, dump_merge_emacs_relocs,
++ ctx,
++ dump_emit_dump_reloc,
++ emacs_reloc_merger,
+ &ctx->object_starts,
+ &ctx->header.object_starts);
+ drain_reloc_list (
- static void *
- emacs_ptr (const ptrdiff_t offset)
- {
- // TODO: assert somehow that offset is actually inside Emacs
- return (void *) (emacs_basis () + offset);
- }
-
++ ctx, dump_emit_emacs_reloc,
++ dump_merge_emacs_relocs,
+ &ctx->emacs_relocs,
+ &ctx->header.emacs_relocs);
+
+ const dump_off cold_end = ctx->offset;
+
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
++ eassert (NILP (ctx->copied_queue));
++ eassert (NILP (ctx->cold_queue));
++ eassert (NILP (ctx->deferred_symbols));
++ eassert (NILP (ctx->deferred_hash_tables));
+ eassert (NILP (ctx->fixups));
+ eassert (NILP (ctx->dump_relocs));
+ eassert (NILP (ctx->emacs_relocs));
+
+ /* Dump is complete. Go back to the header and write the magic
+ indicating that the dump is complete and can be loaded. */
+ ctx->header.magic[0] = dump_magic[0];
+ dump_seek (ctx, 0);
+ dump_write (ctx, &ctx->header, sizeof (ctx->header));
+
+ fprintf (stderr, "Dump complete\n");
+ fprintf (stderr,
+ "Byte counts: header=%lu hot=%lu discardable=%lu cold=%lu\n",
+ (unsigned long) (header_end - header_start),
+ (unsigned long) (hot_end - hot_start),
+ (unsigned long) (discardable_end - ctx->header.discardable_start),
+ (unsigned long) (cold_end - ctx->header.cold_start));
+ fprintf (stderr, "Reloc counts: hot=%u discardable=%u\n",
+ number_hot_relocations,
+ number_discardable_relocations);
+
+ unblock_input ();
+ return unbind_to (count, Qnil);
+}
+
+DEFUN ("dump-emacs-portable--sort-predicate",
+ Fdump_emacs_portable__sort_predicate,
+ Sdump_emacs_portable__sort_predicate,
+ 2, 2, 0,
+ doc: /* Internal relocation sorting function. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ dump_off a_offset = dump_off_from_lisp (XCAR (XCDR (a)));
+ dump_off b_offset = dump_off_from_lisp (XCAR (XCDR (b)));
+ return a_offset < b_offset ? Qt : Qnil;
+}
+
+DEFUN ("dump-emacs-portable--sort-predicate-copied",
+ Fdump_emacs_portable__sort_predicate_copied,
+ Sdump_emacs_portable__sort_predicate_copied,
+ 2, 2, 0,
+ doc: /* Internal relocation sorting function. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ eassert (dump_object_emacs_ptr (a));
+ eassert (dump_object_emacs_ptr (b));
+ return dump_object_emacs_ptr (a) < dump_object_emacs_ptr (b) ? Qt : Qnil;
+}
+
+void
+pdumper_do_now_and_after_load_impl (pdumper_hook hook)
+{
+ if (nr_dump_hooks == ARRAYELTS (dump_hooks))
+ fatal ("out of dump hooks: make dump_hooks[] bigger");
+ dump_hooks[nr_dump_hooks++] = hook;
+ hook ();
+}
+
+static void
+pdumper_remember_user_data_1 (void *mem, int nbytes)
+{
+ if (nr_remembered_data == ARRAYELTS (remembered_data))
+ fatal ("out of remembered data slots: make remembered_data[] bigger");
+ remembered_data[nr_remembered_data].mem = mem;
+ remembered_data[nr_remembered_data].sz = nbytes;
+ nr_remembered_data += 1;
+}
+
+void
+pdumper_remember_scalar_impl (void *mem, ptrdiff_t nbytes)
+{
+ eassert (0 <= nbytes && nbytes <= INT_MAX);
+ if (nbytes > 0)
+ pdumper_remember_user_data_1 (mem, (int) nbytes);
+}
+
+void
+pdumper_remember_lv_ptr_raw_impl (void* ptr, enum Lisp_Type type)
+{
+ pdumper_remember_user_data_1 (ptr, -type);
+}
+
+\f
+/* Dump runtime */
+enum dump_memory_protection {
+ DUMP_MEMORY_ACCESS_NONE = 1,
+ DUMP_MEMORY_ACCESS_READ = 2,
+ DUMP_MEMORY_ACCESS_READWRITE = 3,
+};
+
+static void *
+dump_anonymous_allocate_w32 (void *base,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED != VM_MS_WINDOWS
+ (void) base;
+ (void) size;
+ (void) protection;
+ emacs_abort ();
+#else
+ void *ret;
+ DWORD mem_type;
+ DWORD mem_prot;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_type = MEM_RESERVE;
+ mem_prot = PAGE_NOACCESS;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_type = MEM_COMMIT;
+ mem_prot = PAGE_READONLY;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_type = MEM_COMMIT;
+ mem_prot = PAGE_READWRITE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ ret = VirtualAlloc (base, size, mem_type, mem_prot);
+ if (ret == NULL)
+ errno = (base && GetLastError () == ERROR_INVALID_ADDRESS)
+ ? EBUSY
+ : EPERM;
+ return ret;
+#endif
+}
+
+/* Old versions of macOS only define MAP_ANON, not MAP_ANONYMOUS.
+ FIXME: This probably belongs elsewhere (gnulib/autoconf?) */
+#ifndef MAP_ANONYMOUS
+#define MAP_ANONYMOUS MAP_ANON
+#endif
+
+static void *
+dump_anonymous_allocate_posix (void *base,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED != VM_POSIX
+ (void) base;
+ (void) size;
+ (void) protection;
+ emacs_abort ();
+#else
+ void *ret;
+ int mem_prot;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_prot = PROT_NONE;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_prot = PROT_READ;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_prot = PROT_READ | PROT_WRITE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ int mem_flags = MAP_PRIVATE | MAP_ANONYMOUS;
+ if (mem_prot != PROT_NONE)
+ mem_flags |= MAP_POPULATE;
+ if (base)
+ mem_flags |= MAP_FIXED;
+
+ bool retry;
+ do
+ {
+ retry = false;
+ ret = mmap (base, size, mem_prot, mem_flags, -1, 0);
+ if (ret == MAP_FAILED &&
+ errno == EINVAL &&
+ (mem_flags & MAP_POPULATE))
+ {
+ /* This system didn't understand MAP_POPULATE, so try
+ again without it. */
+ mem_flags &= ~MAP_POPULATE;
+ retry = true;
+ }
+ }
+ while (retry);
+
+ if (ret == MAP_FAILED)
+ ret = NULL;
+ return ret;
+#endif
+}
+
+/* Perform anonymous memory allocation. */
+static void *
+dump_anonymous_allocate (void *base,
+ const size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret = NULL;
+ if (VM_SUPPORTED == VM_MS_WINDOWS)
+ ret = dump_anonymous_allocate_w32 (base, size, protection);
+ else if (VM_SUPPORTED == VM_POSIX)
+ ret = dump_anonymous_allocate_posix (base, size, protection);
+ else
+ errno = ENOSYS;
+ return ret;
+}
+
+/* Undo the effect of dump_reserve_address_space(). */
+static void
+dump_anonymous_release (void *addr, size_t size)
+{
+ eassert (size >= 0);
+#if VM_SUPPORTED == VM_MS_WINDOWS
+ (void) size;
+ if (!VirtualFree (addr, 0, MEM_RELEASE))
+ emacs_abort ();
+#elif VM_SUPPORTED == VM_POSIX
+ if (munmap (addr, size) < 0)
+ emacs_abort ();
+#else
+ (void) addr;
+ (void) size;
+ emacs_abort ();
+#endif
+}
+
+static void *
+dump_map_file_w32 (
+ void *base,
+ int fd,
+ off_t offset,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED != VM_MS_WINDOWS
+ (void) base;
+ (void) fd;
+ (void) offset;
+ (void) size;
+ (void) protection;
+ emacs_abort ();
+#else
+ void *ret = NULL;
+ HANDLE section = NULL;
+ HANDLE file;
+
+ uint64_t full_offset = offset;
+ uint32_t offset_high = (uint32_t) (full_offset >> 32);
+ uint32_t offset_low = (uint32_t) (full_offset & 0xffffffff);
+
+ int error;
+ DWORD map_access;
+
+ file = (HANDLE) _get_osfhandle (fd);
+ if (file == INVALID_HANDLE_VALUE)
+ goto out;
+
+ section = CreateFileMapping (
+ file,
+ /*lpAttributes=*/NULL,
+ PAGE_READONLY,
+ /*dwMaximumSizeHigh=*/0,
+ /*dwMaximumSizeLow=*/0,
+ /*lpName=*/NULL);
+ if (!section)
+ {
+ errno = EINVAL;
+ goto out;
+ }
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ case DUMP_MEMORY_ACCESS_READ:
+ map_access = FILE_MAP_READ;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ map_access = FILE_MAP_COPY;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ ret = MapViewOfFileEx (section,
+ map_access,
+ offset_high,
+ offset_low,
+ size,
+ base);
+
+ error = GetLastError ();
+ if (ret == NULL)
+ errno = (error == ERROR_INVALID_ADDRESS ? EBUSY : EPERM);
+ out:
+ if (section && !CloseHandle (section))
+ emacs_abort ();
+ return ret;
+#endif
+}
+
+static void *
+dump_map_file_posix (
+ void *base,
+ int fd,
+ off_t offset,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+#if VM_SUPPORTED != VM_POSIX
+ (void) base;
+ (void) fd;
+ (void) offset;
+ (void) size;
+ (void) protection;
+ emacs_abort ();
+#else
+ void *ret;
+ int mem_prot;
+ int mem_flags;
+
+ switch (protection)
+ {
+ case DUMP_MEMORY_ACCESS_NONE:
+ mem_prot = PROT_NONE;
+ mem_flags = MAP_SHARED;
+ break;
+ case DUMP_MEMORY_ACCESS_READ:
+ mem_prot = PROT_READ;
+ mem_flags = MAP_SHARED;
+ break;
+ case DUMP_MEMORY_ACCESS_READWRITE:
+ mem_prot = PROT_READ | PROT_WRITE;
+ mem_flags = MAP_PRIVATE;
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ if (base)
+ mem_flags |= MAP_FIXED;
+
+ ret = mmap (base, size, mem_prot, mem_flags, fd, offset);
+ if (ret == MAP_FAILED)
+ ret = NULL;
+ return ret;
+#endif
+}
+
+/* Map a file into memory. */
+static void *
+dump_map_file (
+ void *base,
+ int fd,
+ off_t offset,
+ size_t size,
+ enum dump_memory_protection protection)
+{
+ void *ret = NULL;
+ if (VM_SUPPORTED == VM_MS_WINDOWS)
+ ret = dump_map_file_w32 (base, fd, offset, size, protection);
+ else if (VM_SUPPORTED == VM_POSIX)
+ ret = dump_map_file_posix (base, fd, offset, size, protection);
+ else
+ errno = ENOSYS;
+ return ret;
+}
+
+/* Remove a virtual memory mapping.
+
+ On failure, abort Emacs. For maximum platform compatibility, ADDR
+ and SIZE must match the mapping exactly. */
+static void
+dump_unmap_file (void *addr, size_t size)
+{
+ eassert (size >= 0);
+#if !VM_SUPPORTED
+ (void) addr;
+ (void) size;
+ emacs_abort ();
+#elif defined (WINDOWSNT)
+ (void) size;
+ if (!UnmapViewOfFile (addr))
+ emacs_abort ();
+#else
+ if (munmap (addr, size) < 0)
+ emacs_abort ();
+#endif
+}
+
+struct dump_memory_map_spec
+{
+ int fd; /* File to map; anon zero if negative. */
+ size_t size; /* Number of bytes to map. */
+ off_t offset; /* Offset within fd. */
+ enum dump_memory_protection protection;
+};
+
+struct dump_memory_map {
+ struct dump_memory_map_spec spec;
+ void *mapping; /* Actual mapped memory. */
+ void (*release)(struct dump_memory_map *);
+ void *private;
+};
+
+/* Mark the pages as unneeded, potentially zeroing them, without
+ releasing the address space reservation. */
+static void
+dump_discard_mem (void *mem, size_t size)
+{
+#if VM_SUPPORTED == VM_MS_WINDOWS
+ /* Discard COWed pages. */
+ (void) VirtualFree (mem, size, MEM_DECOMMIT);
+ /* Release the commit charge for the mapping. */
+ (void) VirtualProtect (mem, size, PAGE_NOACCESS, NULL);
+#elif VM_SUPPORTED == VM_POSIX
+# ifdef HAVE_POSIX_MADVISE
+ /* Discard COWed pages. */
+ (void) posix_madvise (mem, size, POSIX_MADV_DONTNEED);
+# endif
+ /* Release the commit charge for the mapping. */
+ (void) mprotect (mem, size, PROT_NONE);
+#endif
+}
+
+static void
+dump_mmap_discard_contents (struct dump_memory_map *map)
+{
+ if (map->mapping)
+ dump_discard_mem (map->mapping, map->spec.size);
+}
+
+static void
+dump_mmap_reset (struct dump_memory_map *map)
+{
+ map->mapping = NULL;
+ map->release = NULL;
+ map->private = NULL;
+}
+
+static void
+dump_mmap_release (struct dump_memory_map *map)
+{
+ if (map->release)
+ map->release (map);
+ dump_mmap_reset (map);
+}
+
+/* Allows heap-allocated dump_mmap to "free" maps individually. */
+struct dump_memory_map_heap_control_block {
+ int refcount;
+ void *mem;
+};
+
+static void
+dump_mm_heap_cb_release (struct dump_memory_map_heap_control_block *cb)
+{
+ eassert (cb->refcount > 0);
+ if (--cb->refcount == 0)
+ {
+ free (cb->mem);
+ free (cb);
+ }
+}
+
+static void
+dump_mmap_release_heap (struct dump_memory_map *map)
+{
+ struct dump_memory_map_heap_control_block *cb = map->private;
+ dump_mm_heap_cb_release (cb);
+}
+
+/* Implement dump_mmap using malloc and read. */
+static bool
+dump_mmap_contiguous_heap (
+ struct dump_memory_map *maps,
+ int nr_maps,
+ size_t total_size)
+{
+ bool ret = false;
+ struct dump_memory_map_heap_control_block *cb = calloc (1, sizeof (*cb));
+ char *mem;
+ if (!cb)
+ goto out;
+ cb->refcount = 1;
+ cb->mem = malloc (total_size);
+ if (!cb->mem)
+ goto out;
+ mem = cb->mem;
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ struct dump_memory_map *map = &maps[i];
+ const struct dump_memory_map_spec spec = map->spec;
+ if (!spec.size)
+ continue;
+ map->mapping = mem;
+ mem += spec.size;
+ map->release = dump_mmap_release_heap;
+ map->private = cb;
+ cb->refcount += 1;
+ if (spec.fd < 0)
+ memset (map->mapping, 0, spec.size);
+ else
+ {
+ if (lseek (spec.fd, spec.offset, SEEK_SET) < 0)
+ goto out;
+ ssize_t nb = dump_read_all (spec.fd,
+ map->mapping,
+ spec.size);
+ if (nb >= 0 && nb != spec.size)
+ errno = EIO;
+ if (nb != spec.size)
+ goto out;
+ }
+ }
+
+ ret = true;
+ out:
+ dump_mm_heap_cb_release (cb);
+ if (!ret)
+ for (int i = 0; i < nr_maps; ++i)
+ dump_mmap_release (&maps[i]);
+ return ret;
+}
+
+static void
+dump_mmap_release_vm (struct dump_memory_map *map)
+{
+ if (map->spec.fd < 0)
+ dump_anonymous_release (map->mapping, map->spec.size);
+ else
+ dump_unmap_file (map->mapping, map->spec.size);
+}
+
+static bool
+needs_mmap_retry_p (void)
+{
+#if defined (CYGWIN) || VM_SUPPORTED == VM_MS_WINDOWS
+ return true;
+#else
+ return false;
+#endif
+}
+
+static bool
+dump_mmap_contiguous_vm (
+ struct dump_memory_map *maps,
+ int nr_maps,
+ size_t total_size)
+{
+ bool ret = false;
+ void *resv = NULL;
+ bool retry = false;
+ const bool need_retry = needs_mmap_retry_p ();
+
+ do
+ {
+ if (retry)
+ {
+ eassert (need_retry);
+ retry = false;
+ for (int i = 0; i < nr_maps; ++i)
+ dump_mmap_release (&maps[i]);
+ }
+
+ eassert (resv == NULL);
+ resv = dump_anonymous_allocate (NULL,
+ total_size,
+ DUMP_MEMORY_ACCESS_NONE);
+ if (!resv)
+ goto out;
+
+ char *mem = resv;
+
+ if (need_retry)
+ {
+ /* Windows lacks atomic mapping replace; need to release the
+ reservation so we can allocate within it. Will retry the
+ loop if someone squats on our address space before we can
+ finish allocation. On POSIX systems, we leave the
+ reservation around for atomicity. */
+ dump_anonymous_release (resv, total_size);
+ resv = NULL;
+ }
+
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ struct dump_memory_map *map = &maps[i];
+ const struct dump_memory_map_spec spec = map->spec;
+ if (!spec.size)
+ continue;
+
+ if (spec.fd < 0)
+ map->mapping = dump_anonymous_allocate (
+ mem, spec.size, spec.protection);
+ else
+ map->mapping = dump_map_file (
+ mem, spec.fd, spec.offset, spec.size, spec.protection);
+ mem += spec.size;
+ if (need_retry &&
+ map->mapping == NULL &&
+ (errno == EBUSY
+#ifdef CYGWIN
+ || errno == EINVAL
+#endif
+ ))
+ {
+ retry = true;
+ continue;
+ }
+ if (map->mapping == NULL)
+ goto out;
+ map->release = dump_mmap_release_vm;
+ }
+ }
+ while (retry);
+
+ ret = true;
+ resv = NULL;
+ out:
+ if (resv)
+ dump_anonymous_release (resv, total_size);
+ if (!ret)
+ {
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ if (need_retry)
+ dump_mmap_reset (&maps[i]);
+ else
+ dump_mmap_release (&maps[i]);
+ }
+ }
+ return ret;
+}
+
+/* Map a range of addresses into a chunk of contiguous memory.
+
+ Each dump_memory_map structure describes how to fill the
+ corresponding range of memory. On input, all members except MAPPING
+ are valid. On output, MAPPING contains the location of the given
+ chunk of memory. The MAPPING for MAPS[N] is MAPS[N-1].mapping +
+ MAPS[N-1].size.
+
+ Each mapping SIZE must be a multiple of the system page size except
+ for the last mapping.
+
+ Return true on success or false on failure with errno set. */
+static bool
+dump_mmap_contiguous (
+ struct dump_memory_map *maps,
+ int nr_maps)
+{
+ if (!nr_maps)
+ return true;
+
+ size_t total_size = 0;
+ int worst_case_page_size = dump_get_page_size ();
+
+ for (int i = 0; i < nr_maps; ++i)
+ {
+ eassert (maps[i].mapping == NULL);
+ eassert (maps[i].release == NULL);
+ eassert (maps[i].private == NULL);
+ if (i != nr_maps - 1)
+ eassert (maps[i].spec.size % worst_case_page_size == 0);
+ total_size += maps[i].spec.size;
+ }
+
+ return (VM_SUPPORTED ?
+ dump_mmap_contiguous_vm :
+ dump_mmap_contiguous_heap)
+ (maps, nr_maps, total_size);
+}
+
+typedef uint_fast32_t dump_bitset_word;
+
+struct dump_bitset {
+ dump_bitset_word *restrict bits;
+ ptrdiff_t number_words;
+};
+
+static bool
+dump_bitset_init (struct dump_bitset *bitset, size_t number_bits)
+{
+ memset (bitset, 0, sizeof (*bitset));
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ ptrdiff_t words_needed = DIVIDE_ROUND_UP (number_bits, bits_per_word);
+ bitset->number_words = words_needed;
+ bitset->bits = calloc (words_needed, xword_size);
+ return bitset->bits != NULL;
+}
+
+static void
+dump_bitset_destroy (struct dump_bitset *bitset)
+{
+ free (bitset->bits);
+}
+
+static dump_bitset_word *
+dump_bitset__bit_slot (const struct dump_bitset *bitset,
+ size_t bit_number)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ ptrdiff_t word_number = bit_number / bits_per_word;
+ eassert (word_number < bitset->number_words);
+ return &bitset->bits[word_number];
+}
+
+static bool
+dump_bitset_bit_set_p (const struct dump_bitset *bitset,
+ size_t bit_number)
+{
+ unsigned xword_size = sizeof (bitset->bits[0]);
+ unsigned bits_per_word = xword_size * CHAR_BIT;
+ dump_bitset_word bit = 1;
+ bit <<= bit_number % bits_per_word;
+ return *dump_bitset__bit_slot (bitset, bit_number) & bit;
+}
+
+static void
+dump_bitset__set_bit_value (struct dump_bitset *bitset,
+ size_t bit_number,
+ bool bit_is_set)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ int bits_per_word = xword_size * CHAR_BIT;
+ dump_bitset_word * slot = dump_bitset__bit_slot (bitset, bit_number);
+ dump_bitset_word bit = 1;
+ bit <<= bit_number % bits_per_word;
+ if (bit_is_set)
+ *slot = *slot | bit;
+ else
+ *slot = *slot & ~bit;
+}
+
+static void
+dump_bitset_set_bit (struct dump_bitset *bitset, size_t bit_number)
+{
+ dump_bitset__set_bit_value (bitset, bit_number, true);
+}
+
+static void
+dump_bitset_clear (struct dump_bitset *bitset)
+{
+ int xword_size = sizeof (bitset->bits[0]);
+ memset (bitset->bits, 0, bitset->number_words * xword_size);
+}
+
+struct pdumper_loaded_dump_private
+{
+ /* Copy of the header we read from the dump. */
+ struct dump_header header;
+ /* Mark bits for objects in the dump; used during GC. */
+ struct dump_bitset mark_bits;
+ /* Time taken to load the dump. */
+ double load_time;
+ /* Dump file name. */
+ char *dump_filename;
+};
+
+struct pdumper_loaded_dump dump_public;
+struct pdumper_loaded_dump_private dump_private;
+
+/* Return a pointer to offset OFFSET within the dump, which begins at
+ DUMP_BASE. DUMP_BASE must be equal to the current dump load
+ location; it's passed as a parameter for efficiency.
+
+ The returned pointer points to the primary memory image of the
+ currently-loaded dump file. The entire dump file is accessible
+ using this function. */
+static void *
+dump_ptr (intptr_t dump_base, dump_off offset)
+{
+ eassert (dump_base == dump_public.start);
++ eassert (0 <= offset);
+ eassert (dump_public.start + offset < dump_public.end);
+ return (char *)dump_public.start + offset;
+}
+
+/* Read a pointer-sized word of memory at OFFSET within the dump,
+ which begins at DUMP_BASE. DUMP_BASE must be equal to the current
+ dump load location; it's passed as a parameter for efficiency. */
+static uintptr_t
+dump_read_word_from_dump (intptr_t dump_base, dump_off offset)
+{
+ uintptr_t value;
+ /* The compiler optimizes this memcpy into a read. */
+ memcpy (&value, dump_ptr (dump_base, offset), sizeof (value));
+ return value;
+}
+
+/* Write a word to the dump. DUMP_BASE and OFFSET are as for
+ dump_read_word_from_dump; VALUE is the word to write at the given
+ offset. */
+static void
+dump_write_word_to_dump (intptr_t dump_base,
+ dump_off offset,
+ uintptr_t value)
+{
+ /* The compiler optimizes this memcpy into a write. */
+ memcpy (dump_ptr (dump_base, offset), &value, sizeof (value));
+}
+
+/* Write a Lisp_Object to the dump. DUMP_BASE and OFFSET are as for
+ dump_read_word_from_dump; VALUE is the Lisp_Object to write at the
+ given offset. */
+static void
+dump_write_lv_to_dump (intptr_t dump_base,
+ dump_off offset,
+ Lisp_Object value)
+{
+ /* The compiler optimizes this memcpy into a write. */
+ memcpy (dump_ptr (dump_base, offset), &value, sizeof (value));
+}
+
+/* Search for a relocation given a relocation target.
+
+ DUMP is the dump metadata structure. TABLE is the relocation table
+ to search. KEY is the dump offset to find. Return the relocation
+ RELOC such that RELOC.offset is the smallest RELOC.offset that
+ satisfies the constraint KEY <= RELOC.offset --- that is, return
+ the first relocation at KEY or after KEY. Return NULL if no such
+ relocation exists. */
+static const struct dump_reloc *
+dump_find_relocation (const struct dump_table_locator *const table,
+ const dump_off key)
+{
+ const struct dump_reloc *const relocs = dump_ptr (
+ dump_public.start, table->offset);
+ const struct dump_reloc *found = NULL;
+ ptrdiff_t idx_left = 0;
+ ptrdiff_t idx_right = table->nr_entries;
+
+ eassert (key >= 0);
+
+ while (idx_left < idx_right)
+ {
+ const ptrdiff_t idx_mid = idx_left + (idx_right - idx_left) / 2;
+ const struct dump_reloc *mid = &relocs[idx_mid];
+ if (key > dump_reloc_get_offset (*mid))
+ idx_left = idx_mid + 1;
+ else
+ {
+ found = mid;
+ idx_right = idx_mid;
+ if (idx_right <= idx_left ||
+ key > dump_reloc_get_offset (relocs[idx_right - 1]))
+ break;
+ }
+ }
+
+ return found;
+}
+
+static bool
+dump_loaded_p (void)
+{
+ return dump_public.start != 0;
+}
+
+bool
+pdumper_cold_object_p_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ eassert (pdumper_object_p_precise (obj));
+ dump_off offset = ptrdiff_t_to_dump_off (
+ (intptr_t) obj - dump_public.start);
+ return offset >= dump_private.header.cold_start;
+}
+
+enum Lisp_Type
+pdumper_find_object_type_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ dump_off offset = ptrdiff_t_to_dump_off (
+ (intptr_t) obj - dump_public.start);
+ if (offset % GCALIGNMENT != 0)
+ return PDUMPER_NO_OBJECT;
+ const struct dump_reloc *reloc =
+ dump_find_relocation (&dump_private.header.object_starts, offset);
+ return (reloc != NULL && dump_reloc_get_offset (*reloc) == offset)
+ ? (enum Lisp_Type) reloc->type
+ : PDUMPER_NO_OBJECT;
+}
+
+bool
+pdumper_marked_p_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ ptrdiff_t offset = (intptr_t) obj - dump_public.start;
+ eassert (offset % GCALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / GCALIGNMENT;
+ return dump_bitset_bit_set_p (&dump_private.mark_bits, bitno);
+}
+
+void
+pdumper_set_marked_impl (const void *obj)
+{
+ eassert (pdumper_object_p (obj));
+ ptrdiff_t offset = (intptr_t) obj - dump_public.start;
+ eassert (offset % GCALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / GCALIGNMENT;
+ dump_bitset_set_bit (&dump_private.mark_bits, bitno);
+}
+
+void
+pdumper_clear_marks_impl (void)
+{
+ dump_bitset_clear (&dump_private.mark_bits);
+}
+
+static ssize_t
+dump_read_all (int fd, void *buf, size_t bytes_to_read)
+{
+ /* We don't want to use emacs_read, since that relies on the lisp
+ world, and we're not in the lisp world yet. */
+ eassert (bytes_to_read <= SSIZE_MAX);
+ size_t bytes_read = 0;
+ while (bytes_read < bytes_to_read)
+ {
+ /* Some platforms accept only int-sized values to read. */
+ unsigned chunk_to_read = INT_MAX;
+ if (bytes_to_read - bytes_read < chunk_to_read)
+ chunk_to_read = (unsigned)(bytes_to_read - bytes_read);
+ ssize_t chunk =
+ read (fd, (char*) buf + bytes_read, chunk_to_read);
+ if (chunk < 0)
+ return chunk;
+ if (chunk == 0)
+ break;
+ bytes_read += chunk;
+ }
+
+ return bytes_read;
+}
+
- eassume (reloc.length <= Lisp_Float);
- if (reloc.length == Lisp_Symbol)
- lv = make_lisp_symbol (dump_ptr (dump_base, reloc.u.dump_offset));
- else
- lv = make_lisp_ptr (dump_ptr (dump_base, reloc.u.dump_offset),
- reloc.length);
- memcpy (emacs_ptr (reloc.emacs_offset), &lv, sizeof (lv));
- break;
+/* Return the number of bytes written when we perform the given
+ relocation. */
+static int
+dump_reloc_size (const struct dump_reloc reloc)
+{
+ if (sizeof (Lisp_Object) == sizeof (void*))
+ return sizeof (Lisp_Object);
+ if (reloc.type == RELOC_DUMP_TO_EMACS_PTR_RAW ||
+ reloc.type == RELOC_DUMP_TO_DUMP_PTR_RAW)
+ return sizeof (void*);
+ return sizeof (Lisp_Object);
+}
+
+static Lisp_Object
+dump_make_lv_from_reloc (
+ const intptr_t dump_base,
+ const struct dump_reloc reloc)
+{
+ const dump_off reloc_offset = dump_reloc_get_offset (reloc);
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ enum Lisp_Type lisp_type;
+
+ if (RELOC_DUMP_TO_DUMP_LV <= reloc.type &&
+ reloc.type < RELOC_DUMP_TO_EMACS_LV)
+ {
+ lisp_type = reloc.type - RELOC_DUMP_TO_DUMP_LV;
+ value += dump_base;
++ eassert (pdumper_object_p ((void *) value));
+ }
+ else
+ {
+ eassert (RELOC_DUMP_TO_EMACS_LV <= reloc.type);
+ eassert (reloc.type < RELOC_DUMP_TO_EMACS_LV + 8);
+ lisp_type = reloc.type - RELOC_DUMP_TO_EMACS_LV;
+ value += emacs_basis ();
+ }
+
+ eassert (lisp_type != Lisp_Int0 && lisp_type != Lisp_Int1);
+
+ Lisp_Object lv;
+ if (lisp_type == Lisp_Symbol)
+ lv = make_lisp_symbol ((void *) value);
+ else
+ lv = make_lisp_ptr ((void *) value, lisp_type);
+
+ return lv;
+}
+
+/* Actually apply a dump relocation. */
+static inline void
+dump_do_dump_relocation (
+ const intptr_t dump_base,
+ const struct dump_reloc reloc)
+{
+ const dump_off reloc_offset = dump_reloc_get_offset (reloc);
+
+ /* We should never generate a relocation in the cold section. */
+ eassert (reloc_offset < dump_private.header.cold_start);
+
+ switch (reloc.type)
+ {
+ case RELOC_DUMP_TO_EMACS_PTR_RAW:
+ {
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ eassert (dump_reloc_size (reloc) == sizeof (value));
+ value += emacs_basis ();
+ dump_write_word_to_dump (dump_base, reloc_offset, value);
+ break;
+ }
+ case RELOC_DUMP_TO_DUMP_PTR_RAW:
+ {
+ uintptr_t value = dump_read_word_from_dump (dump_base, reloc_offset);
+ eassert (dump_reloc_size (reloc) == sizeof (value));
+ value += dump_base;
+ dump_write_word_to_dump (dump_base, reloc_offset, value);
+ break;
+ }
+ default: /* Lisp_Object in the dump; precise type in reloc.type */
+ {
+ Lisp_Object lv = dump_make_lv_from_reloc (dump_base, reloc);
+ eassert (dump_reloc_size (reloc) == sizeof (lv));
+ dump_write_lv_to_dump (dump_base, reloc_offset, lv);
+ break;
+ }
+ }
+}
+
+static void
+dump_do_all_dump_relocations (
+ const struct dump_header *const header,
+ const intptr_t dump_base)
+{
+ struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset);
+ dump_off nr_entries = header->dump_relocs.nr_entries;
+ for (dump_off i = 0; i < nr_entries; ++i)
+ dump_do_dump_relocation (dump_base, r[i]);
+}
+
+static void
+dump_do_emacs_relocation (
+ const intptr_t dump_base,
+ const struct emacs_reloc reloc)
+{
+ ptrdiff_t pval;
+ Lisp_Object lv;
+
+ switch (reloc.type)
+ {
+ case RELOC_EMACS_COPY_FROM_DUMP:
+ eassume (reloc.length > 0);
+ memcpy (emacs_ptr (reloc.emacs_offset),
+ dump_ptr (dump_base, reloc.u.dump_offset),
+ reloc.length);
+ break;
+ case RELOC_EMACS_IMMEDIATE:
+ eassume (reloc.length > 0);
+ eassume (reloc.length <= sizeof (reloc.u.immediate));
+ memcpy (emacs_ptr (reloc.emacs_offset),
+ &reloc.u.immediate,
+ reloc.length);
+ break;
+ case RELOC_EMACS_DUMP_PTR_RAW:
+ pval = reloc.u.dump_offset + dump_base;
+ memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_EMACS_PTR_RAW:
+ pval = reloc.u.emacs_offset2 + emacs_basis ();
+ memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_DUMP_LV:
++ case RELOC_EMACS_EMACS_LV:
++ {
++ /* Lisp_Float is the maximum lisp type. */
++ eassume (reloc.length <= Lisp_Float);
++ void *obj_ptr = reloc.type == RELOC_EMACS_DUMP_LV
++ ? dump_ptr (dump_base, reloc.u.dump_offset)
++ : emacs_ptr (reloc.u.emacs_offset2);
++ if (reloc.length == Lisp_Symbol)
++ lv = make_lisp_symbol (obj_ptr);
++ else
++ lv = make_lisp_ptr (obj_ptr, reloc.length);
++ memcpy (emacs_ptr (reloc.emacs_offset), &lv, sizeof (lv));
++ break;
++ }
+ default:
+ fatal ("unrecognied relocation type %d", (int) reloc.type);
+ }
+}
+
+static void
+dump_do_all_emacs_relocations (
+ const struct dump_header *const header,
+ const intptr_t dump_base)
+{
+ const dump_off nr_entries = header->emacs_relocs.nr_entries;
+ struct emacs_reloc *r = dump_ptr (dump_base, header->emacs_relocs.offset);
+ for (dump_off i = 0; i < nr_entries; ++i)
+ dump_do_emacs_relocation (dump_base, r[i]);
+}
+
+enum dump_section
+ {
+ DS_HOT,
+ DS_DISCARDABLE,
+ DS_COLD,
+ NUMBER_DUMP_SECTIONS,
+ };
+
+/* Subtract two timespecs, yielding a difference in milliseconds. */
+static double
+subtract_timespec (struct timespec minuend, struct timespec subtrahend)
+{
+ return
+ 1000.0 * (double)(minuend.tv_sec - subtrahend.tv_sec)
+ + (double)(minuend.tv_nsec - subtrahend.tv_nsec) / 1.0e6;
+}
+
+/* Load a dump from DUMP_FILENAME. Return an error code.
+
+ N.B. We run very early in initialization, so we can't use lisp,
+ unwinding, xmalloc, and so on. */
+enum pdumper_load_result
+pdumper_load (const char *dump_filename)
+{
+ enum pdumper_load_result err = PDUMPER_LOAD_ERROR;
+
+ int dump_fd = -1;
+ intptr_t dump_size;
+ struct stat stat;
+ intptr_t dump_base;
+ int dump_page_size;
+ dump_off adj_discardable_start;
+
+ struct dump_bitset mark_bits;
+ bool free_mark_bits = false;
+ size_t mark_bits_needed;
+
+ struct dump_header header_buf;
+ struct dump_header *header = &header_buf;
+ struct dump_memory_map sections[NUMBER_DUMP_SECTIONS];
+
+ const struct timespec start_time = current_timespec ();
+ char *dump_filename_copy = NULL;
+
+ memset (&header_buf, 0, sizeof (header_buf));
+ memset (§ions, 0, sizeof (sections));
+
+ /* Overwriting an initialized Lisp universe will not go well. */
+ eassert (!initialized);
+
+ /* We can load only one dump. */
+ eassert (!dump_loaded_p ());
+
+ err = PDUMPER_LOAD_FILE_NOT_FOUND;
+ dump_fd = emacs_open (dump_filename, O_RDONLY, 0);
+ if (dump_fd < 0)
+ goto out;
+
+ err = PDUMPER_LOAD_FILE_NOT_FOUND;
+ if (fstat (dump_fd, &stat) < 0)
+ goto out;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (stat.st_size > INTPTR_MAX)
+ goto out;
+ dump_size = (intptr_t) stat.st_size;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (dump_size < sizeof (*header))
+ goto out;
+
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ if (dump_read_all (dump_fd,
+ header,
+ sizeof (*header)) < sizeof (*header))
+ goto out;
+
+ if (memcmp (header->magic, dump_magic, sizeof (dump_magic)) != 0)
+ {
+ if (header->magic[0] == '!' &&
+ ((header->magic[0] = dump_magic[0]),
+ memcmp (header->magic, dump_magic, sizeof (dump_magic)) == 0))
+ {
+ err = PDUMPER_LOAD_FAILED_DUMP;
+ goto out;
+ }
+ err = PDUMPER_LOAD_BAD_FILE_TYPE;
+ goto out;
+ }
+
+ err = PDUMPER_LOAD_VERSION_MISMATCH;
+ verify (sizeof (header->fingerprint) == sizeof (fingerprint));
+ if (memcmp (header->fingerprint, fingerprint, sizeof (fingerprint)) != 0)
+ {
+ dump_fingerprint ("desired fingerprint", fingerprint);
+ dump_fingerprint ("found fingerprint", header->fingerprint);
+ goto out;
+ }
+
+ err = PDUMPER_LOAD_OOM;
+ dump_filename_copy = strdup (dump_filename);
+ if (!dump_filename_copy)
+ goto out;
+
+ err = PDUMPER_LOAD_OOM;
+
+ adj_discardable_start = header->discardable_start;
+ dump_page_size = dump_get_page_size ();
+ /* Snap to next page boundary. */
+ adj_discardable_start = ROUNDUP (
+ adj_discardable_start,
+ dump_page_size);
+ eassert (adj_discardable_start % dump_page_size == 0);
+ eassert (adj_discardable_start <= header->cold_start);
+
+ sections[DS_HOT].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = adj_discardable_start,
+ .offset = 0,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ sections[DS_DISCARDABLE].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = header->cold_start - adj_discardable_start,
+ .offset = adj_discardable_start,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ sections[DS_COLD].spec = (struct dump_memory_map_spec)
+ {
+ .fd = dump_fd,
+ .size = dump_size - header->cold_start,
+ .offset = header->cold_start,
+ .protection = DUMP_MEMORY_ACCESS_READWRITE,
+ };
+
+ if (!dump_mmap_contiguous (sections, ARRAYELTS (sections)))
+ goto out;
+
+ err = PDUMPER_LOAD_ERROR;
+ mark_bits_needed =
+ DIVIDE_ROUND_UP (header->discardable_start, GCALIGNMENT);
+ if (!dump_bitset_init (&mark_bits, mark_bits_needed))
+ goto out;
+ free_mark_bits = true;
+
+ /* Point of no return. */
+ err = PDUMPER_LOAD_SUCCESS;
+ dump_base = (intptr_t) sections[DS_HOT].mapping;
+ gflags.dumped_with_pdumper_ = true;
+ free_mark_bits = false;
+ dump_private.header = *header;
+ dump_private.mark_bits = mark_bits;
+ dump_public.start = dump_base;
+ dump_public.end = dump_public.start + dump_size;
+
+ dump_do_all_dump_relocations (header, dump_base);
+ dump_do_all_emacs_relocations (header, dump_base);
+
+ dump_mmap_discard_contents (§ions[DS_DISCARDABLE]);
+ for (int i = 0; i < ARRAYELTS (sections); ++i)
+ dump_mmap_reset (§ions[i]);
+
+ /* Run the functions Emacs registered for doing post-dump-load
+ initialization. */
+ for (int i = 0; i < nr_dump_hooks; ++i)
+ dump_hooks[i] ();
+ initialized = true;
+
+ dump_private.load_time = subtract_timespec (
+ current_timespec (), start_time);
+ dump_private.dump_filename = dump_filename_copy;
+ dump_filename_copy = NULL;
+
+ out:
+ for (int i = 0; i < ARRAYELTS (sections); ++i)
+ dump_mmap_release (§ions[i]);
+ if (free_mark_bits)
+ dump_bitset_destroy (&mark_bits);
+ if (dump_fd >= 0)
+ emacs_close (dump_fd);
+ free (dump_filename_copy);
+ return err;
+}
+
+DEFUN ("pdumper-stats",
+ Fpdumper_stats, Spdumper_stats,
+ 0, 0, 0,
+ doc: /* Return an alist of statistics about dump file that
+ started this Emacs, if any. Nil if this Emacs was not
+ started using a portable dumper dump file.*/)
+ (void)
+{
+ if (!dumped_with_pdumper_p ())
+ return Qnil;
+
+ return CALLN (
+ Flist,
+ Fcons (Qdumped_with_pdumper, Qt),
+ Fcons (Qload_time, make_float (dump_private.load_time)),
+ Fcons (Qdump_file_name,
+ build_unibyte_string (dump_private.dump_filename)));
+}
+
+#endif /* HAVE_PDUMPER */
+
+\f
+
+void
+syms_of_pdumper (void)
+{
+#ifdef HAVE_PDUMPER
+ defsubr (&Sdump_emacs_portable);
+ defsubr (&Sdump_emacs_portable__sort_predicate);
+ defsubr (&Sdump_emacs_portable__sort_predicate_copied);
+ DEFSYM (Qdump_emacs_portable__sort_predicate,
+ "dump-emacs-portable--sort-predicate");
+ DEFSYM (Qdump_emacs_portable__sort_predicate_copied,
+ "dump-emacs-portable--sort-predicate-copied");
+ DEFSYM (Qdumped_with_pdumper, "dumped-with-pdumper");
+ DEFSYM (Qload_time, "load-time");
+ DEFSYM (Qdump_file_name, "dump-file-name");
+ defsubr (&Spdumper_stats);
+#endif /* HAVE_PDUMPER */
+}
--- /dev/null
-init_timefns (bool dumping)
+ /* Timestamp functions for Emacs
+
+ Copyright (C) 1985-1987, 1989, 1993-2019 Free Software Foundation, Inc.
+
+ This file is part of GNU Emacs.
+
+ GNU Emacs is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or (at
+ your option) any later version.
+
+ GNU Emacs is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+ #include <config.h>
+
+ #include "systime.h"
+
+ #include "blockinput.h"
+ #include "bignum.h"
+ #include "coding.h"
+ #include "lisp.h"
+
+ #include <strftime.h>
+
+ #include <errno.h>
+ #include <limits.h>
+ #include <math.h>
+ #include <stdio.h>
+ #include <stdlib.h>
+
+ #ifdef HAVE_TIMEZONE_T
+ # include <sys/param.h>
+ # if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000
+ # define HAVE_TZALLOC_BUG true
+ # endif
+ #endif
+ #ifndef HAVE_TZALLOC_BUG
+ # define HAVE_TZALLOC_BUG false
+ #endif
+
+ enum { TM_YEAR_BASE = 1900 };
+
+ #ifndef HAVE_TM_GMTOFF
+ # define HAVE_TM_GMTOFF false
+ #endif
+
+ #ifndef TIME_T_MIN
+ # define TIME_T_MIN TYPE_MINIMUM (time_t)
+ #endif
+ #ifndef TIME_T_MAX
+ # define TIME_T_MAX TYPE_MAXIMUM (time_t)
+ #endif
+
+ /* Compile with -DFASTER_TIMEFNS=0 to disable common optimizations and
+ allow easier testing of some slow-path code. */
+ #ifndef FASTER_TIMEFNS
+ # define FASTER_TIMEFNS 1
+ #endif
+
+ /* Whether to warn about Lisp timestamps (TICKS . HZ) that may be
+ instances of obsolete-format timestamps (HI . LO) where HI is
+ the high-order bits and LO the low-order 16 bits. Currently this
+ is true, but it should change to false in a future version of
+ Emacs. Compile with -DWARN_OBSOLETE_TIMESTAMPS=0 to see what the
+ future will be like. */
+ #ifndef WARN_OBSOLETE_TIMESTAMPS
+ enum { WARN_OBSOLETE_TIMESTAMPS = true };
+ #endif
+
+ /* Although current-time etc. generate list-format timestamps
+ (HI LO US PS), the plan is to change these functions to generate
+ frequency-based timestamps (TICKS . HZ) in a future release.
+ To try this now, compile with -DCURRENT_TIME_LIST=0. */
+ #ifndef CURRENT_TIME_LIST
+ enum { CURRENT_TIME_LIST = true };
+ #endif
+
+ #if FIXNUM_OVERFLOW_P (1000000000)
+ static Lisp_Object timespec_hz;
+ #else
+ # define timespec_hz make_fixnum (TIMESPEC_HZ)
+ #endif
+
+ #define TRILLION 1000000000000
+ #if FIXNUM_OVERFLOW_P (TRILLION)
+ static Lisp_Object trillion;
+ # define ztrillion (XBIGNUM (trillion)->value)
+ #else
+ # define trillion make_fixnum (TRILLION)
+ # if ULONG_MAX < TRILLION || !FASTER_TIMEFNS
+ mpz_t ztrillion;
+ # endif
+ #endif
+
+ /* Return a struct timeval that is roughly equivalent to T.
+ Use the least timeval not less than T.
+ Return an extremal value if the result would overflow. */
+ struct timeval
+ make_timeval (struct timespec t)
+ {
+ struct timeval tv;
+ tv.tv_sec = t.tv_sec;
+ tv.tv_usec = t.tv_nsec / 1000;
+
+ if (t.tv_nsec % 1000 != 0)
+ {
+ if (tv.tv_usec < 999999)
+ tv.tv_usec++;
+ else if (tv.tv_sec < TIME_T_MAX)
+ {
+ tv.tv_sec++;
+ tv.tv_usec = 0;
+ }
+ }
+
+ return tv;
+ }
+
+ /* Yield A's UTC offset, or an unspecified value if unknown. */
+ static long int
+ tm_gmtoff (struct tm *a)
+ {
+ #if HAVE_TM_GMTOFF
+ return a->tm_gmtoff;
+ #else
+ return 0;
+ #endif
+ }
+
+ /* Yield A - B, measured in seconds.
+ This function is copied from the GNU C Library. */
+ static int
+ tm_diff (struct tm *a, struct tm *b)
+ {
+ /* Compute intervening leap days correctly even if year is negative.
+ Take care to avoid int overflow in leap day calculations,
+ but it's OK to assume that A and B are close to each other. */
+ int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
+ int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
+ int a100 = a4 / 25 - (a4 % 25 < 0);
+ int b100 = b4 / 25 - (b4 % 25 < 0);
+ int a400 = a100 >> 2;
+ int b400 = b100 >> 2;
+ int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
+ int years = a->tm_year - b->tm_year;
+ int days = (365 * years + intervening_leap_days
+ + (a->tm_yday - b->tm_yday));
+ return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
+ + (a->tm_min - b->tm_min))
+ + (a->tm_sec - b->tm_sec));
+ }
+
+ enum { tzeqlen = sizeof "TZ=" - 1 };
+
+ /* Time zones equivalent to current local time and to UTC, respectively. */
+ static timezone_t local_tz;
+ static timezone_t const utc_tz = 0;
+
+ static struct tm *
+ emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
+ {
+ tm = localtime_rz (tz, t, tm);
+ if (!tm && errno == ENOMEM)
+ memory_full (SIZE_MAX);
+ return tm;
+ }
+
+ static _Noreturn void
+ invalid_time_zone_specification (Lisp_Object zone)
+ {
+ xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
+ }
+
+ /* Free a timezone, except do not free the time zone for local time.
+ Freeing utc_tz is also a no-op. */
+ static void
+ xtzfree (timezone_t tz)
+ {
+ if (tz != local_tz)
+ tzfree (tz);
+ }
+
+ /* Convert the Lisp time zone rule ZONE to a timezone_t object.
+ The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
+ If SETTZ, set Emacs local time to the time zone rule; otherwise,
+ the caller should eventually pass the returned value to xtzfree. */
+ static timezone_t
+ tzlookup (Lisp_Object zone, bool settz)
+ {
+ static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
+ char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
+ char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
+ char const *zone_string;
+ timezone_t new_tz;
+
+ if (NILP (zone))
+ return local_tz;
+ else if (EQ (zone, Qt) || EQ (zone, make_fixnum (0)))
+ {
+ zone_string = "UTC0";
+ new_tz = utc_tz;
+ }
+ else
+ {
+ bool plain_integer = FIXNUMP (zone);
+
+ if (EQ (zone, Qwall))
+ zone_string = 0;
+ else if (STRINGP (zone))
+ zone_string = SSDATA (ENCODE_SYSTEM (zone));
+ else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone))
+ && CONSP (XCDR (zone))))
+ {
+ Lisp_Object abbr UNINIT;
+ if (!plain_integer)
+ {
+ abbr = XCAR (XCDR (zone));
+ zone = XCAR (zone);
+ }
+
+ EMACS_INT abszone = eabs (XFIXNUM (zone)), hour = abszone / (60 * 60);
+ int hour_remainder = abszone % (60 * 60);
+ int min = hour_remainder / 60, sec = hour_remainder % 60;
+
+ if (plain_integer)
+ {
+ int prec = 2;
+ EMACS_INT numzone = hour;
+ if (hour_remainder != 0)
+ {
+ prec += 2, numzone = 100 * numzone + min;
+ if (sec != 0)
+ prec += 2, numzone = 100 * numzone + sec;
+ }
+ sprintf (tzbuf, tzbuf_format, prec,
+ XFIXNUM (zone) < 0 ? -numzone : numzone,
+ &"-"[XFIXNUM (zone) < 0], hour, min, sec);
+ zone_string = tzbuf;
+ }
+ else
+ {
+ AUTO_STRING (leading, "<");
+ AUTO_STRING_WITH_LEN (trailing, tzbuf,
+ sprintf (tzbuf, trailing_tzbuf_format,
+ &"-"[XFIXNUM (zone) < 0],
+ hour, min, sec));
+ zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
+ trailing));
+ }
+ }
+ else
+ invalid_time_zone_specification (zone);
+
+ new_tz = tzalloc (zone_string);
+
+ if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer
+ && XFIXNUM (zone) % (60 * 60) == 0)
+ {
+ /* tzalloc mishandles POSIX strings; fall back on tzdb if
+ possible (Bug#30738). */
+ sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XFIXNUM (zone) / (60 * 60)));
+ new_tz = tzalloc (zone_string);
+ }
+
+ if (!new_tz)
+ {
+ if (errno == ENOMEM)
+ memory_full (SIZE_MAX);
+ invalid_time_zone_specification (zone);
+ }
+ }
+
+ if (settz)
+ {
+ block_input ();
+ emacs_setenv_TZ (zone_string);
+ tzset ();
+ timezone_t old_tz = local_tz;
+ local_tz = new_tz;
+ tzfree (old_tz);
+ unblock_input ();
+ }
+
+ return new_tz;
+ }
+
+ void
- if (dumping)
++init_timefns (void)
+ {
+ #ifndef CANNOT_DUMP
+ /* A valid but unlikely setting for the TZ environment variable.
+ It is OK (though a bit slower) if the user chooses this value. */
+ static char dump_tz_string[] = "TZ=UtC0";
+
+ /* When just dumping out, set the time zone to a known unlikely value
+ and skip the rest of this function. */
++ if (will_dump_with_unexec_p ())
+ {
+ xputenv (dump_tz_string);
+ tzset ();
+ return;
+ }
+ #endif
+
+ char *tz = getenv ("TZ");
+
+ #if !defined CANNOT_DUMP
+ /* If the execution TZ happens to be the same as the dump TZ,
+ change it to some other value and then change it back,
+ to force the underlying implementation to reload the TZ info.
+ This is needed on implementations that load TZ info from files,
+ since the TZ file contents may differ between dump and execution. */
+ if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
+ {
+ ++*tz;
+ tzset ();
+ --*tz;
+ }
+ #endif
+
+ /* Set the time zone rule now, so that the call to putenv is done
+ before multiple threads are active. */
+ tzlookup (tz ? build_string (tz) : Qwall, true);
+ }
+
+ /* Report that a time value is out of range for Emacs. */
+ void
+ time_overflow (void)
+ {
+ error ("Specified time is not representable");
+ }
+
+ static _Noreturn void
+ time_error (int err)
+ {
+ switch (err)
+ {
+ case ENOMEM: memory_full (SIZE_MAX);
+ case EOVERFLOW: time_overflow ();
+ default: error ("Invalid time specification");
+ }
+ }
+
+ static _Noreturn void
+ invalid_hz (Lisp_Object hz)
+ {
+ xsignal2 (Qerror, build_string ("Invalid time frequency"), hz);
+ }
+
+ /* Return the upper part of the time T (everything but the bottom 16 bits). */
+ static Lisp_Object
+ hi_time (time_t t)
+ {
+ return INT_TO_INTEGER (t >> LO_TIME_BITS);
+ }
+
+ /* Return the bottom bits of the time T. */
+ static Lisp_Object
+ lo_time (time_t t)
+ {
+ return make_fixnum (t & ((1 << LO_TIME_BITS) - 1));
+ }
+
+ /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
+ Return zero if successful, an error number otherwise. */
+ static int
+ decode_float_time (double t, struct lisp_time *result)
+ {
+ if (!isfinite (t))
+ return isnan (t) ? EINVAL : EOVERFLOW;
+ /* Actual hz unknown; guess TIMESPEC_HZ. */
+ mpz_set_d (mpz[1], t);
+ mpz_set_si (mpz[0], floor ((t - trunc (t)) * TIMESPEC_HZ));
+ mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ);
+ result->ticks = make_integer_mpz ();
+ result->hz = timespec_hz;
+ return 0;
+ }
+
+ /* Compute S + NS/TIMESPEC_HZ as a double.
+ Calls to this function suffer from double-rounding;
+ work around some of the problem by using long double. */
+ static double
+ s_ns_to_double (long double s, long double ns)
+ {
+ return s + ns / TIMESPEC_HZ;
+ }
+
+ /* Make a 4-element timestamp (HI LO US PS) from TICKS and HZ.
+ Drop any excess precision. */
+ static Lisp_Object
+ ticks_hz_list4 (Lisp_Object ticks, Lisp_Object hz)
+ {
+ mpz_t *zticks = bignum_integer (&mpz[0], ticks);
+ #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
+ mpz_mul_ui (mpz[0], *zticks, TRILLION);
+ #else
+ mpz_mul (mpz[0], *zticks, ztrillion);
+ #endif
+ mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz));
+ #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX
+ unsigned long int fullps = mpz_fdiv_q_ui (mpz[0], mpz[0], TRILLION);
+ int us = fullps / 1000000;
+ int ps = fullps % 1000000;
+ #else
+ mpz_fdiv_qr (mpz[0], mpz[1], mpz[0], ztrillion);
+ int ps = mpz_fdiv_q_ui (mpz[1], mpz[1], 1000000);
+ int us = mpz_get_ui (mpz[1]);
+ #endif
+ unsigned long ulo = mpz_get_ui (mpz[0]);
+ if (mpz_sgn (mpz[0]) < 0)
+ ulo = -ulo;
+ int lo = ulo & ((1 << LO_TIME_BITS) - 1);
+ mpz_fdiv_q_2exp (mpz[0], mpz[0], LO_TIME_BITS);
+ return list4 (make_integer_mpz (), make_fixnum (lo),
+ make_fixnum (us), make_fixnum (ps));
+ }
+
+ /* Set ROP to T. */
+ static void
+ mpz_set_time (mpz_t rop, time_t t)
+ {
+ if (EXPR_SIGNED (t))
+ mpz_set_intmax (rop, t);
+ else
+ mpz_set_uintmax (rop, t);
+ }
+
+ /* Store into mpz[0] a clock tick count for T, assuming a
+ TIMESPEC_HZ-frequency clock. Use mpz[1] as a temp. */
+ static void
+ timespec_mpz (struct timespec t)
+ {
+ mpz_set_ui (mpz[0], t.tv_nsec);
+ mpz_set_time (mpz[1], t.tv_sec);
+ mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ);
+ }
+
+ /* Convert T to a Lisp integer counting TIMESPEC_HZ ticks. */
+ static Lisp_Object
+ timespec_ticks (struct timespec t)
+ {
+ intmax_t accum;
+ if (FASTER_TIMEFNS
+ && !INT_MULTIPLY_WRAPV (t.tv_sec, TIMESPEC_HZ, &accum)
+ && !INT_ADD_WRAPV (t.tv_nsec, accum, &accum))
+ return make_int (accum);
+ timespec_mpz (t);
+ return make_integer_mpz ();
+ }
+
+ /* Convert T to a Lisp integer counting HZ ticks, taking the floor.
+ Assume T is valid, but check HZ. */
+ static Lisp_Object
+ time_hz_ticks (time_t t, Lisp_Object hz)
+ {
+ if (FIXNUMP (hz))
+ {
+ if (XFIXNUM (hz) <= 0)
+ invalid_hz (hz);
+ intmax_t ticks;
+ if (FASTER_TIMEFNS && !INT_MULTIPLY_WRAPV (t, XFIXNUM (hz), &ticks))
+ return make_int (ticks);
+ }
+ else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))
+ invalid_hz (hz);
+
+ mpz_set_time (mpz[0], t);
+ mpz_mul (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz));
+ return make_integer_mpz ();
+ }
+ static Lisp_Object
+ lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz)
+ {
+ if (FASTER_TIMEFNS && EQ (t.hz, hz))
+ return t.ticks;
+ if (FIXNUMP (hz))
+ {
+ if (XFIXNUM (hz) <= 0)
+ invalid_hz (hz);
+ intmax_t ticks;
+ if (FASTER_TIMEFNS && FIXNUMP (t.ticks) && FIXNUMP (t.hz)
+ && !INT_MULTIPLY_WRAPV (XFIXNUM (t.ticks), XFIXNUM (hz), &ticks))
+ return make_int (ticks / XFIXNUM (t.hz)
+ - (ticks % XFIXNUM (t.hz) < 0));
+ }
+ else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))
+ invalid_hz (hz);
+
+ mpz_mul (mpz[0],
+ *bignum_integer (&mpz[0], t.ticks),
+ *bignum_integer (&mpz[1], hz));
+ mpz_fdiv_q (mpz[0], mpz[0], *bignum_integer (&mpz[1], t.hz));
+ return make_integer_mpz ();
+ }
+
+ /* Convert T to a Lisp integer counting seconds, taking the floor. */
+ static Lisp_Object
+ lisp_time_seconds (struct lisp_time t)
+ {
+ if (!FASTER_TIMEFNS)
+ return lisp_time_hz_ticks (t, make_fixnum (1));
+ if (FIXNUMP (t.ticks) && FIXNUMP (t.hz))
+ return make_fixnum (XFIXNUM (t.ticks) / XFIXNUM (t.hz)
+ - (XFIXNUM (t.ticks) % XFIXNUM (t.hz) < 0));
+ mpz_fdiv_q (mpz[0],
+ *bignum_integer (&mpz[0], t.ticks),
+ *bignum_integer (&mpz[1], t.hz));
+ return make_integer_mpz ();
+ }
+
+ /* Convert T to a Lisp timestamp. */
+ Lisp_Object
+ make_lisp_time (struct timespec t)
+ {
+ if (CURRENT_TIME_LIST)
+ {
+ time_t s = t.tv_sec;
+ int ns = t.tv_nsec;
+ return list4 (hi_time (s), lo_time (s),
+ make_fixnum (ns / 1000), make_fixnum (ns % 1000 * 1000));
+ }
+ else
+ return Fcons (timespec_ticks (t), timespec_hz);
+ }
+
+ /* Convert T to a Lisp timestamp. FORM specifies the timestamp format. */
+ static Lisp_Object
+ time_form_stamp (time_t t, Lisp_Object form)
+ {
+ if (NILP (form))
+ form = CURRENT_TIME_LIST ? Qlist : Qt;
+ if (EQ (form, Qlist))
+ return list2 (hi_time (t), lo_time (t));
+ if (EQ (form, Qt) || EQ (form, Qinteger))
+ return INT_TO_INTEGER (t);
+ return Fcons (time_hz_ticks (t, form), form);
+ }
+ static Lisp_Object
+ lisp_time_form_stamp (struct lisp_time t, Lisp_Object form)
+ {
+ if (NILP (form))
+ form = CURRENT_TIME_LIST ? Qlist : Qt;
+ if (EQ (form, Qlist))
+ return ticks_hz_list4 (t.ticks, t.hz);
+ if (EQ (form, Qinteger))
+ return lisp_time_seconds (t);
+ if (EQ (form, Qt))
+ form = t.hz;
+ return Fcons (lisp_time_hz_ticks (t, form), form);
+ }
+
+ /* From what should be a valid timestamp (TICKS . HZ), generate the
+ corresponding time values.
+
+ If RESULT is not null, store into *RESULT the converted time.
+ Otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Return zero if successful, an error number if (TICKS . HZ) would not
+ be a valid new-format timestamp. */
+ static int
+ decode_ticks_hz (Lisp_Object ticks, Lisp_Object hz,
+ struct lisp_time *result, double *dresult)
+ {
+ int ns;
+ mpz_t *q = &mpz[0];
+
+ if (! (INTEGERP (ticks)
+ && ((FIXNUMP (hz) && 0 < XFIXNUM (hz))
+ || (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value)))))
+ return EINVAL;
+
+ if (result)
+ {
+ result->ticks = ticks;
+ result->hz = hz;
+ }
+ else
+ {
+ if (FASTER_TIMEFNS && EQ (hz, timespec_hz))
+ {
+ if (FIXNUMP (ticks))
+ {
+ verify (1 < TIMESPEC_HZ);
+ EMACS_INT s = XFIXNUM (ticks) / TIMESPEC_HZ;
+ ns = XFIXNUM (ticks) % TIMESPEC_HZ;
+ if (ns < 0)
+ s--, ns += TIMESPEC_HZ;
+ *dresult = s_ns_to_double (s, ns);
+ return 0;
+ }
+ ns = mpz_fdiv_q_ui (*q, XBIGNUM (ticks)->value, TIMESPEC_HZ);
+ }
+ else if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1)))
+ {
+ ns = 0;
+ if (FIXNUMP (ticks))
+ {
+ *dresult = XFIXNUM (ticks);
+ return 0;
+ }
+ q = &XBIGNUM (ticks)->value;
+ }
+ else
+ {
+ mpz_mul_ui (*q, *bignum_integer (&mpz[1], ticks), TIMESPEC_HZ);
+ mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], hz));
+ ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ);
+ }
+
+ *dresult = s_ns_to_double (mpz_get_d (*q), ns);
+ }
+
+ return 0;
+ }
+
+ /* Lisp timestamp classification. */
+ enum timeform
+ {
+ TIMEFORM_INVALID = 0,
+ TIMEFORM_HI_LO, /* seconds in the form (HI << LO_TIME_BITS) + LO. */
+ TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */
+ TIMEFORM_NIL, /* current time in nanoseconds */
+ TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */
+ TIMEFORM_FLOAT, /* time as a float */
+ TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */
+ };
+
+ /* From the valid form FORM and the time components HIGH, LOW, USEC
+ and PSEC, generate the corresponding time value. If LOW is
+ floating point, the other components should be zero and FORM should
+ not be TIMEFORM_TICKS_HZ.
+
+ If RESULT is not null, store into *RESULT the converted time.
+ Otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Return zero if successful, an error number otherwise. */
+ static int
+ decode_time_components (enum timeform form,
+ Lisp_Object high, Lisp_Object low,
+ Lisp_Object usec, Lisp_Object psec,
+ struct lisp_time *result, double *dresult)
+ {
+ switch (form)
+ {
+ case TIMEFORM_INVALID:
+ return EINVAL;
+
+ case TIMEFORM_TICKS_HZ:
+ return decode_ticks_hz (high, low, result, dresult);
+
+ case TIMEFORM_FLOAT:
+ {
+ double t = XFLOAT_DATA (low);
+ if (result)
+ return decode_float_time (t, result);
+ else
+ {
+ *dresult = t;
+ return 0;
+ }
+ }
+
+ case TIMEFORM_NIL:
+ {
+ struct timespec now = current_timespec ();
+ if (result)
+ {
+ result->ticks = timespec_ticks (now);
+ result->hz = timespec_hz;
+ }
+ else
+ *dresult = s_ns_to_double (now.tv_sec, now.tv_nsec);
+ return 0;
+ }
+
+ default:
+ break;
+ }
+
+ if (! (INTEGERP (high) && INTEGERP (low)
+ && FIXNUMP (usec) && FIXNUMP (psec)))
+ return EINVAL;
+ EMACS_INT us = XFIXNUM (usec);
+ EMACS_INT ps = XFIXNUM (psec);
+
+ /* Normalize out-of-range lower-order components by carrying
+ each overflow into the next higher-order component. */
+ us += ps / 1000000 - (ps % 1000000 < 0);
+ mpz_set_intmax (mpz[0], us / 1000000 - (us % 1000000 < 0));
+ mpz_add (mpz[0], mpz[0], *bignum_integer (&mpz[1], low));
+ mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], high), 1 << LO_TIME_BITS);
+ ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
+ us = us % 1000000 + 1000000 * (us % 1000000 < 0);
+
+ if (result)
+ {
+ switch (form)
+ {
+ case TIMEFORM_HI_LO:
+ /* Floats and nil were handled above, so it was an integer. */
+ result->hz = make_fixnum (1);
+ break;
+
+ case TIMEFORM_HI_LO_US:
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], us);
+ result->hz = make_fixnum (1000000);
+ break;
+
+ case TIMEFORM_HI_LO_US_PS:
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], us);
+ mpz_mul_ui (mpz[0], mpz[0], 1000000);
+ mpz_add_ui (mpz[0], mpz[0], ps);
+ result->hz = trillion;
+ break;
+
+ default:
+ eassume (false);
+ }
+ result->ticks = make_integer_mpz ();
+ }
+ else
+ *dresult = mpz_get_d (mpz[0]) + (us * 1e6L + ps) / 1e12L;
+
+ return 0;
+ }
+
+ enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 };
+
+ /* Decode a Lisp timestamp SPECIFIED_TIME that represents a time.
+
+ FLAGS specifies conversion flags. If FLAGS & DECODE_SECS_ONLY,
+ ignore and do not validate any sub-second components of an
+ old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS,
+ diagnose what could be obsolete (HIGH . LOW) timestamps.
+
+ If PFORM is not null, store into *PFORM the form of SPECIFIED-TIME.
+ If RESULT is not null, store into *RESULT the converted time;
+ otherwise, store into *DRESULT the number of seconds since the
+ start of the POSIX Epoch. Unsuccessful calls may or may not store
+ results.
+
+ Signal an error if unsuccessful. */
+ static void
+ decode_lisp_time (Lisp_Object specified_time, int flags,
+ enum timeform *pform,
+ struct lisp_time *result, double *dresult)
+ {
+ Lisp_Object high = make_fixnum (0);
+ Lisp_Object low = specified_time;
+ Lisp_Object usec = make_fixnum (0);
+ Lisp_Object psec = make_fixnum (0);
+ enum timeform form = TIMEFORM_HI_LO;
+
+ if (NILP (specified_time))
+ form = TIMEFORM_NIL;
+ else if (FLOATP (specified_time))
+ form = TIMEFORM_FLOAT;
+ else if (CONSP (specified_time))
+ {
+ high = XCAR (specified_time);
+ low = XCDR (specified_time);
+ if (CONSP (low))
+ {
+ Lisp_Object low_tail = XCDR (low);
+ low = XCAR (low);
+ if (! (flags & DECODE_SECS_ONLY))
+ {
+ if (CONSP (low_tail))
+ {
+ usec = XCAR (low_tail);
+ low_tail = XCDR (low_tail);
+ if (CONSP (low_tail))
+ {
+ psec = XCAR (low_tail);
+ form = TIMEFORM_HI_LO_US_PS;
+ }
+ else
+ form = TIMEFORM_HI_LO_US;
+ }
+ else if (!NILP (low_tail))
+ {
+ usec = low_tail;
+ form = TIMEFORM_HI_LO_US;
+ }
+ }
+ }
+ else
+ {
+ if (flags & WARN_OBSOLETE_TIMESTAMPS
+ && RANGED_FIXNUMP (0, low, (1 << LO_TIME_BITS) - 1))
+ message ("obsolete timestamp with cdr %"pI"d", XFIXNUM (low));
+ form = TIMEFORM_TICKS_HZ;
+ }
+
+ /* Require LOW to be an integer, as otherwise the computation
+ would be considerably trickier. */
+ if (! INTEGERP (low))
+ form = TIMEFORM_INVALID;
+ }
+
+ if (pform)
+ *pform = form;
+ int err = decode_time_components (form, high, low, usec, psec,
+ result, dresult);
+ if (err)
+ time_error (err);
+ }
+
+ /* Convert Z to time_t, returning true if it fits. */
+ static bool
+ mpz_time (mpz_t const z, time_t *t)
+ {
+ if (TYPE_SIGNED (time_t))
+ {
+ intmax_t i;
+ if (! (mpz_to_intmax (z, &i) && TIME_T_MIN <= i && i <= TIME_T_MAX))
+ return false;
+ *t = i;
+ }
+ else
+ {
+ uintmax_t i;
+ if (! (mpz_to_uintmax (z, &i) && i <= TIME_T_MAX))
+ return false;
+ *t = i;
+ }
+ return true;
+ }
+
+ /* Convert T to struct timespec, returning an invalid timespec
+ if T does not fit. */
+ static struct timespec
+ lisp_to_timespec (struct lisp_time t)
+ {
+ struct timespec result = invalid_timespec ();
+ int ns;
+ mpz_t *q = &mpz[0];
+
+ if (FASTER_TIMEFNS && EQ (t.hz, timespec_hz))
+ {
+ if (FIXNUMP (t.ticks))
+ {
+ EMACS_INT s = XFIXNUM (t.ticks) / TIMESPEC_HZ;
+ ns = XFIXNUM (t.ticks) % TIMESPEC_HZ;
+ if (ns < 0)
+ s--, ns += TIMESPEC_HZ;
+ if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
+ && s <= TIME_T_MAX)
+ {
+ result.tv_sec = s;
+ result.tv_nsec = ns;
+ }
+ return result;
+ }
+ else
+ ns = mpz_fdiv_q_ui (*q, XBIGNUM (t.ticks)->value, TIMESPEC_HZ);
+ }
+ else if (FASTER_TIMEFNS && EQ (t.hz, make_fixnum (1)))
+ {
+ ns = 0;
+ if (FIXNUMP (t.ticks))
+ {
+ EMACS_INT s = XFIXNUM (t.ticks);
+ if ((TYPE_SIGNED (time_t) ? TIME_T_MIN <= s : 0 <= s)
+ && s <= TIME_T_MAX)
+ {
+ result.tv_sec = s;
+ result.tv_nsec = ns;
+ }
+ return result;
+ }
+ else
+ q = &XBIGNUM (t.ticks)->value;
+ }
+ else
+ {
+ mpz_mul_ui (*q, *bignum_integer (q, t.ticks), TIMESPEC_HZ);
+ mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], t.hz));
+ ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ);
+ }
+
+ /* With some versions of MinGW, tv_sec is a 64-bit type, whereas
+ time_t is a 32-bit type. */
+ time_t sec;
+ if (mpz_time (*q, &sec))
+ {
+ result.tv_sec = sec;
+ result.tv_nsec = ns;
+ }
+ return result;
+ }
+
+ /* Convert (HIGH LOW USEC PSEC) to struct timespec.
+ Return true if successful. */
+ bool
+ list4_to_timespec (Lisp_Object high, Lisp_Object low,
+ Lisp_Object usec, Lisp_Object psec,
+ struct timespec *result)
+ {
+ struct lisp_time t;
+ if (decode_time_components (TIMEFORM_HI_LO_US_PS, high, low, usec, psec,
+ &t, 0))
+ return false;
+ *result = lisp_to_timespec (t);
+ return timespec_valid_p (*result);
+ }
+
+ /* Decode a Lisp list SPECIFIED_TIME that represents a time.
+ If SPECIFIED_TIME is nil, use the current time.
+ Signal an error if SPECIFIED_TIME does not represent a time. */
+ static struct lisp_time
+ lisp_time_struct (Lisp_Object specified_time, enum timeform *pform)
+ {
+ struct lisp_time t;
+ decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, pform, &t, 0);
+ return t;
+ }
+
+ /* Decode a Lisp list SPECIFIED_TIME that represents a time.
+ Discard any low-order (sub-ns) resolution.
+ If SPECIFIED_TIME is nil, use the current time.
+ Signal an error if SPECIFIED_TIME does not represent a timespec. */
+ struct timespec
+ lisp_time_argument (Lisp_Object specified_time)
+ {
+ struct lisp_time lt = lisp_time_struct (specified_time, 0);
+ struct timespec t = lisp_to_timespec (lt);
+ if (! timespec_valid_p (t))
+ time_overflow ();
+ return t;
+ }
+
+ /* Like lisp_time_argument, except decode only the seconds part, and
+ do not check the subseconds part. */
+ static time_t
+ lisp_seconds_argument (Lisp_Object specified_time)
+ {
+ int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY;
+ struct lisp_time lt;
+ decode_lisp_time (specified_time, flags, 0, <, 0);
+ struct timespec t = lisp_to_timespec (lt);
+ if (! timespec_valid_p (t))
+ time_overflow ();
+ return t.tv_sec;
+ }
+
+ /* Given Lisp operands A and B, add their values, and return the
+ result as a Lisp timestamp that is in (TICKS . HZ) form if either A
+ or B are in that form, (HI LO US PS) form otherwise. Subtract
+ instead of adding if SUBTRACT. */
+ static Lisp_Object
+ time_arith (Lisp_Object a, Lisp_Object b, bool subtract)
+ {
+ if (FLOATP (a) && !isfinite (XFLOAT_DATA (a)))
+ {
+ double da = XFLOAT_DATA (a);
+ double db = XFLOAT_DATA (Ffloat_time (b));
+ return make_float (subtract ? da - db : da + db);
+ }
+ if (FLOATP (b) && !isfinite (XFLOAT_DATA (b)))
+ return subtract ? make_float (-XFLOAT_DATA (b)) : b;
+
+ enum timeform aform, bform;
+ struct lisp_time ta = lisp_time_struct (a, &aform);
+ struct lisp_time tb = lisp_time_struct (b, &bform);
+ Lisp_Object ticks, hz;
+
+ if (FASTER_TIMEFNS && EQ (ta.hz, tb.hz))
+ {
+ hz = ta.hz;
+ if (FIXNUMP (ta.ticks) && FIXNUMP (tb.ticks))
+ ticks = make_int (subtract
+ ? XFIXNUM (ta.ticks) - XFIXNUM (tb.ticks)
+ : XFIXNUM (ta.ticks) + XFIXNUM (tb.ticks));
+ else
+ {
+ (subtract ? mpz_sub : mpz_add)
+ (mpz[0],
+ *bignum_integer (&mpz[0], ta.ticks),
+ *bignum_integer (&mpz[1], tb.ticks));
+ ticks = make_integer_mpz ();
+ }
+ }
+ else
+ {
+ /* The plan is to decompose ta into na/da and tb into nb/db.
+ Start by computing da and db. */
+ mpz_t *da = bignum_integer (&mpz[1], ta.hz);
+ mpz_t *db = bignum_integer (&mpz[2], tb.hz);
+
+ /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db)
+ where g = gcd (da, db). Start by computing g. */
+ mpz_t *g = &mpz[3];
+ mpz_gcd (*g, *da, *db);
+
+ /* fa = da/g, fb = db/g. */
+ mpz_t *fa = &mpz[1], *fb = &mpz[3];
+ mpz_tdiv_q (*fa, *da, *g);
+ mpz_tdiv_q (*fb, *db, *g);
+
+ /* FIXME: Maybe omit need for extra temp by computing fa * db here? */
+
+ /* hz = fa * db. This is equal to lcm (da, db). */
+ mpz_mul (mpz[0], *fa, *db);
+ hz = make_integer_mpz ();
+
+ /* ticks = (fb * na) OPER (fa * nb), where OPER is + or -.
+ OP is the multiply-add or multiply-sub form of OPER. */
+ mpz_t *na = bignum_integer (&mpz[0], ta.ticks);
+ mpz_mul (mpz[0], *fb, *na);
+ mpz_t *nb = bignum_integer (&mpz[3], tb.ticks);
+ (subtract ? mpz_submul : mpz_addmul) (mpz[0], *fa, *nb);
+ ticks = make_integer_mpz ();
+ }
+
+ /* Return the (TICKS . HZ) form if either argument is that way,
+ otherwise the (HI LO US PS) form for backward compatibility. */
+ return (aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ
+ ? Fcons (ticks, hz)
+ : ticks_hz_list4 (ticks, hz));
+ }
+
+ DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
+ doc: /* Return the sum of two time values A and B, as a time value.
+ See `format-time-string' for the various forms of a time value.
+ For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+ {
+ return time_arith (a, b, false);
+ }
+
+ DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
+ doc: /* Return the difference between two time values A and B, as a time value.
+ You can use `float-time' to convert the difference into elapsed seconds.
+ See `format-time-string' for the various forms of a time value.
+ For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+ {
+ return time_arith (a, b, true);
+ }
+
+ /* Return negative, 0, positive if a < b, a == b, a > b respectively.
+ Return positive if either a or b is a NaN; this is good enough
+ for the current callers. */
+ static int
+ time_cmp (Lisp_Object a, Lisp_Object b)
+ {
+ if ((FLOATP (a) && !isfinite (XFLOAT_DATA (a)))
+ || (FLOATP (b) && !isfinite (XFLOAT_DATA (b))))
+ {
+ double da = FLOATP (a) ? XFLOAT_DATA (a) : 0;
+ double db = FLOATP (b) ? XFLOAT_DATA (b) : 0;
+ return da < db ? -1 : da != db;
+ }
+
+ struct lisp_time ta = lisp_time_struct (a, 0);
+
+ /* Compare nil to nil correctly, and other eq values while we're at it.
+ Compare here rather than earlier, to handle NaNs and check formats. */
+ if (EQ (a, b))
+ return 0;
+
+ struct lisp_time tb = lisp_time_struct (b, 0);
+ mpz_t *za = bignum_integer (&mpz[0], ta.ticks);
+ mpz_t *zb = bignum_integer (&mpz[1], tb.ticks);
+ if (! (FASTER_TIMEFNS && EQ (ta.hz, tb.hz)))
+ {
+ /* This could be sped up by looking at the signs, sizes, and
+ number of bits of the two sides; see how GMP does mpq_cmp.
+ It may not be worth the trouble here, though. */
+ mpz_mul (mpz[0], *za, *bignum_integer (&mpz[2], tb.hz));
+ mpz_mul (mpz[1], *zb, *bignum_integer (&mpz[2], ta.hz));
+ za = &mpz[0];
+ zb = &mpz[1];
+ }
+ return mpz_cmp (*za, *zb);
+ }
+
+ DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
+ doc: /* Return non-nil if time value A is less than time value B.
+ See `format-time-string' for the various forms of a time value.
+ For example, nil stands for the current time. */)
+ (Lisp_Object a, Lisp_Object b)
+ {
+ return time_cmp (a, b) < 0 ? Qt : Qnil;
+ }
+
+ DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0,
+ doc: /* Return non-nil if A and B are equal time values.
+ See `format-time-string' for the various forms of a time value. */)
+ (Lisp_Object a, Lisp_Object b)
+ {
+ return time_cmp (a, b) == 0 ? Qt : Qnil;
+ }
+ \f
+
+ DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
+ doc: /* Return the current time, as a float number of seconds since the epoch.
+ If SPECIFIED-TIME is given, it is a time value to convert to float
+ instead of the current time. See `format-time-string' for the various
+ forms of a time value.
+
+ WARNING: Since the result is floating point, it may not be exact.
+ If precise time stamps are required, use either `encode-time',
+ or (if you need time as a string) `format-time-string'. */)
+ (Lisp_Object specified_time)
+ {
+ double t;
+ decode_lisp_time (specified_time, 0, 0, 0, &t);
+ return make_float (t);
+ }
+
+ /* Write information into buffer S of size MAXSIZE, according to the
+ FORMAT of length FORMAT_LEN, using time information taken from *TP.
+ Use the time zone specified by TZ.
+ Use NS as the number of nanoseconds in the %N directive.
+ Return the number of bytes written, not including the terminating
+ '\0'. If S is NULL, nothing will be written anywhere; so to
+ determine how many bytes would be written, use NULL for S and
+ ((size_t) -1) for MAXSIZE.
+
+ This function behaves like nstrftime, except it allows null
+ bytes in FORMAT and it does not support nanoseconds. */
+ static size_t
+ emacs_nmemftime (char *s, size_t maxsize, const char *format,
+ size_t format_len, const struct tm *tp, timezone_t tz, int ns)
+ {
+ size_t total = 0;
+
+ /* Loop through all the null-terminated strings in the format
+ argument. Normally there's just one null-terminated string, but
+ there can be arbitrarily many, concatenated together, if the
+ format contains '\0' bytes. nstrftime stops at the first
+ '\0' byte so we must invoke it separately for each such string. */
+ for (;;)
+ {
+ size_t len;
+ size_t result;
+
+ if (s)
+ s[0] = '\1';
+
+ result = nstrftime (s, maxsize, format, tp, tz, ns);
+
+ if (s)
+ {
+ if (result == 0 && s[0] != '\0')
+ return 0;
+ s += result + 1;
+ }
+
+ maxsize -= result + 1;
+ total += result;
+ len = strlen (format);
+ if (len == format_len)
+ return total;
+ total++;
+ format += len + 1;
+ format_len -= len + 1;
+ }
+ }
+
+ static Lisp_Object
+ format_time_string (char const *format, ptrdiff_t formatlen,
+ struct timespec t, Lisp_Object zone, struct tm *tmp)
+ {
+ char buffer[4000];
+ char *buf = buffer;
+ ptrdiff_t size = sizeof buffer;
+ size_t len;
+ int ns = t.tv_nsec;
+ USE_SAFE_ALLOCA;
+
+ timezone_t tz = tzlookup (zone, false);
+ /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
+ a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
+ expects a pointer to time_t value. */
+ time_t tsec = t.tv_sec;
+ tmp = emacs_localtime_rz (tz, &tsec, tmp);
+ if (! tmp)
+ {
+ int localtime_errno = errno;
+ xtzfree (tz);
+ time_error (localtime_errno);
+ }
+ synchronize_system_time_locale ();
+
+ while (true)
+ {
+ buf[0] = '\1';
+ len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
+ if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
+ break;
+
+ /* Buffer was too small, so make it bigger and try again. */
+ len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
+ if (STRING_BYTES_BOUND <= len)
+ {
+ xtzfree (tz);
+ string_overflow ();
+ }
+ size = len + 1;
+ buf = SAFE_ALLOCA (size);
+ }
+
+ xtzfree (tz);
+ AUTO_STRING_WITH_LEN (bufstring, buf, len);
+ Lisp_Object result = code_convert_string_norecord (bufstring,
+ Vlocale_coding_system, 0);
+ SAFE_FREE ();
+ return result;
+ }
+
+ DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
+ doc: /* Use FORMAT-STRING to format the time value TIME.
+ A time value that is omitted or nil stands for the current time,
+ a number stands for that many seconds, an integer pair (TICKS . HZ)
+ stands for TICKS/HZ seconds, and an integer list (HI LO US PS) stands
+ for HI*2**16 + LO + US/10**6 + PS/10**12 seconds. This function
+ treats seconds as time since the epoch of 1970-01-01 00:00:00 UTC.
+
+ The optional ZONE is omitted or nil for Emacs local time, t for
+ Universal Time, `wall' for system wall clock time, or a string as in
+ the TZ environment variable. It can also be a list (as from
+ `current-time-zone') or an integer (as from `decode-time') applied
+ without consideration for daylight saving time.
+
+ The value is a copy of FORMAT-STRING, but with certain constructs replaced
+ by text that describes the specified date and time in TIME:
+
+ %Y is the year, %y within the century, %C the century.
+ %G is the year corresponding to the ISO week, %g within the century.
+ %m is the numeric month.
+ %b and %h are the locale's abbreviated month name, %B the full name.
+ (%h is not supported on MS-Windows.)
+ %d is the day of the month, zero-padded, %e is blank-padded.
+ %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
+ %a is the locale's abbreviated name of the day of week, %A the full name.
+ %U is the week number starting on Sunday, %W starting on Monday,
+ %V according to ISO 8601.
+ %j is the day of the year.
+
+ %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
+ only blank-padded, %l is like %I blank-padded.
+ %p is the locale's equivalent of either AM or PM.
+ %q is the calendar quarter (1–4).
+ %M is the minute (00-59).
+ %S is the second (00-59; 00-60 on platforms with leap seconds)
+ %s is the number of seconds since 1970-01-01 00:00:00 +0000.
+ %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
+ %Z is the time zone abbreviation, %z is the numeric form.
+
+ %c is the locale's date and time format.
+ %x is the locale's "preferred" date format.
+ %D is like "%m/%d/%y".
+ %F is the ISO 8601 date format (like "%Y-%m-%d").
+
+ %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
+ %X is the locale's "preferred" time format.
+
+ Finally, %n is a newline, %t is a tab, %% is a literal %, and
+ unrecognized %-sequences stand for themselves.
+
+ Certain flags and modifiers are available with some format controls.
+ The flags are `_', `-', `^' and `#'. For certain characters X,
+ %_X is like %X, but padded with blanks; %-X is like %X,
+ but without padding. %^X is like %X, but with all textual
+ characters up-cased; %#X is like %X, but with letter-case of
+ all textual characters reversed.
+ %NX (where N stands for an integer) is like %X,
+ but takes up at least N (a number) positions.
+ The modifiers are `E' and `O'. For certain characters X,
+ %EX is a locale's alternative version of %X;
+ %OX is like %X, but uses the locale's number symbols.
+
+ For example, to produce full ISO 8601 format, use "%FT%T%z".
+
+ usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
+ (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
+ {
+ struct timespec t = lisp_time_argument (timeval);
+ struct tm tm;
+
+ CHECK_STRING (format_string);
+ format_string = code_convert_string_norecord (format_string,
+ Vlocale_coding_system, 1);
+ return format_time_string (SSDATA (format_string), SBYTES (format_string),
+ t, zone, &tm);
+ }
+
+ DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
+ doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
+ The optional TIME is the time value to convert. See
+ `format-time-string' for the various forms of a time value.
+
+ The optional ZONE is omitted or nil for Emacs local time, t for
+ Universal Time, `wall' for system wall clock time, or a string as in
+ the TZ environment variable. It can also be a list (as from
+ `current-time-zone') or an integer (the UTC offset in seconds) applied
+ without consideration for daylight saving time.
+
+ The list has the following nine members: SEC is an integer between 0
+ and 60; SEC is 60 for a leap second, which only some operating systems
+ support. MINUTE is an integer between 0 and 59. HOUR is an integer
+ between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
+ integer between 1 and 12. YEAR is an integer indicating the
+ four-digit year. DOW is the day of week, an integer between 0 and 6,
+ where 0 is Sunday. DST is t if daylight saving time is in effect,
+ nil if it is not in effect, and -1 if daylight saving information is
+ not available. UTCOFF is an integer indicating the UTC offset in
+ seconds, i.e., the number of seconds east of Greenwich. (Note that
+ Common Lisp has different meanings for DOW and UTCOFF.)
+
+ usage: (decode-time &optional TIME ZONE) */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+ {
+ time_t time_spec = lisp_seconds_argument (specified_time);
+ struct tm local_tm, gmt_tm;
+ timezone_t tz = tzlookup (zone, false);
+ struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
+ int localtime_errno = errno;
+ xtzfree (tz);
+
+ if (!tm)
+ time_error (localtime_errno);
+
+ Lisp_Object year;
+ if (FASTER_TIMEFNS
+ && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
+ && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
+ {
+ /* Avoid overflow when INT_MAX - TM_YEAR_BASE < local_tm.tm_year. */
+ EMACS_INT tm_year_base = TM_YEAR_BASE;
+ year = make_fixnum (local_tm.tm_year + tm_year_base);
+ }
+ else
+ {
+ mpz_set_si (mpz[0], local_tm.tm_year);
+ mpz_add_ui (mpz[0], mpz[0], TM_YEAR_BASE);
+ year = make_integer_mpz ();
+ }
+
+ return CALLN (Flist,
+ make_fixnum (local_tm.tm_sec),
+ make_fixnum (local_tm.tm_min),
+ make_fixnum (local_tm.tm_hour),
+ make_fixnum (local_tm.tm_mday),
+ make_fixnum (local_tm.tm_mon + 1),
+ year,
+ make_fixnum (local_tm.tm_wday),
+ (local_tm.tm_isdst < 0 ? make_fixnum (-1)
+ : local_tm.tm_isdst == 0 ? Qnil : Qt),
+ (HAVE_TM_GMTOFF
+ ? make_fixnum (tm_gmtoff (&local_tm))
+ : gmtime_r (&time_spec, &gmt_tm)
+ ? make_fixnum (tm_diff (&local_tm, &gmt_tm))
+ : Qnil));
+ }
+
+ /* Return OBJ - OFFSET, checking that OBJ is a valid integer and that
+ the result is representable as an int. 0 <= OFFSET <= TM_YEAR_BASE. */
+ static int
+ check_tm_member (Lisp_Object obj, int offset)
+ {
+ if (FASTER_TIMEFNS && INT_MAX <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE)
+ {
+ CHECK_FIXNUM (obj);
+ EMACS_INT n = XFIXNUM (obj);
+ int i;
+ if (INT_SUBTRACT_WRAPV (n, offset, &i))
+ time_overflow ();
+ return i;
+ }
+ else
+ {
+ CHECK_INTEGER (obj);
+ mpz_sub_ui (mpz[0], *bignum_integer (&mpz[0], obj), offset);
+ intmax_t i;
+ if (! (mpz_to_intmax (mpz[0], &i) && INT_MIN <= i && i <= INT_MAX))
+ time_overflow ();
+ return i;
+ }
+ }
+
+ DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0,
+ doc: /* Convert optional TIME to a timestamp.
+ Optional FORM specifies how the returned value should be encoded.
+ This can act as the reverse operation of `decode-time', which see.
+
+ If TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE)
+ it is a decoded time in the style of `decode-time', so that (encode-time
+ (decode-time ...)) works. TIME can also be a time value.
+ See `format-time-string' for the various forms of a time value.
+ For example, an omitted TIME stands for the current time.
+
+ If FORM is a positive integer, the time is returned as a pair of
+ integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM
+ is the clock frequency in ticks per second. (Currently the positive
+ integer should be at least 65536 if the returned value is expected to
+ be given to standard functions expecting Lisp timestamps.) If FORM is
+ t, the time is returned as (TICKS . PHZ), where PHZ is a platform dependent
+ clock frequency in ticks per second. If FORM is `integer', the time is
+ returned as an integer count of seconds. If FORM is `list', the time is
+ returned as an integer list (HIGH LOW USEC PSEC), where HIGH has the
+ most significant bits of the seconds, LOW has the least significant 16
+ bits, and USEC and PSEC are the microsecond and picosecond counts.
+ Returned values are rounded toward minus infinity. Although an
+ omitted or nil FORM currently acts like `list', this is planned to
+ change, so callers requiring list timestamps should specify `list'.
+
+ As an obsolescent calling convention, if this function is called with
+ 6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR,
+ DAY, MONTH, and YEAR, and specify the components of a decoded time,
+ where DST assumed to be -1 and FORM is omitted. If there are more
+ than 6 arguments the *last* argument is used as ZONE and any other
+ extra arguments are ignored, so that (apply #\\='encode-time
+ (decode-time ...)) works; otherwise ZONE is assumed to be nil.
+
+ If the input is a decoded time, ZONE is nil for Emacs local time, t
+ for Universal Time, `wall' for system wall clock time, or a string as
+ in the TZ environment variable. It can also be a list (as from
+ `current-time-zone') or an integer (as from `decode-time') applied
+ without consideration for daylight saving time.
+
+ If the input is a decoded time and ZONE specifies a time zone with
+ daylight-saving transitions, DST is t for daylight saving time and nil
+ for standard time. If DST is -1, the daylight saving flag is guessed.
+
+ Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
+ for example, a DAY of 0 means the day preceding the given month.
+ Year numbers less than 100 are treated just like other year numbers.
+ If you want them to stand for years in this century, you must do that yourself.
+
+ Years before 1970 are not guaranteed to work. On some systems,
+ year values as low as 1901 do work.
+
+ usage: (encode-time &optional TIME FORM &rest OBSOLESCENT-ARGUMENTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+ {
+ struct tm tm;
+ Lisp_Object form = Qnil, zone = Qnil;
+ Lisp_Object a = args[0];
+ tm.tm_isdst = -1;
+
+ if (nargs <= 2)
+ {
+ if (nargs == 2)
+ form = args[1];
+ Lisp_Object tail = a;
+ for (int i = 0; i < 9; i++, tail = XCDR (tail))
+ if (! CONSP (tail))
+ {
+ struct lisp_time t;
+ decode_lisp_time (a, 0, 0, &t, 0);
+ return lisp_time_form_stamp (t, form);
+ }
+ tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_hour = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_mday = check_tm_member (XCAR (a), 0); a = XCDR (a);
+ tm.tm_mon = check_tm_member (XCAR (a), 1); a = XCDR (a);
+ tm.tm_year = check_tm_member (XCAR (a), TM_YEAR_BASE); a = XCDR (a);
+ a = XCDR (a);
+ if (SYMBOLP (XCAR (a)))
+ tm.tm_isdst = !NILP (XCAR (a));
+ a = XCDR (a);
+ zone = XCAR (a);
+ }
+ else if (nargs < 6)
+ xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs));
+ else
+ {
+ if (6 < nargs)
+ zone = args[nargs - 1];
+ tm.tm_sec = check_tm_member (a, 0);
+ tm.tm_min = check_tm_member (args[1], 0);
+ tm.tm_hour = check_tm_member (args[2], 0);
+ tm.tm_mday = check_tm_member (args[3], 0);
+ tm.tm_mon = check_tm_member (args[4], 1);
+ tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
+ }
+
+ timezone_t tz = tzlookup (zone, false);
+ tm.tm_wday = -1;
+ time_t value = mktime_z (tz, &tm);
+ int mktime_errno = errno;
+ xtzfree (tz);
+
+ if (tm.tm_wday < 0)
+ time_error (mktime_errno);
+
+ return time_form_stamp (value, form);
+ }
+
+ DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
+ doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
+ The time is returned as a list of integers (HIGH LOW USEC PSEC).
+ HIGH has the most significant bits of the seconds, while LOW has the
+ least significant 16 bits. USEC and PSEC are the microsecond and
+ picosecond counts. Use `encode-time' if you need a particular
+ timestamp form; for example, (encode-time nil \\='integer) returns the
+ current time in seconds. */)
+ (void)
+ {
+ return make_lisp_time (current_timespec ());
+ }
+
+ DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
+ 0, 2, 0,
+ doc: /* Return the current local time, as a human-readable string.
+ Programs can use this function to decode a time,
+ since the number of columns in each field is fixed
+ if the year is in the range 1000-9999.
+ The format is `Sun Sep 16 01:03:52 1973'.
+ However, see also the functions `decode-time' and `format-time-string'
+ which provide a much more powerful and general facility.
+
+ If SPECIFIED-TIME is given, it is the time value to format instead of
+ the current time. See `format-time-string' for the various forms of a
+ time value.
+
+ The optional ZONE is omitted or nil for Emacs local time, t for
+ Universal Time, `wall' for system wall clock time, or a string as in
+ the TZ environment variable. It can also be a list (as from
+ `current-time-zone') or an integer (as from `decode-time') applied
+ without consideration for daylight saving time. */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+ {
+ time_t value = lisp_seconds_argument (specified_time);
+ timezone_t tz = tzlookup (zone, false);
+
+ /* Convert to a string in ctime format, except without the trailing
+ newline, and without the 4-digit year limit. Don't use asctime
+ or ctime, as they might dump core if the year is outside the
+ range -999 .. 9999. */
+ struct tm tm;
+ struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
+ int localtime_errno = errno;
+ xtzfree (tz);
+ if (! tmp)
+ time_error (localtime_errno);
+
+ static char const wday_name[][4] =
+ { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
+ static char const mon_name[][4] =
+ { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
+ printmax_t year_base = TM_YEAR_BASE;
+ char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
+ int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
+ wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
+ tm.tm_hour, tm.tm_min, tm.tm_sec,
+ tm.tm_year + year_base);
+
+ return make_unibyte_string (buf, len);
+ }
+
+ DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
+ doc: /* Return the offset and name for the local time zone.
+ This returns a list of the form (OFFSET NAME).
+ OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
+ A negative value means west of Greenwich.
+ NAME is a string giving the name of the time zone.
+ If SPECIFIED-TIME is given, the time zone offset is determined from it
+ instead of using the current time. The argument should be a Lisp
+ time value; see `format-time-string' for the various forms of a time
+ value.
+
+ The optional ZONE is omitted or nil for Emacs local time, t for
+ Universal Time, `wall' for system wall clock time, or a string as in
+ the TZ environment variable. It can also be a list (as from
+ `current-time-zone') or an integer (as from `decode-time') applied
+ without consideration for daylight saving time.
+
+ Some operating systems cannot provide all this information to Emacs;
+ in this case, `current-time-zone' returns a list containing nil for
+ the data it can't find. */)
+ (Lisp_Object specified_time, Lisp_Object zone)
+ {
+ struct timespec value;
+ struct tm local_tm, gmt_tm;
+ Lisp_Object zone_offset, zone_name;
+
+ zone_offset = Qnil;
+ value = make_timespec (lisp_seconds_argument (specified_time), 0);
+ zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
+ zone, &local_tm);
+
+ /* gmtime_r expects a pointer to time_t, but tv_sec of struct
+ timespec on some systems (MinGW) is a 64-bit field. */
+ time_t tsec = value.tv_sec;
+ if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
+ {
+ long int offset = (HAVE_TM_GMTOFF
+ ? tm_gmtoff (&local_tm)
+ : tm_diff (&local_tm, &gmt_tm));
+ zone_offset = make_fixnum (offset);
+ if (SCHARS (zone_name) == 0)
+ {
+ /* No local time zone name is available; use numeric zone instead. */
+ long int hour = offset / 3600;
+ int min_sec = offset % 3600;
+ int amin_sec = min_sec < 0 ? - min_sec : min_sec;
+ int min = amin_sec / 60;
+ int sec = amin_sec % 60;
+ int min_prec = min_sec ? 2 : 0;
+ int sec_prec = sec ? 2 : 0;
+ char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
+ zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
+ (offset < 0 ? '-' : '+'),
+ hour, min_prec, min, sec_prec, sec);
+ }
+ }
+
+ return list2 (zone_offset, zone_name);
+ }
+
+ DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
+ doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
+ If TZ is nil or `wall', use system wall clock time; this differs from
+ the usual Emacs convention where nil means current local time. If TZ
+ is t, use Universal Time. If TZ is a list (as from
+ `current-time-zone') or an integer (as from `decode-time'), use the
+ specified time zone without consideration for daylight saving time.
+
+ Instead of calling this function, you typically want something else.
+ To temporarily use a different time zone rule for just one invocation
+ of `decode-time', `encode-time', or `format-time-string', pass the
+ function a ZONE argument. To change local time consistently
+ throughout Emacs, call (setenv "TZ" TZ): this changes both the
+ environment of the Emacs process and the variable
+ `process-environment', whereas `set-time-zone-rule' affects only the
+ former. */)
+ (Lisp_Object tz)
+ {
+ tzlookup (NILP (tz) ? Qwall : tz, true);
+ return Qnil;
+ }
+
+ /* A buffer holding a string of the form "TZ=value", intended
+ to be part of the environment. If TZ is supposed to be unset,
+ the buffer string is "tZ=". */
+ static char *tzvalbuf;
+
+ /* Get the local time zone rule. */
+ char *
+ emacs_getenv_TZ (void)
+ {
+ return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
+ }
+
+ /* Set the local time zone rule to TZSTRING, which can be null to
+ denote wall clock time. Do not record the setting in LOCAL_TZ.
+
+ This function is not thread-safe, in theory because putenv is not,
+ but mostly because of the static storage it updates. Other threads
+ that invoke localtime etc. may be adversely affected while this
+ function is executing. */
+
+ int
+ emacs_setenv_TZ (const char *tzstring)
+ {
+ static ptrdiff_t tzvalbufsize;
+ ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
+ char *tzval = tzvalbuf;
+ bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
+
+ if (new_tzvalbuf)
+ {
+ /* Do not attempt to free the old tzvalbuf, since another thread
+ may be using it. In practice, the first allocation is large
+ enough and memory does not leak. */
+ tzval = xpalloc (NULL, &tzvalbufsize,
+ tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
+ tzvalbuf = tzval;
+ tzval[1] = 'Z';
+ tzval[2] = '=';
+ }
+
+ if (tzstring)
+ {
+ /* Modify TZVAL in place. Although this is dicey in a
+ multithreaded environment, we know of no portable alternative.
+ Calling putenv or setenv could crash some other thread. */
+ tzval[0] = 'T';
+ strcpy (tzval + tzeqlen, tzstring);
+ }
+ else
+ {
+ /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
+ Although this is also dicey, calling unsetenv here can crash Emacs.
+ See Bug#8705. */
+ tzval[0] = 't';
+ tzval[tzeqlen] = 0;
+ }
+
+
+ #ifndef WINDOWSNT
+ /* Modifying *TZVAL merely requires calling tzset (which is the
+ caller's responsibility). However, modifying TZVAL requires
+ calling putenv; although this is not thread-safe, in practice this
+ runs only on startup when there is only one thread. */
+ bool need_putenv = new_tzvalbuf;
+ #else
+ /* MS-Windows 'putenv' copies the argument string into a block it
+ allocates, so modifying *TZVAL will not change the environment.
+ However, the other threads run by Emacs on MS-Windows never call
+ 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
+ dicey in-place modification technique doesn't exist there in the
+ first place. */
+ bool need_putenv = true;
+ #endif
+ if (need_putenv)
+ xputenv (tzval);
+
+ return 0;
+ }
+
+ void
+ syms_of_timefns (void)
+ {
+ #ifndef timespec_hz
+ timespec_hz = make_int (TIMESPEC_HZ);
+ staticpro (×pec_hz);
+ #endif
+ #ifndef trillion
+ trillion = make_int (1000000000000);
+ staticpro (&trillion);
+ #endif
+ #if (ULONG_MAX < TRILLION || !FASTER_TIMEFNS) && !defined ztrillion
+ mpz_init_set_ui (ztrillion, 1000000);
+ mpz_mul_ui (ztrillion, ztrillion, 1000000);
+ #endif
+
+ DEFSYM (Qencode_time, "encode-time");
+
+ defsubr (&Scurrent_time);
+ defsubr (&Stime_add);
+ defsubr (&Stime_subtract);
+ defsubr (&Stime_less_p);
+ defsubr (&Stime_equal_p);
+ defsubr (&Sformat_time_string);
+ defsubr (&Sfloat_time);
+ defsubr (&Sdecode_time);
+ defsubr (&Sencode_time);
+ defsubr (&Scurrent_time_string);
+ defsubr (&Scurrent_time_zone);
+ defsubr (&Sset_time_zone_rule);
+ }
projects / emacs.git / commitdiff