From: Daniel Colascione Date: Mon, 14 Jan 2019 10:37:00 +0000 (-0800) Subject: checkpoint X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=7023360c46f19e5b8f64a13d41bb7e5146499c4b;p=emacs.git checkpoint --- 7023360c46f19e5b8f64a13d41bb7e5146499c4b diff --cc configure.ac index d2da890452f,16a2ce059df..75297194299 --- a/configure.ac +++ b/configure.ac @@@ -1310,50 -1227,52 +1312,48 @@@ AC_SUBST([FIND_DELETE] PAXCTL_dumped= PAXCTL_notdumped= -if test "$CANNOT_DUMP" != yes; then - if test $opsys = gnu-linux; then - if test "${SETFATTR+set}" != set; then - AC_CACHE_CHECK([for setfattr], - [emacs_cv_prog_setfattr], - [touch conftest.tmp - if (setfattr -n user.pax.flags conftest.tmp) >/dev/null 2>&1; then - emacs_cv_prog_setfattr=yes - else - emacs_cv_prog_setfattr=no - fi]) - if test "$emacs_cv_prog_setfattr" = yes; then - PAXCTL_notdumped='$(SETFATTR) -n user.pax.flags -v er' - SETFATTR=setfattr - else - SETFATTR= - fi - rm -f conftest.tmp - AC_SUBST([SETFATTR]) +if test "$CANNOT_DUMP" = "no" && test $opsys = gnu-linux; then + if test "${SETFATTR+set}" != set; then + AC_CACHE_CHECK([for setfattr], + [emacs_cv_prog_setfattr], + [touch conftest.tmp + if (setfattr -n user.pax.flags conftest.tmp) >/dev/null 2>&1; then + emacs_cv_prog_setfattr=yes + else + emacs_cv_prog_setfattr=no + fi]) + if test "$emacs_cv_prog_setfattr" = yes; then + PAXCTL_notdumped='$(SETFATTR) -n user.pax.flags -v er' + SETFATTR=setfattr + else + SETFATTR= fi - rm -f conftest.tmp - AC_SUBST([SETFATTR]) fi - fi - case $opsys,$PAXCTL_notdumped,$emacs_uname_r in - gnu-linux,,* | netbsd,,[0-7].*) - AC_PATH_PROG([PAXCTL], [paxctl], [], - [$PATH$PATH_SEPARATOR/sbin$PATH_SEPARATOR/usr/sbin]) - if test -n "$PAXCTL"; then - if test "$opsys" = netbsd; then - PAXCTL_dumped='$(PAXCTL) +a' - PAXCTL_notdumped=$PAXCTL_dumped - else - AC_MSG_CHECKING([whether binaries have a PT_PAX_FLAGS header]) - AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], - [if $PAXCTL -v conftest$EXEEXT >/dev/null 2>&1; then - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - PAXCTL= - fi]) - if test -n "$PAXCTL"; then - PAXCTL_dumped='$(PAXCTL) -zex' - PAXCTL_notdumped='$(PAXCTL) -r' + case $opsys,$PAXCTL_notdumped,$emacs_uname_r in + gnu-linux,,* | netbsd,,[0-7].*) + AC_PATH_PROG([PAXCTL], [paxctl], [], + [$PATH$PATH_SEPARATOR/sbin$PATH_SEPARATOR/usr/sbin]) + if test -n "$PAXCTL"; then + if test "$opsys" = netbsd; then + PAXCTL_dumped='$(PAXCTL) +a' + PAXCTL_notdumped=$PAXCTL_dumped + else + AC_MSG_CHECKING([whether binaries have a PT_PAX_FLAGS header]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], + [if $PAXCTL -v conftest$EXEEXT >/dev/null 2>&1; then + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + PAXCTL= + fi]) + if test -n "$PAXCTL"; then + PAXCTL_dumped='$(PAXCTL) -zex' + PAXCTL_notdumped='$(PAXCTL) -r' + fi fi - fi - fi;; - esac + fi;; + esac + fi AC_SUBST([PAXCTL_dumped]) AC_SUBST([PAXCTL_notdumped]) diff --cc lisp/loadup.el index 2189c46abf5,f419f0bd4ae..0f0ca15cebc --- a/lisp/loadup.el +++ b/lisp/loadup.el @@@ -474,22 -446,24 +474,29 @@@ lost after dumping")) ;; Make sure we will attempt bidi reordering henceforth. (setq redisplay--inhibit-bidi nil) -(if (and (fboundp 'dump-emacs) - (member (car (last command-line-args)) '("dump" "bootstrap"))) - (progn - ;; Prevent build-time PATH getting stored in the binary. - ;; Mainly cosmetic, but helpful for Guix. (Bug#20330) - ;; Do this here, rather than earlier, so that the above code - ;; can invoke Git commands and the like. - (setq exec-path nil) - (message "Dumping under the name emacs") +(if dump-mode + (let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp") + ((equal dump-mode "dump") "emacs") + ((equal dump-mode "bootstrap") "emacs") + ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp") + (t (error "unrecognized dump mode %s" dump-mode))))) + (message "Dumping under the name %s" output) (condition-case () - (delete-file "emacs") - (file-error nil)) - ;; We used to dump under the name xemacs, but that occasionally - ;; confused people installing Emacs (they'd install the file - ;; under the name `xemacs'), and it's inconsistent with every - ;; other GNU program's build process. - (dump-emacs "emacs" "temacs") - (message "%d pure bytes used" pure-bytes-used) + (delete-file output) + (file-error nil)) + ;; On MS-Windows, the current directory is not necessarily the + ;; same as invocation-directory. - (if (member dump-mode '("pdump" "pbootstrap")) - (dump-emacs-portable (expand-file-name output invocation-directory)) - (dump-emacs output "temacs") - (message "%d pure bytes used" pure-bytes-used)) ++ (let (success) ++ (unwind-protect ++ (progn ++ (if (member dump-mode '("pdump" "pbootstrap")) ++ (dump-emacs-portable (expand-file-name output invocation-directory)) ++ (dump-emacs output "temacs") ++ (message "%d pure bytes used" pure-bytes-used)) ++ (setq success t)) ++ (unless success ++ (ignore-errors ++ (delete-file output))))) ;; Recompute NAME now, so that it isn't set when we dump. (if (not (or (eq system-type 'ms-dos) ;; Don't bother adding another name if we're just diff --cc src/Makefile.in index 84ac633db25,f409ed4db28..43aac5c8c62 --- a/src/Makefile.in +++ b/src/Makefile.in @@@ -396,10 -392,10 +399,10 @@@ base_obj = dispnew.o frame.o scroll.o x charset.o coding.o category.o ccl.o character.o chartab.o bidi.o \ $(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \ emacs.o keyboard.o macros.o keymap.o sysdep.o \ - buffer.o filelock.o insdel.o marker.o \ + bignum.o buffer.o filelock.o insdel.o marker.o \ minibuf.o fileio.o dired.o \ - cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \ + cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ - alloc.o data.o doc.o editfns.o callint.o \ + alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ @@@ -677,15 -645,12 +680,15 @@@ ns-app: emacs$(EXEEXT) $(pdmp .PHONY: versionclean extraclean mostlyclean: - rm -f temacs$(EXEEXT) core *.core \#* *.o + rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o + rm -f temacs.in$(EXEEXT) fingerprint.c dmpstruct.h + rm -f emacs.pdmp rm -f ../etc/DOC - rm -f bootstrap-emacs$(EXEEXT) emacs-$(version)$(EXEEXT) + rm -f bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) + rm -f emacs-$(version)$(EXEEXT) rm -f buildobj.h rm -f globals.h gl-stamp - rm -f *.res *.tmp + rm -f ./*.res ./*.tmp clean: mostlyclean rm -f emacs-*.*.*[0-9]$(EXEEXT) emacs$(EXEEXT) $(DEPDIR)/* @@@ -788,18 -754,12 +792,23 @@@ ifeq ($(DUMPING),unexec ifneq ($(PAXCTL_dumped),) $(PAXCTL_dumped) emacs$(EXEEXT) endif - mv -f emacs$(EXEEXT) $@ + mv -f emacs$(EXEEXT) bootstrap-emacs$(EXEEXT) + @: Compile some files earlier to speed up further compilation. + $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)" +else + @: In the pdumper case, make compile-first after the dump + cp -f temacs$(EXEEXT) bootstrap-emacs$(EXEEXT) endif + +ifeq ($(DUMPING),pdumper) +$(bootstrap_pdmp): bootstrap-emacs$(EXEEXT) + rm -f $@ + $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap @: Compile some files earlier to speed up further compilation. $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)" +endif + + ### Flymake support (for C only) + check-syntax: + $(AM_V_CC)$(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) ${CHK_SOURCES} || true + .PHONY: check-syntax diff --cc src/alloc.c index da9526e518c,407ac725414..85589a84b73 --- a/src/alloc.c +++ b/src/alloc.c @@@ -230,14 -240,8 +232,14 @@@ byte_ct gc_relative_threshold /* Minimum number of bytes of consing since GC before next GC, when memory is full. */ - EMACS_INT memory_full_cons_threshold; + byte_ct memory_full_cons_threshold; +#ifdef HAVE_PDUMPER +/* Number of finalizers run: used to loop over GC until we stop + generating garbage. */ +int number_finalizers_run; +#endif + /* True during GC. */ bool gc_in_progress; @@@ -365,34 -375,6 +373,27 @@@ static void compact_small_strings (void static void free_large_strings (void); extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; +/* Forward declare mark accessor functions: they're used all over the + place. */ + +inline static bool vector_marked_p (const struct Lisp_Vector *v); +inline static void set_vector_marked (struct Lisp_Vector *v); + +inline static bool vectorlike_marked_p (const union vectorlike_header *v); ++inline static void set_vectorlike_marked (union vectorlike_header *v); + +inline static bool cons_marked_p (const struct Lisp_Cons *c); +inline static void set_cons_marked (struct Lisp_Cons *c); + +inline static bool string_marked_p (const struct Lisp_String *s); +inline static void set_string_marked (struct Lisp_String *s); + +inline static bool symbol_marked_p (const struct Lisp_Symbol *s); +inline static void set_symbol_marked (struct Lisp_Symbol *s); + - inline static bool misc_any_marked_p (const struct Lisp_Misc_Any *m); - inline static void set_misc_any_marked (struct Lisp_Misc_Any *m); - - inline static bool marker_marked_p (const struct Lisp_Marker *m); - - inline static bool overlay_marked_p (const struct Lisp_Overlay *m); - inline static void set_overlay_marked (struct Lisp_Overlay *m); - +inline static bool interval_marked_p (INTERVAL i); +inline static void set_interval_marked (INTERVAL i); + /* When scanning the C stack for live Lisp objects, Emacs keeps track of what memory allocated via lisp_malloc and lisp_align_malloc is intended for what purpose. This enumeration specifies the type of memory. */ @@@ -3257,11 -3268,11 +3292,11 @@@ sweep_vectors (void for (vector = (struct Lisp_Vector *) block->data; VECTOR_IN_BLOCK (vector, block); vector = next) { - if (VECTOR_MARKED_P (vector)) + if (XVECTOR_MARKED_P (vector)) { - VECTOR_UNMARK (vector); + XUNMARK_VECTOR (vector); total_vectors++; - nbytes = vector_nbytes (vector); + ptrdiff_t nbytes = vector_nbytes (vector); total_vector_slots += nbytes / word_size; next = ADVANCE (vector, nbytes); } @@@ -3286,6 -3291,7 +3315,7 @@@ total_bytes += nbytes; next = ADVANCE (next, nbytes); } - while (VECTOR_IN_BLOCK (next, block) && !VECTOR_MARKED_P (next)); ++ while (VECTOR_IN_BLOCK (next, block) && !vector_marked_p (next)); eassert (total_bytes % roundup_size == 0); @@@ -4011,7 -3834,7 +3858,7 @@@ mark_finalizer_list (struct Lisp_Finali finalizer != head; finalizer = finalizer->next) { - set_misc_any_marked (&finalizer->base); - VECTOR_MARK (finalizer); ++ set_vectorlike_marked (&finalizer->header); mark_object (finalizer->function); } } @@@ -4028,8 -3851,7 +3875,8 @@@ queue_doomed_finalizers (struct Lisp_Fi while (finalizer != src) { struct Lisp_Finalizer *next = finalizer->next; - if (!misc_any_marked_p (&finalizer->base) - if (!VECTOR_MARKED_P (finalizer) && !NILP (finalizer->function)) ++ if (!vectorlike_marked_p (&finalizer->header) + && !NILP (finalizer->function)) { unchain_finalizer (finalizer); finalizer_insert (dest, finalizer); @@@ -4093,158 -3911,9 +3939,129 @@@ FUNCTION. FUNCTION will be run once pe finalizer->function = function; finalizer->prev = finalizer->next = NULL; finalizer_insert (&finalizers, finalizer); - return val; + return make_lisp_ptr (finalizer, Lisp_Vectorlike); } + +/************************************************************************ + Mark bit access functions + ************************************************************************/ + +/* With the rare exception of functions implementing block-based + allocation of various types, you should not directly test or set GC + mark bits on objects. Some objects might live in special memory + regions (e.g., a dump image) and might store their mark bits + elsewhere. */ + +static bool +vector_marked_p (const struct Lisp_Vector *v) +{ + if (pdumper_object_p (v)) + { + /* Look at cold_start first so that we don't have to fault in + the vector header just to tell that it's a bool vector. */ + if (pdumper_cold_object_p (v)) + { + eassert (PSEUDOVECTOR_TYPE (v) == PVEC_BOOL_VECTOR); + return true; + } + return pdumper_marked_p (v); + } + return XVECTOR_MARKED_P (v); +} + +static void +set_vector_marked (struct Lisp_Vector *v) +{ + if (pdumper_object_p (v)) + { + eassert (PSEUDOVECTOR_TYPE (v) != PVEC_BOOL_VECTOR); + pdumper_set_marked (v); + } + else + XMARK_VECTOR (v); +} + +static bool +vectorlike_marked_p (const union vectorlike_header *header) +{ + return vector_marked_p ((const struct Lisp_Vector *) header); +} + ++static void ++set_vectorlike_marked (union vectorlike_header *header) ++{ ++ set_vector_marked ((struct Lisp_Vector *) header); ++} ++ +static bool +cons_marked_p (const struct Lisp_Cons *c) +{ + return pdumper_object_p (c) + ? pdumper_marked_p (c) + : XCONS_MARKED_P (c); +} + +static void +set_cons_marked (struct Lisp_Cons *c) +{ + if (pdumper_object_p (c)) + pdumper_set_marked (c); + else + XMARK_CONS (c); +} + +static bool +string_marked_p (const struct Lisp_String *s) +{ + return pdumper_object_p (s) + ? pdumper_marked_p (s) + : XSTRING_MARKED_P (s); +} + +static void +set_string_marked (struct Lisp_String *s) +{ + if (pdumper_object_p (s)) + pdumper_set_marked (s); + else + XMARK_STRING (s); +} + +static bool +symbol_marked_p (const struct Lisp_Symbol *s) +{ + return pdumper_object_p (s) + ? pdumper_marked_p (s) + : s->u.s.gcmarkbit; +} + +static void +set_symbol_marked (struct Lisp_Symbol *s) +{ + if (pdumper_object_p (s)) + pdumper_set_marked (s); + else + s->u.s.gcmarkbit = true; +} + - static bool - misc_any_marked_p (const struct Lisp_Misc_Any *m) - { - return pdumper_object_p (m) - ? pdumper_marked_p (m) - : m->gcmarkbit; - } - - static void - set_misc_any_marked (struct Lisp_Misc_Any *m) - { - if (pdumper_object_p (m)) - pdumper_set_marked (m); - else - m->gcmarkbit = true; - } - - static bool - marker_marked_p (const struct Lisp_Marker *m) - { - return misc_any_marked_p ((struct Lisp_Misc_Any *) m); - } - - static bool - overlay_marked_p (const struct Lisp_Overlay *m) - { - return misc_any_marked_p ((struct Lisp_Misc_Any *) m); - } - - static void - set_overlay_marked (struct Lisp_Overlay *m) - { - set_misc_any_marked ((struct Lisp_Misc_Any *) m); - } - +static bool +interval_marked_p (INTERVAL i) +{ + return pdumper_object_p (i) + ? pdumper_marked_p (i) + : i->gcmarkbit; +} + +static void +set_interval_marked (INTERVAL i) +{ + if (pdumper_object_p (i)) + pdumper_set_marked (i); + else + i->gcmarkbit = true; +} + /************************************************************************ Memory Full Handling @@@ -4979,10 -4613,11 +4761,10 @@@ static voi mark_maybe_object (Lisp_Object obj) { #if USE_VALGRIND - if (valgrind_p) - VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); + VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (INTEGERP (obj)) + if (FIXNUMP (obj)) return; void *po = XPNTR (obj); @@@ -5079,20 -4704,9 +4866,20 @@@ mark_maybe_pointer (void *p { /* For the wide-int case, also mark emacs_value tagged pointers, which can be generated by emacs-module.c's value_to_lisp. */ - p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1)); + p = (void *) ((uintptr_t) p & ~((1 << GCTYPEBITS) - 1)); } + if (pdumper_object_p (p)) + { + enum Lisp_Type type = pdumper_find_object_type (p); + if (type != PDUMPER_NO_OBJECT) + mark_object ((type == Lisp_Symbol) + ? make_lisp_symbol(p) + : make_lisp_ptr(p, type)); + /* See mark_maybe_object for why we can confidently return. */ + return; + } + m = mem_find (p); if (m != MEM_NIL) { @@@ -5449,6 -5063,6 +5236,12 @@@ valid_pointer_p (void *p return p ? -1 : 0; int fd[2]; ++ static int under_rr_state; ++ ++ if (!under_rr_state) ++ under_rr_state = getenv ("RUNNING_UNDER_RR") ? -1 : 1; ++ if (under_rr_state < 0) ++ return under_rr_state; /* Obviously, we cannot just access it (we would SEGV trying), so we trick the o/s to tell us whether p is a valid pointer. @@@ -6066,7 -5699,7 +5882,7 @@@ compact_undo_list (Lisp_Object list { if (CONSP (XCAR (tail)) && MARKERP (XCAR (XCAR (tail))) - && !marker_marked_p (XMARKER (XCAR (XCAR (tail))))) - && !VECTOR_MARKED_P (XMARKER (XCAR (XCAR (tail))))) ++ && !vectorlike_marked_p (&XMARKER (XCAR (XCAR (tail)))->header)) *prev = XCDR (tail); else prev = xcdr_addr (tail); @@@ -6214,10 -5749,8 +6030,10 @@@ garbage_collect_1 (void *end ptrdiff_t count = SPECPDL_INDEX (); struct timespec start; Lisp_Object retval = Qnil; - size_t tot_before = 0; + byte_ct tot_before = 0; + eassert (weak_hash_tables == NULL); + /* Can't GC if pure storage overflowed because we can't determine if something is a pure object or not. */ if (pure_bytes_used_before_overflow) @@@ -6341,12 -5878,14 +6157,14 @@@ queue_doomed_finalizers (&doomed_finalizers, &finalizers); mark_finalizer_list (&doomed_finalizers); - gc_sweep (); + /* Must happen after all other marking and before gc_sweep. */ + mark_and_sweep_weak_table_contents (); + eassert (weak_hash_tables == NULL); - /* Clear the mark bits that we set in certain root slots. */ - VECTOR_UNMARK (&buffer_defaults); - VECTOR_UNMARK (&buffer_local_symbols); + gc_sweep (); + unmark_main_thread (); + check_cons_list (); gc_in_progress = 0; @@@ -6557,8 -6082,7 +6366,8 @@@ mark_char_table (struct Lisp_Vector *pt { Lisp_Object val = ptr->contents[i]; - if (INTEGERP (val) || - if (FIXNUMP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit)) ++ if (FIXNUMP (val) || + (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val)))) continue; if (SUB_CHAR_TABLE_P (val)) { @@@ -6588,11 -6112,12 +6397,12 @@@ mark_compiled (struct Lisp_Vector *ptr static void mark_overlay (struct Lisp_Overlay *ptr) { - for (; ptr && !overlay_marked_p (ptr); ptr = ptr->next) - for (; ptr && !VECTOR_MARKED_P (ptr); ptr = ptr->next) ++ for (; ptr && !vectorlike_marked_p (&ptr->header); ptr = ptr->next) { - set_overlay_marked (ptr); - mark_object (ptr->start); - mark_object (ptr->end); - VECTOR_MARK (ptr); ++ set_vectorlike_marked (&ptr->header); + /* These two are always markers and can be marked fast. */ - VECTOR_MARK (XMARKER (ptr->start)); - VECTOR_MARK (XMARKER (ptr->end)); ++ set_vectorlike_marked (&XMARKER (ptr->start)->header); ++ set_vectorlike_marked (&XMARKER (ptr->end)->header); mark_object (ptr->plist); } } @@@ -6796,7 -6226,7 +6578,7 @@@ mark_object (Lisp_Object arg register Lisp_Object obj; void *po; #if GC_CHECK_MARKED_OBJECTS -- struct mem_node *m; ++ struct mem_node *m = NULL; #endif ptrdiff_t cdr_count = 0; @@@ -6951,14 -6418,8 +6732,18 @@@ mark_char_table (ptr, (enum pvec_type) pvectype); break; - case PVEC_OVERLAY: + case PVEC_BOOL_VECTOR: + /* bool vectors in a dump are permanently "marked", since + they're in the old section and don't have mark bits. + If we're looking at a dumped bool vector, we should + have aborted above when we called vector_marked_p(), so + we should never get here. */ + eassert (!pdumper_object_p (ptr)); + set_vector_marked (ptr); ++ break; ++ ++ case PVEC_OVERLAY: + mark_overlay (XOVERLAY (obj)); break; case PVEC_SUBR: @@@ -6968,7 -6429,9 +6753,9 @@@ emacs_abort (); default: + /* A regular vector, or a pseudovector needing no special + treatment. */ - mark_vectorlike (ptr); + mark_vectorlike (&ptr->header); } } break; @@@ -7016,67 -6479,26 +6803,26 @@@ } break; - case Lisp_Misc: - CHECK_ALLOCATED_AND_LIVE (live_misc_p); - - if (misc_any_marked_p (XMISCANY (obj))) - break; - - switch (XMISCTYPE (obj)) - { - case Lisp_Misc_Marker: - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when freed by gc. */ - set_misc_any_marked (XMISCANY (obj)); - break; - - case Lisp_Misc_Save_Value: - set_misc_any_marked (XMISCANY (obj)); - mark_save_value (XSAVE_VALUE (obj)); - break; - - case Lisp_Misc_Overlay: - mark_overlay (XOVERLAY (obj)); - break; - - case Lisp_Misc_Finalizer: - set_misc_any_marked (XMISCANY (obj)); - mark_object (XFINALIZER (obj)->function); - break; - - #ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - set_misc_any_marked (XMISCANY (obj)); - break; - #endif - - default: - emacs_abort (); - } - - break; - case Lisp_Cons: { - register struct Lisp_Cons *ptr = XCONS (obj); - if (cons_marked_p (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + struct Lisp_Cons *ptr = XCONS (obj); - if (CONS_MARKED_P (ptr)) ++ if (cons_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_cons_p); - CONS_MARK (ptr); + set_cons_marked (ptr); - /* If the cdr is nil, avoid recursion for the car. */ - if (EQ (ptr->u.s.u.cdr, Qnil)) - { - obj = ptr->u.s.car; - cdr_count = 0; - goto loop; - } - mark_object (ptr->u.s.car); - obj = ptr->u.s.u.cdr; - cdr_count++; - if (cdr_count == mark_object_loop_halt) - emacs_abort (); - goto loop; + /* If the cdr is nil, avoid recursion for the car. */ + if (NILP (ptr->u.s.u.cdr)) + { + obj = ptr->u.s.car; + cdr_count = 0; + goto loop; + } + mark_object (ptr->u.s.car); + obj = ptr->u.s.u.cdr; + cdr_count++; + if (cdr_count == mark_object_loop_halt) + emacs_abort (); + goto loop; } case Lisp_Float: @@@ -7137,15 -6555,11 +6883,11 @@@ survives_gc_p (Lisp_Object obj break; case Lisp_Symbol: - survives_p = XSYMBOL (obj)->u.s.gcmarkbit; + survives_p = symbol_marked_p (XSYMBOL (obj)); break; - case Lisp_Misc: - survives_p = misc_any_marked_p (XMISCANY (obj)); - break; - case Lisp_String: - survives_p = STRING_MARKED_P (XSTRING (obj)); + survives_p = string_marked_p (XSTRING (obj)); break; case Lisp_Vectorlike: @@@ -7262,14 -6672,13 +7002,13 @@@ sweep_floats (void float_free_list = 0; - for (fblk = float_block; fblk; fblk = *fprev) + for (struct float_block *fblk; (fblk = *fprev); ) { - register int i; int this_free = 0; - for (i = 0; i < lim; i++) + for (int i = 0; i < lim; i++) { struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); - if (!FLOAT_MARKED_P (afloat)) + if (!XFLOAT_MARKED_P (afloat)) { this_free++; fblk->floats[i].u.chain = float_free_list; @@@ -7422,75 -6829,21 +7159,21 @@@ sweep_symbols (void total_free_symbols = num_free; } - NO_INLINE /* For better stack traces. */ + /* Remove BUFFER's markers that are due to be swept. This is needed since + we treat BUF_MARKERS and markers's `next' field as weak pointers. */ static void - sweep_misc (void) + unchain_dead_markers (struct buffer *buffer) { - register struct marker_block *mblk; - struct marker_block **mprev = &marker_block; - register int lim = marker_block_index; - EMACS_INT num_free = 0, num_used = 0; - - /* Put all unmarked misc's on free list. For a marker, first - unchain it from the buffer it points into. */ + struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer); - marker_free_list = 0; - - for (mblk = marker_block; mblk; mblk = *mprev) - { - register int i; - int this_free = 0; - - for (i = 0; i < lim; i++) - { - if (!mblk->markers[i].m.u_any.gcmarkbit) - { - if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker) - unchain_marker (&mblk->markers[i].m.u_marker); - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer) - unchain_finalizer (&mblk->markers[i].m.u_finalizer); - #ifdef HAVE_MODULES - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr) - { - struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr; - if (uptr->finalizer) - uptr->finalizer (uptr->p); - } - #endif - /* Set the type of the freed object to Lisp_Misc_Free. - We could leave the type alone, since nobody checks it, - but this might catch bugs faster. */ - mblk->markers[i].m.u_marker.type = Lisp_Misc_Free; - mblk->markers[i].m.u_free.chain = marker_free_list; - marker_free_list = &mblk->markers[i].m; - this_free++; - } - else - { - num_used++; - mblk->markers[i].m.u_any.gcmarkbit = 0; - } - } - lim = MARKER_BLOCK_SIZE; - /* If this block contains only free markers and we have already - seen more than two blocks worth of free markers then deallocate - this block. */ - if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE) - { - *mprev = mblk->next; - /* Unhook from the free list. */ - marker_free_list = mblk->markers[0].m.u_free.chain; - lisp_free (mblk); - } - else - { - num_free += this_free; - mprev = &mblk->next; - } - } - - total_markers = num_used; - total_free_markers = num_free; + while ((this = *prev)) - if (VECTOR_MARKED_P (this)) ++ if (vectorlike_marked_p (&this->header)) + prev = &this->next; + else + { + this->buffer = NULL; + *prev = this->next; + } } NO_INLINE /* For better stack traces */ @@@ -7508,10 -6861,10 +7191,11 @@@ sweep_buffers (void } else { - VECTOR_UNMARK (buffer); + if (!pdumper_object_p (buffer)) + XUNMARK_VECTOR (buffer); /* Do not use buffer_(set|get)_intervals here. */ buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); total_buffers++; bprev = &buffer->next; } @@@ -7527,10 -6884,8 +7211,9 @@@ gc_sweep (void sweep_floats (); sweep_intervals (); sweep_symbols (); - sweep_misc (); sweep_buffers (); sweep_vectors (); + pdumper_clear_marks (); check_string_bytes (!noninteractive); } diff --cc src/buffer.c index 0702c2c6056,cc0899676de..a12c80ec0b0 --- a/src/buffer.c +++ b/src/buffer.c @@@ -5344,14 -5266,12 +5305,12 @@@ init_buffer_once (void } void -init_buffer (int initialized) +init_buffer (void) { - char *pwd; Lisp_Object temp; - ptrdiff_t len; #ifdef USE_MMAP_FOR_BUFFERS - if (initialized) + if (dumped_with_unexec_p ()) { struct buffer *b; diff --cc src/charset.c index 98529bbb1e0,724b35536ed..28f6203a66d --- a/src/charset.c +++ b/src/charset.c @@@ -2320,23 -2321,12 +2325,21 @@@ init_charset_once (void for (i = 0; i < 256; i++) emacs_mule_charset[i] = -1; + PDUMPER_REMEMBER_SCALAR (emacs_mule_charset); + charset_jisx0201_roman = -1; + PDUMPER_REMEMBER_SCALAR (charset_jisx0201_roman); + charset_jisx0208_1978 = -1; + PDUMPER_REMEMBER_SCALAR (charset_jisx0208_1978); + charset_jisx0208 = -1; + PDUMPER_REMEMBER_SCALAR (charset_jisx0208); + charset_ksc5601 = -1; + PDUMPER_REMEMBER_SCALAR (charset_ksc5601); } - #ifdef emacs - /* Allocate an initial charset table that is large enough to handle Emacs while it is bootstrapping. As of September 2011, the size needs to be at least 166; make it a bit bigger to allow for future @@@ -2444,11 -2424,6 +2447,9 @@@ the value may be a list of mnemonics. charset_eight_bit = define_charset_internal (Qeight_bit, 1, "\x80\xFF\0\0\0\0\0", 128, 255, -1, 0, -1, 0, 1, - MAX_5_BYTE_CHAR + 1); + MAX_5_BYTE_CHAR + 1); + PDUMPER_REMEMBER_SCALAR (charset_eight_bit); + charset_unibyte = charset_iso_8859_1; + PDUMPER_REMEMBER_SCALAR (charset_unibyte); } - - #endif /* emacs */ diff --cc src/coding.c index 22a04b3dbed,1c1462198ca..665aefa34c8 --- a/src/coding.c +++ b/src/coding.c @@@ -10817,12 -10764,8 +10770,10 @@@ init_coding_once (void emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_12] = 3; emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_21] = 4; emacs_mule_bytes[EMACS_MULE_LEADING_CODE_PRIVATE_22] = 4; + + PDUMPER_REMEMBER_SCALAR (emacs_mule_bytes); } - #ifdef emacs - void syms_of_coding (void) { diff --cc src/composite.c index 72e887895e7,cd8364a2936..c426cbb1246 --- a/src/composite.c +++ b/src/composite.c @@@ -654,29 -654,22 +654,23 @@@ Lisp_Objec composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); + hash_rehash_if_needed (h); - - EMACS_UINT hash; - Lisp_Object header, copy; - ptrdiff_t i; - - header = LGSTRING_HEADER (gstring); - hash = h->test.hashfn (&h->test, header); + Lisp_Object header = LGSTRING_HEADER (gstring); + EMACS_UINT hash = h->test.hashfn (&h->test, header); if (len < 0) { - ptrdiff_t j, glyph_len = LGSTRING_GLYPH_LEN (gstring); - for (j = 0; j < glyph_len; j++) - if (NILP (LGSTRING_GLYPH (gstring, j))) + ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring); + for (len = 0; len < glyph_len; len++) + if (NILP (LGSTRING_GLYPH (gstring, len))) break; - len = j; } - copy = Fmake_vector (make_number (len + 2), Qnil); + Lisp_Object copy = make_nil_vector (len + 2); LGSTRING_SET_HEADER (copy, Fcopy_sequence (header)); - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) LGSTRING_SET_GLYPH (copy, i, Fcopy_sequence (LGSTRING_GLYPH (gstring, i))); - i = hash_put (h, LGSTRING_HEADER (copy), copy, hash); - LGSTRING_SET_ID (copy, make_number (i)); + ptrdiff_t id = hash_put (h, LGSTRING_HEADER (copy), copy, hash); + LGSTRING_SET_ID (copy, make_fixnum (id)); return copy; } diff --cc src/data.c index 83234622e3d,a9908a34f4f..cad903dbcc8 --- a/src/data.c +++ b/src/data.c @@@ -1822,7 -1826,7 +1826,7 @@@ The function `default-value' gets the d { struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; -- union Lisp_Val_Fwd valcontents; ++ union Lisp_Val_Fwd valcontents UNINIT; bool forwarded UNINIT; CHECK_SYMBOL (variable); @@@ -1889,7 -1893,7 +1893,7 @@@ Instead, use `add-hook' and specify t f { Lisp_Object tem; bool forwarded UNINIT; -- union Lisp_Val_Fwd valcontents; ++ union Lisp_Val_Fwd valcontents UNINIT; struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; @@@ -2768,151 -2812,178 +2812,178 @@@ enum aritho Alogior, Alogxor }; + static bool + floating_point_op (enum arithop code) + { + return code <= Adiv; + } + + /* Return the result of applying the floating-point operation CODE to + the NARGS arguments starting at ARGS. If ARGNUM is positive, + ARGNUM of the arguments were already consumed, yielding ACCUM. + 0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of + ARGS[ARGSNUM], converted to double. */ - static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop, - ptrdiff_t, Lisp_Object *); static Lisp_Object - arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) + floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, double next) { - Lisp_Object val; - ptrdiff_t argnum, ok_args; - EMACS_INT accum = 0; - EMACS_INT next, ok_accum; - bool overflow = 0; - - switch (code) - { - case Alogior: - case Alogxor: - case Aadd: - case Asub: - accum = 0; - break; - case Amult: - case Adiv: - accum = 1; - break; - case Alogand: - accum = -1; - break; - default: - break; + if (argnum == 0) + { + accum = next; + goto next_arg; } - for (argnum = 0; argnum < nargs; argnum++) + while (true) { - if (! overflow) - { - ok_args = argnum; - ok_accum = accum; - } - - /* Using args[argnum] as argument to CHECK_NUMBER_... */ - val = args[argnum]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); - - if (FLOATP (val)) - return float_arith_driver (ok_accum, ok_args, code, - nargs, args); - args[argnum] = val; - next = XINT (args[argnum]); switch (code) { - case Aadd: - overflow |= INT_ADD_WRAPV (accum, next, &accum); - break; - case Asub: - if (! argnum) - accum = nargs == 1 ? - next : next; - else - overflow |= INT_SUBTRACT_WRAPV (accum, next, &accum); - break; - case Amult: - overflow |= INT_MULTIPLY_WRAPV (accum, next, &accum); - break; + case Aadd : accum += next; break; + case Asub : accum -= next; break; + case Amult: accum *= next; break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (next == 0) - xsignal0 (Qarith_error); - if (INT_DIVIDE_OVERFLOW (accum, next)) - overflow = true; - else - accum /= next; - } - break; - case Alogand: - accum &= next; - break; - case Alogior: - accum |= next; - break; - case Alogxor: - accum ^= next; + if (! IEEE_FLOATING_POINT && next == 0) + xsignal0 (Qarith_error); + accum /= next; break; + default: eassume (false); } + + next_arg: + argnum++; + if (argnum == nargs) + return make_float (accum); + Lisp_Object val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + next = XFLOATINT (val); } + } - XSETINT (val, accum); - return val; + /* Like floatop_arith_driver, except CODE might not be a floating-point + operation, and NEXT is a Lisp float rather than a C double. */ + + static Lisp_Object + float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, Lisp_Object next) + { + if (! floating_point_op (code)) + wrong_type_argument (Qinteger_or_marker_p, next); + return floatop_arith_driver (code, nargs, args, argnum, accum, + XFLOAT_DATA (next)); } - #ifndef isnan - # define isnan(x) ((x) != (x)) - #endif + /* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS. If ARGNUM is positive, ARGNUM of + the arguments were already consumed, yielding IACCUM. 0 <= ARGNUM + < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM], + converted to integer. */ static Lisp_Object - float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, - ptrdiff_t nargs, Lisp_Object *args) + bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val) { - register Lisp_Object val; - double next; + mpz_t *accum; + if (argnum == 0) + { + accum = bignum_integer (&mpz[0], val); + goto next_arg; + } + mpz_set_intmax (mpz[0], iaccum); + accum = &mpz[0]; - for (; argnum < nargs; argnum++) + while (true) { - val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + mpz_t *next = bignum_integer (&mpz[1], val); - if (FLOATP (val)) - { - next = XFLOAT_DATA (val); - } - else - { - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); - } switch (code) { - case Aadd: - accum += next; - break; - case Asub: - accum = argnum ? accum - next : nargs == 1 ? - next : next; - break; - case Amult: - accum *= next; - break; + case Aadd : mpz_add (mpz[0], *accum, *next); break; + case Asub : mpz_sub (mpz[0], *accum, *next); break; + case Amult : emacs_mpz_mul (mpz[0], *accum, *next); break; + case Alogand: mpz_and (mpz[0], *accum, *next); break; + case Alogior: mpz_ior (mpz[0], *accum, *next); break; + case Alogxor: mpz_xor (mpz[0], *accum, *next); break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (! IEEE_FLOATING_POINT && next == 0) - xsignal0 (Qarith_error); - accum /= next; - } + if (mpz_sgn (*next) == 0) + xsignal0 (Qarith_error); + mpz_tdiv_q (mpz[0], *accum, *next); break; - case Alogand: - case Alogior: - case Alogxor: - wrong_type_argument (Qinteger_or_marker_p, val); + default: + eassume (false); } + accum = &mpz[0]; + + next_arg: + argnum++; + if (argnum == nargs) + return make_integer_mpz (); + val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + if (FLOATP (val)) + return float_arith_driver (code, nargs, args, argnum, + mpz_get_d_rounded (*accum), val); } + } + + /* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS, with the first argument being the + number VAL. 2 <= NARGS. Check that the remaining arguments are + numbers or markers. */ + + static Lisp_Object + arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + Lisp_Object val) + { + eassume (2 <= nargs); + + ptrdiff_t argnum = 0; + /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some + ignored value to avoid using an uninitialized variable later. */ + intmax_t accum = XFIXNUM (val); + + if (FIXNUMP (val)) + while (true) + { + argnum++; + if (argnum == nargs) + return make_int (accum); + val = args[argnum]; + CHECK_NUMBER_COERCE_MARKER (val); + + /* Set NEXT to the next value if it fits, else exit the loop. */ + intmax_t next; + if (! (INTEGERP (val) && integer_to_intmax (val, &next))) + break; - return make_float (accum); + /* Set ACCUM to the next operation's result if it fits, + else exit the loop. */ + bool overflow = false; - intmax_t a; ++ intmax_t a = 0; /* Assignment suppresses warning. */ + switch (code) + { + case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break; + case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break; + case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break; + case Adiv: + if (next == 0) + xsignal0 (Qarith_error); + overflow = INT_DIVIDE_OVERFLOW (accum, next); + if (!overflow) + a = accum / next; + break; + case Alogand: accum &= next; continue; + case Alogior: accum |= next; continue; + case Alogxor: accum ^= next; continue; + default: eassume (false); + } + if (overflow) + break; + accum = a; + } + + return (FLOATP (val) + ? float_arith_driver (code, nargs, args, argnum, accum, val) + : bignum_arith_driver (code, nargs, args, argnum, accum, val)); } diff --cc src/dispnew.c index 49231805340,55cdaf5de8a..88783cd5da7 --- a/src/dispnew.c +++ b/src/dispnew.c @@@ -6078,10 -6078,14 +6089,10 @@@ init_display_interactive (void #endif /* HAVE_NTGUI */ #ifdef HAVE_NS - if (!inhibit_window_system -#ifndef CANNOT_DUMP - && initialized -#endif - ) + if (!inhibit_window_system && !will_dump_p ()) { Vinitial_window_system = Qns; - Vwindow_system_version = make_number (10); + Vwindow_system_version = make_fixnum (10); return; } #endif diff --cc src/editfns.c index 7f24d0e3b8b,028fec8d092..1215c22dbdf --- a/src/editfns.c +++ b/src/editfns.c @@@ -4609,18 -3459,59 +3459,59 @@@ styled_format (ptrdiff_t nargs, Lisp_Ob ptrdiff_t sprintf_bytes; if (float_conversion) { - if (INT_AS_LDBL && INTEGERP (arg)) + /* Format as a long double if the arg is an integer + that would lose less information than when formatting + it as a double. Otherwise, format as a double; + this is likely to be faster and better-tested. */ + + bool format_as_long_double = false; + double darg; - long double ldarg; ++ long double ldarg = 0; + + if (FLOATP (arg)) + darg = XFLOAT_DATA (arg); + else + { + bool format_bignum_as_double = false; + if (LDBL_MANT_DIG <= DBL_MANT_DIG) + { + if (FIXNUMP (arg)) + darg = XFIXNUM (arg); + else + format_bignum_as_double = true; + } + else + { + if (INTEGERP (arg)) + { + intmax_t iarg; + uintmax_t uarg; + if (integer_to_intmax (arg, &iarg)) + ldarg = iarg; + else if (integer_to_uintmax (arg, &uarg)) + ldarg = uarg; + else + format_bignum_as_double = true; + } + if (!format_bignum_as_double) + { + darg = ldarg; + format_as_long_double = darg != ldarg; + } + } + if (format_bignum_as_double) + darg = bignum_to_double (arg); + } + + if (format_as_long_double) { - /* Although long double may have a rounding error if - DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1, - it is more accurate than plain 'double'. */ - long double x = XINT (arg); - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); + f[-1] = 'L'; + *f++ = conversion; + *f = '\0'; + sprintf_bytes = sprintf (p, convspec, prec, ldarg); } else - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, - XFLOATINT (arg)); + sprintf_bytes = sprintf (p, convspec, prec, darg); } else if (conversion == 'c') { diff --cc src/emacs.c index a9db0a32f0d,221b074afc9..9c88b6e3f17 --- a/src/emacs.c +++ b/src/emacs.c @@@ -697,112 -677,6 +705,114 @@@ close_output_streams (void _exit (EXIT_FAILURE); } +#ifdef HAVE_PDUMPER + +static const char * +dump_error_to_string (enum pdumper_load_result result) +{ + switch (result) + { + case PDUMPER_LOAD_SUCCESS: + return "success"; + case PDUMPER_LOAD_OOM: + return "out of memory"; + case PDUMPER_NOT_LOADED: + return "not loaded"; + case PDUMPER_LOAD_FILE_NOT_FOUND: + return "could not open file"; + case PDUMPER_LOAD_BAD_FILE_TYPE: + return "not a dump file"; + case PDUMPER_LOAD_FAILED_DUMP: + return "dump file is result of failed dump attempt"; + case PDUMPER_LOAD_VERSION_MISMATCH: + return "not built for this Emacs executable"; + default: + return "generic error"; + } +} + +#define PDUMP_FILE_ARG "--dump-file" + +static enum pdumper_load_result +load_pdump (int argc, char **argv) +{ + const char *const suffix = ".pdmp"; + const char *const argv0_base = "emacs"; + enum pdumper_load_result result; +#ifdef WINDOWSNT + size_t argv0_len; +#endif + + /* TODO: maybe more thoroughly scrub process environment in order to - make this use case possible? Right now, we assume that things we - don't touch are zero-initialized, and in an unexeced Emacs, this - assumption doesn't hold. */ - eassert (!initialized); ++ make this use case (loading a pdumper image in an unexeced emacs) ++ possible? Right now, we assume that things we don't touch are ++ zero-initialized, and in an unexeced Emacs, this assumption ++ doesn't hold. */ ++ if (initialized) ++ fatal ("cannot load pdumper image in unexeced Emacs"); + + /* Look for an explicitly-specified dump file. */ + const char *path_exec = PATH_EXEC; + char *dump_file = find_argument (PDUMP_FILE_ARG, argc, argv); + + result = PDUMPER_NOT_LOADED; + if (dump_file) + result = pdumper_load (dump_file); + + if (dump_file && result != PDUMPER_LOAD_SUCCESS) + fatal ("could not load dump file \"%s\": %s", + dump_file, dump_error_to_string (result)); + + if (result == PDUMPER_LOAD_SUCCESS) + goto out; + + /* Look for a dump file in the same directory as the executable; it + should have the same basename. */ + + dump_file = alloca (strlen (argv[0]) + strlen (suffix) + 1); +#ifdef WINDOWSNT + /* Remove the .exe extension if present. */ + argv0_len = strlen (argv[0]); + if (argv0_len >= 4 && c_strcasecmp (argv[0] + argv0_len - 4, ".exe") == 0) + sprintf (dump_file, "%.*s%s", argv0_len - 4, argv[0], suffix); + else +#endif + sprintf (dump_file, "%s%s", argv[0], suffix); + + result = pdumper_load (dump_file); + if (result == PDUMPER_LOAD_SUCCESS) + goto out; + + if (result != PDUMPER_LOAD_FILE_NOT_FOUND) + fatal ("could not load dump file \"%s\": %s", + dump_file, dump_error_to_string (result)); + + /* Finally, look for "emacs.pdmp" in PATH_EXEC. We hardcode + "emacs" in "emacs.pdmp" so that the Emacs binary still works + if the user copies and renames it. + + FIXME: this doesn't work with emacs-XX.YY.ZZ.pdmp versioned files. */ +#ifdef WINDOWSNT + /* On MS-Windows, PATH_EXEC normally starts with a literal + "%emacs_dir%", so it will never work without some tweaking. */ + path_exec = w32_relocate (path_exec); +#endif + dump_file = alloca (strlen (path_exec) + + 1 + + strlen (argv0_base) + + strlen (suffix) + + 1); + sprintf (dump_file, "%s%c%s%s", + path_exec, DIRECTORY_SEP, argv0_base, suffix); + result = pdumper_load (dump_file); + if (result != PDUMPER_LOAD_SUCCESS) + dump_file = NULL; + + out: + return result; +} +#endif /* HAVE_PDUMPER */ + /* ARGSUSED */ int main (int argc, char **argv) @@@ -902,40 -742,6 +914,22 @@@ w32_init_main_thread (); #endif +#ifdef HAVE_PDUMPER + if (attempt_load_pdump) + load_pdump (argc, argv); +#endif + - /* True if address randomization interferes with memory allocation. */ - # ifdef __PPC64__ - bool disable_aslr = true; - # else - bool disable_aslr = will_dump_with_unexec_p (); - # endif - - if (disable_aslr && disable_address_randomization ()) - { - /* Set this so the personality will be reverted before execs - after this one. */ - xputenv ("EMACS_HEAP_EXEC=true"); - - /* Address randomization was enabled, but is now disabled. - Re-execute Emacs to get a clean slate. */ - execvp (argv[0], argv); - - /* If the exec fails, warn and then try anyway. */ - perror (argv[0]); - } ++ argc = maybe_disable_address_randomization ( ++ will_dump_with_unexec_p (), argc, argv); + +#if defined (GNU_LINUX) && !defined (CANNOT_DUMP) + if (!initialized) + { + char *heap_start = my_heap_start (); + heap_bss_diff = heap_start - max (my_endbss, my_endbss_static); + } +#endif + #ifdef RUN_TIME_REMAP if (initialized) run_time_remap (argv[0]); @@@ -1826,8 -1649,10 +1833,10 @@@ Using an Emacs configured with --with-x init_charset (); - /* This calls putenv and so must precede init_process_emacs. Also, - it sets Voperating_system_release, which init_process_emacs uses. */ + /* This calls putenv and so must precede init_process_emacs. */ - init_timefns (dumping); ++ init_timefns (); + + /* This sets Voperating_system_release, which init_process_emacs uses. */ init_editfns (); /* These two call putenv. */ @@@ -1895,13 -1714,9 +1897,12 @@@ } else moncontrol (0); - #endif #endif - initialized = 1; + initialized = true; + + if (dump_mode) + Vdump_mode = build_string (dump_mode); /* Enter editor command loop. This never returns. */ Frecursive_edit (); diff --cc src/eval.c index 9aeafa218c5,28478956e35..b094fc2e663 --- a/src/eval.c +++ b/src/eval.c @@@ -219,8 -235,15 +232,17 @@@ backtrace_next (union specbinding *pdl return pdl; } +static void init_eval_once_for_pdumper (void); + + static union specbinding * + backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl) + { + pdl--; + while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE) + pdl--; + return pdl; + } + void init_eval_once (void) { diff --cc src/fns.c index d5759c5fc6c,0fad6f47447..9e794202184 --- a/src/fns.c +++ b/src/fns.c @@@ -3700,10 -3881,12 +3877,12 @@@ hashfn_equal (struct hash_table_test *h `eql' to compare keys. The hash code returned is guaranteed to fit in a Lisp integer. */ -static EMACS_UINT +EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key) { - return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key); + return ((FLOATP (key) || BIGNUMP (key)) + ? hashfn_equal (ht, key) + : hashfn_eq (ht, key)); } /* Value is a hash code for KEY for use in hash table H which uses as @@@ -3802,11 -3985,10 +3981,11 @@@ make_hash_table (struct hash_table_tes h->rehash_threshold = rehash_threshold; h->rehash_size = rehash_size; h->count = 0; - h->key_and_value = Fmake_vector (make_number (2 * size), Qnil); - h->hash = Fmake_vector (make_number (size), Qnil); - h->next = Fmake_vector (make_number (size), make_number (-1)); - h->index = Fmake_vector (make_number (index_size), make_number (-1)); + h->key_and_value = make_nil_vector (2 * size); + h->hash = make_nil_vector (size); + h->next = make_vector (size, make_fixnum (-1)); + h->index = make_vector (index_size, make_fixnum (-1)); + h->next_weak = NULL; h->pure = pure; /* Set up the free list. */ @@@ -3925,43 -4120,6 +4103,43 @@@ maybe_resize_hash_table (struct Lisp_Ha } } +void +hash_table_rehash (struct Lisp_Hash_Table *h) +{ + ptrdiff_t size = HASH_TABLE_SIZE (h); + + /* Recompute the actual hash codes for each entry in the table. + Order is still invalid. */ + for (ptrdiff_t i = 0; i < size; ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key = HASH_KEY (h, i); + EMACS_UINT hash_code = h->test.hashfn (&h->test, key); - set_hash_hash_slot (h, i, make_number (hash_code)); ++ set_hash_hash_slot (h, i, make_fixnum (hash_code)); + } + + /* Reset the index so that any slot we don't fill below is marked + invalid. */ - Ffillarray (h->index, make_number (-1)); ++ Ffillarray (h->index, make_fixnum (-1)); + + /* Rebuild the collision chains. */ + for (ptrdiff_t i = 0; i < size; ++i) + if (!NILP (HASH_HASH (h, i))) + { - EMACS_UINT hash_code = XUINT (HASH_HASH (h, i)); ++ EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i)); + ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index); + set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket)); + set_hash_index_slot (h, start_of_bucket, i); + eassert (HASH_NEXT (h, i) != i); /* Stop loops. */ + } + + /* Finally, mark the hash table as having a valid hash order. + Do this last so that if we're interrupted, we retry on next + access. */ + eassert (h->count < 0); + h->count = -h->count; + eassert (!hash_rehash_needed_p (h)); +} /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH the hash code of KEY. Value is the index of the entry in H diff --cc src/font.c index b5b545580e3,3fc77a1d76a..4ca44942fde --- a/src/font.c +++ b/src/font.c @@@ -5348,13 -5349,13 +5351,13 @@@ syms_of_font (void DEFSYM (QCuser_spec, ":user-spec"); - staticpro (&scratch_font_spec); scratch_font_spec = Ffont_spec (0, NULL); - staticpro (&scratch_font_prefer); + staticpro (&scratch_font_spec); scratch_font_prefer = Ffont_spec (0, NULL); + staticpro (&scratch_font_prefer); - Vfont_log_deferred = Fmake_vector (make_number (3), Qnil); - staticpro (&Vfont_log_deferred); + Vfont_log_deferred = make_nil_vector (3); + staticpro (&Vfont_log_deferred); #if 0 #ifdef HAVE_LIBOTF diff --cc src/keyboard.c index 42803167945,9e38bb21f6e..2d6fa91a16c --- a/src/keyboard.c +++ b/src/keyboard.c @@@ -11872,46 -11818,17 +11824,48 @@@ other kind of crash or fatal error. */ DEFVAR_BOOL ("attempt-orderly-shutdown-on-fatal-signal", attempt_orderly_shutdown_on_fatal_signal, - doc: /* If non-nil, attempt to perform an orderly - shutdown when Emacs receives a fatal signal (e.g., a crash). - This cleanup is unsafe and may lead to deadlocks or data corruption, - but it usually works and may preserve modified buffers that would - otherwise be lost. If nil, crash immediately in response to fatal - signals. */); + doc: /* If non-nil, attempt orderly shutdown on fatal signals. + By default this variable is non-nil, and Emacs attempts to perform + an orderly shutdown when it catches a fatal signal (e.g., a crash). + The orderly shutdown includes an attempt to auto-save your unsaved edits + and other useful cleanups. These cleanups are potentially unsafe and may + lead to deadlocks or data corruption, but it usually works and may + preserve data in modified buffers that would otherwise be lost. + If nil, Emacs crashes immediately in response to fatal signals. */); attempt_orderly_shutdown_on_fatal_signal = true; + pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper); +} + +static void +syms_of_keyboard_for_pdumper (void) +{ + /* Make sure input state is pristine when restoring from a dump. + init_keyboard() also resets some of these, but the duplication + doesn't hurt and makes sure that allocate_kboard and subsequent + early init functions see the environment they expect. */ + + PDUMPER_RESET_LV (pending_funcalls, Qnil); + PDUMPER_RESET_LV (unread_switch_frame, Qnil); + PDUMPER_RESET_LV (internal_last_event_frame, Qnil); + PDUMPER_RESET_LV (last_command_event, Qnil); + PDUMPER_RESET_LV (last_nonmenu_event, Qnil); + PDUMPER_RESET_LV (last_input_event, Qnil); + PDUMPER_RESET_LV (Vunread_command_events, Qnil); + PDUMPER_RESET_LV (Vunread_post_input_method_events, Qnil); + PDUMPER_RESET_LV (Vunread_input_method_events, Qnil); + PDUMPER_RESET_LV (Vthis_command, Qnil); + PDUMPER_RESET_LV (Vreal_this_command, Qnil); + PDUMPER_RESET_LV (Vthis_command_keys_shift_translated, Qnil); + PDUMPER_RESET_LV (Vthis_original_command, Qnil); + PDUMPER_RESET (num_input_keys, 0); + PDUMPER_RESET (num_nonmacro_input_events, 0); + PDUMPER_RESET_LV (Vlast_event_frame, Qnil); + PDUMPER_RESET_LV (Vdeferred_action_list, Qnil); + PDUMPER_RESET_LV (Vdelayed_warnings_list, Qnil); + /* Create the initial keyboard. Qt means 'unset'. */ + eassert (initial_kboard == NULL); initial_kboard = allocate_kboard (Qt); DEFVAR_LISP ("while-no-input-ignore-events", diff --cc src/lisp.h index 98eb87dbcef,faf5a4ad407..7b66de8a43c --- a/src/lisp.h +++ b/src/lisp.h @@@ -493,6 -527,6 +527,7 @@@ enum Lisp_Typ /* Cons. XCONS (object) points to a struct Lisp_Cons. */ Lisp_Cons = USE_LSB_TAG ? 3 : 6, ++ /* Must be last entry in Lisp_Type enumeration. */ Lisp_Float = 7 }; @@@ -2301,12 -2224,13 +2338,14 @@@ struct Lisp_Hash_Tabl /* The comparison and hash functions. */ struct hash_table_test test; - /* Next weak hash table if this is a weak hash table. The head - of the list is in weak_hash_tables. */ + /* Next weak hash table if this is a weak hash table. The head of + the list is in weak_hash_tables. Used only during garbage + collection --- at other times, it is NULL. */ struct Lisp_Hash_Table *next_weak; - }; + } GCALIGNED_STRUCT; + /* Sanity-check pseudovector layout. */ + verify (offsetof (struct Lisp_Hash_Table, weak) == header_size); INLINE bool HASH_TABLE_P (Lisp_Object a) @@@ -2674,11 -2435,12 +2565,15 @@@ struct Lisp_Finalize FUNCTION contains a reference to the finalizer; i.e., call FUNCTION when it is reachable _only_ through finalizers. */ Lisp_Object function; - }; + + /* Circular list of all active weak references. */ + struct Lisp_Finalizer *prev; + struct Lisp_Finalizer *next; + } GCALIGNED_STRUCT; +extern struct Lisp_Finalizer finalizers; +extern struct Lisp_Finalizer doomed_finalizers; + INLINE bool FINALIZERP (Lisp_Object x) { @@@ -3139,38 -2887,14 +3020,28 @@@ CHECK_INTEGER (Lisp_Object x CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ } while (false) - /* Since we can't assign directly to the CAR or CDR fields of a cons - cell, use these when checking that those fields contain numbers. */ - INLINE void - CHECK_NUMBER_CAR (Lisp_Object x) - { - Lisp_Object tmp = XCAR (x); - CHECK_NUMBER (tmp); - XSETCAR (x, tmp); - } - - INLINE void - CHECK_NUMBER_CDR (Lisp_Object x) - { - Lisp_Object tmp = XCDR (x); - CHECK_NUMBER (tmp); - XSETCDR (x, tmp); - } + #define CHECK_INTEGER_COERCE_MARKER(x) \ + do { \ + if (MARKERP (x)) \ + XSETFASTINT (x, marker_position (x)); \ + else \ + CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \ + } while (false) + +/* If we're not dumping using the legacy dumper and we might be using + the portable dumper, try to bunch all the subr structures together + for more efficient dump loading. */ +#ifdef CANNOT_DUMP +# ifdef DARWIN_OS +# define SUBR_SECTION_ATTRIBUTE ATTRIBUTE_SECTION ("__DATA,subrs") +# else +# define SUBR_SECTION_ATTRIBUTE ATTRIBUTE_SECTION (".subrs") +# endif +#else +# define SUBR_SECTION_ATTRIBUTE +#endif + /* Define a built-in function for calling from Lisp. `lname' should be the name to give the function in Lisp, as a null-terminated C string. @@@ -3199,11 -2923,10 +3070,11 @@@ /* This version of DEFUN declares a function prototype with the right arguments, so we can catch errors with maxargs at compile-time. */ #define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ - SUBR_SECTION_ATTRIBUTE \ - static struct Lisp_Subr sname = \ - { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ - static union Aligned_Lisp_Subr sname = \ ++ SUBR_SECTION_ATTRIBUTE \ ++ static union Aligned_Lisp_Subr sname = \ + {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, intspec, 0}; \ + minargs, maxargs, lname, intspec, 0}}; \ Lisp_Object fnname /* defsubr (Sname); @@@ -3648,9 -3413,10 +3566,10 @@@ extern void syms_of_syntax (void) /* Defined in fns.c. */ enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; + extern ptrdiff_t list_length (Lisp_Object); extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST; extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t); -extern void sweep_weak_hash_tables (void); +extern bool sweep_weak_table (struct Lisp_Hash_Table *, bool); extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *); EMACS_UINT hash_string (char const *, ptrdiff_t); EMACS_UINT sxhash (Lisp_Object, int); @@@ -3822,15 -3588,10 +3743,16 @@@ extern void mark_stack (char *, char *) extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; - extern EMACS_INT consing_since_gc; - extern EMACS_INT gc_relative_threshold; - extern EMACS_INT memory_full_cons_threshold; + typedef uintptr_t byte_ct; /* System byte counts reported by GC. */ + extern byte_ct consing_since_gc; + extern byte_ct gc_relative_threshold; + extern byte_ct memory_full_cons_threshold; +#ifdef HAVE_PDUMPER +extern int number_finalizers_run; +#endif +#ifdef ENABLE_CHECKING +extern Lisp_Object Vdead; +#endif extern Lisp_Object list1 (Lisp_Object); extern Lisp_Object list2 (Lisp_Object, Lisp_Object); extern Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object); @@@ -4245,8 -3989,8 +4166,9 @@@ extern void syms_of_module (void) #endif /* Defined in thread.c. */ +extern struct thread_state primary_thread; extern void mark_threads (void); + extern void unmark_main_thread (void); /* Defined in editfns.c. */ extern void insert1 (Lisp_Object); diff --cc src/lread.c index c3bb0c6dfac,5a595f2119b..dde9ccef549 --- a/src/lread.c +++ b/src/lread.c @@@ -4335,9 -4373,9 +4374,9 @@@ OBARRAY defaults to the value of `obarr #define OBARRAY_SIZE 15121 void -init_obarray (void) +init_obarray_once (void) { - Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0)); + Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0)); initial_obarray = Vobarray; staticpro (&initial_obarray); @@@ -4361,13 -4399,11 +4400,14 @@@ DEFSYM (Qvariable_documentation, "variable-documentation"); } + +int ndefsubr; + void - defsubr (struct Lisp_Subr *sname) + defsubr (union Aligned_Lisp_Subr *aname) { + struct Lisp_Subr *sname = &aname->s; Lisp_Object sym, tem; sym = intern_c_string (sname->symbol_name); XSETPVECTYPE (sname, PVEC_SUBR); diff --cc src/minibuf.c index 09927c29553,c1fbfb40857..321fda1ba88 --- a/src/minibuf.c +++ b/src/minibuf.c @@@ -1948,7 -1882,11 +1901,10 @@@ syms_of_minibuf (void DEFSYM (Qminibuffer_completion_table, "minibuffer-completion-table"); staticpro (&last_minibuf_string); - last_minibuf_string = Qnil; + DEFSYM (Qcustom_variable_history, "custom-variable-history"); + Fset (Qcustom_variable_history, Qnil); + DEFSYM (Qminibuffer_history, "minibuffer-history"); DEFSYM (Qbuffer_name_history, "buffer-name-history"); Fset (Qbuffer_name_history, Qnil); diff --cc src/nsfont.m index 62fa07efe19,b59f87f4682..9721e489357 --- a/src/nsfont.m +++ b/src/nsfont.m @@@ -36,9 -36,8 +36,9 @@@ Author: Adrian Robert (arobert@cogsci.u #include "character.h" #include "font.h" #include "termchar.h" +#include "pdumper.h" - /* TODO: Drop once we can assume gnustep-gui 0.17.1. */ + /* TODO: Drop once we can assume gnustep-gui 0.17.1. */ #ifdef NS_IMPL_GNUSTEP #import #endif @@@ -1510,12 -1508,7 +1510,12 @@@ syms_of_nsfont (void DEFSYM (Qapple, "apple"); DEFSYM (Qmedium, "medium"); DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script, - doc: /* Internal use: maps font registry to Unicode script. */); + doc: /* Internal use: maps font registry to Unicode script. */); + pdumper_do_now_and_after_load (syms_of_nsfont_for_pdumper); +} - ascii_printable = NULL; +static void +syms_of_nsfont_for_pdumper (void) +{ + register_font_driver (&nsfont_driver, NULL); } diff --cc src/nsterm.m index 08e2fcedfcc,6383e4b7ab5..29aa6214527 --- a/src/nsterm.m +++ b/src/nsterm.m @@@ -9301,9 -9326,8 +9327,9 @@@ syms_of_nsterm (void NSTRACE ("syms_of_nsterm"); ns_antialias_threshold = 10.0; + PDUMPER_REMEMBER_SCALAR (ns_antialias_threshold); - /* from 23+ we need to tell emacs what modifiers there are.. */ + /* From 23+ we need to tell emacs what modifiers there are. */ DEFSYM (Qmodifier_value, "modifier-value"); DEFSYM (Qalt, "alt"); DEFSYM (Qhyper, "hyper"); diff --cc src/pdumper.c index 8b06f05f487,00000000000..eb080384f8d mode 100644,000000..100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@@ -1,5304 -1,0 +1,5474 @@@ +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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: + - - Make sure global finalizer list makes it across the dump. - + - 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 - # define CHECK_STRUCTS 1 ++# 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 +# 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 + { - /* Copy raw bytes from the dump into Emacs. */ ++ /* 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, - /* Set an aligned pointer-sized object in Emacs to a dump offset. */ ++ /* 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 - something also in Emacs. */ ++ 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 - dump. Must be last. */ ++ 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; - int8_t immediate_i8; - int16_t immediate_i16; - int32_t immediate_i32; + } 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 - indicator (as opposed to a special sentinel) so we can efficiency ++ 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. */ - bool_bf dump_object_starts : 1; ++ 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 - 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, - }; ++ 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) + + +/* 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); + - static void ++/* 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) +{ - /* TODO: assert that emacs_ptr is actually in emacs */ ++ /* 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 - invocations --- i.e., is invariant across a dump. */ ++ 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) \ + { \ - type result; \ + ALLOW_IMPLICIT_CONVERSION; \ - CONS_TO_INTEGER (value, type, 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 result; \ + } + +#define DEFINE_TOLISP_FUNC(fn, type) \ + static Lisp_Object \ + fn (type value) \ + { \ - return INTEGER_TO_CONS (value); \ ++ 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 offset at which OBJECT has been dumped, or 0 if OBJECT has - not been dumped. */ ++/* 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; - return dump_off_from_lisp (Fgethash (object, 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), - make_number (0)); ++ 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 ( - XFASTINT (Fhash_table_count (dump_queue->sequence_numbers)) ++ 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), - (unsigned) XFASTINT (Fhash_table_count (dump_queue->link_weights))); ++ (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) +{ - if (!dump_object_self_representing_p (object) || - dump_object_emacs_ptr (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) + { - bool cold = BOOL_VECTOR_P (object) || FLOATP (object); + if (state == DUMP_OBJECT_NOT_SEEN) + { - dump_remember_object (ctx, object, DUMP_OBJECT_ON_NORMAL_QUEUE); - if (cold) - dump_remember_cold_op (ctx, COLD_OP_OBJECT, object); ++ state = DUMP_OBJECT_ON_NORMAL_QUEUE; ++ dump_remember_object (ctx, object, state); + } - if (!cold && - state <= DUMP_OBJECT_NOT_SEEN && - state != DUMP_OBJECT_DEFERRED) ++ /* 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); + } + } - /* Always make sure that we have a referrer. */ ++ /* 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) - dump_push (&ctx->cold_queue, Fcons (make_number (op), arg)); ++ 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) + { - case Lisp_Misc: + 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_COPY_FROM_DUMP), ++ 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, - list4 (make_number (RELOC_EMACS_IMMEDIATE), ++ 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, - list3 (make_number (RELOC_EMACS_DUMP_PTR_RAW), ++ 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 - dump_emacs_reloc_to_dump_lv (struct dump_context *ctx, - Lisp_Object *emacs_ptr, - Lisp_Object 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 (dump_off_to_lisp (RELOC_EMACS_DUMP_LV + XTYPE (value)), ++ 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, - list3 (make_number (RELOC_EMACS_EMACS_PTR_RAW), ++ 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 (fixup_subtype == LV_FIXUP_LISP_OBJECT ++ 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 ( - make_number (DUMP_FIXUP_PTR_DUMP_RAW), ++ 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)); - dump_emacs_reloc_to_dump_lv (ctx, root_ptr, *root_ptr); ++ 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; - if (ptr_raw_type == NULL) ++ 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; - case Lisp_Misc: + case Lisp_String: + case Lisp_Vectorlike: + case Lisp_Cons: + case Lisp_Float: + value = make_lisp_ptr (ptrval, *ptr_raw_type); + break; + default: + emacs_abort (); + } + } + - bool is_ptr_raw = (ptr_raw_type != NULL); - + /* 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; + - intptr_t abs_emacs_ptr; - cpyptr (&abs_emacs_ptr, in_field); - ptrdiff_t rel_emacs_ptr = abs_emacs_ptr - (intptr_t) emacs_basis (); + 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_reloc_dump_to_emacs_ptr_raw (ctx, ctx->obj_offset + relpos); ++} ++ ++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; - 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. */ ++ 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, - 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_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, ++ 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 (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 (); - } - } + 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_field_lv_rawptr (ctx, out, finalizer, field, Lisp_Misc, ++ 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_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_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); - dump_field_lv (ctx, &out, finalizer, &finalizer->function, - WEIGHT_NORMAL); + return dump_object_finish (ctx, &out, sizeof (out)); +} + - 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; - } - +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 - dump_emacs_reloc_to_dump_lv (ctx, objfwd->objvar, *objfwd->objvar); ++ 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 ( - Fgethash (symbol, symbol_aux, make_number (0))); ++ 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 - dump_symbol (struct dump_context *ctx, struct Lisp_Symbol *symbol) ++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) + { - /* 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; ++ 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); + - dump_off offset = dump_object_finish (ctx, &out, sizeof (out)); ++ 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; +} + - 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); - } - +/* 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), - make_number (0))); ++ make_fixnum (0))); +} + +static dump_off +dump_hash_table (struct dump_context *ctx, - const struct Lisp_Hash_Table *hash_in) ++ 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) + { - /* 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; ++ 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; - buffer->display_count_ = make_number (0); ++ 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, - Lisp_Misc, WEIGHT_NORMAL); ++ 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_vectorlike (struct dump_context *ctx, const struct Lisp_Vector *v) ++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 - dump_off offset; - Lisp_Object lv = make_lisp_ptr ((void *) v, Lisp_Vectorlike); ++ 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_hash_table (ctx, (struct Lisp_Hash_Table *) v); ++ offset = dump_hash_table (ctx, lv, offset); + break; + case PVEC_BUFFER: - offset = dump_buffer (ctx, (struct buffer *) v); ++ offset = dump_buffer (ctx, XBUFFER (lv)); + break; + case PVEC_SUBR: - offset = dump_subr (ctx, (const struct Lisp_Subr *) v); ++ 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: - error_unsupported_dump_object (ctx, lv, "threading 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; +} + - /* Internal guts of dump_object(). ++/* 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. + - 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. ++ 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. + - Called directly by dump_copied_objects() to bypass dump_object()'s - check for copied objects. ++ 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 - dump_object_1 (struct dump_context *ctx, Lisp_Object object) ++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) - { - /* 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); ++ return offset; /* Object already dumped. */ + - /* offset can be < 0 if we've deferred an object --- e.g., a - hash table. */ - if (ctx->flags.dump_object_contents && offset > 0) ++ bool cold = BOOL_VECTOR_P (object) || FLOATP (object); ++ if (cold && ctx->flags.defer_cold_objects) ++ { ++ if (offset != DUMP_OBJECT_ON_COLD_QUEUE) + { - eassert (offset % (1<flags.dump_object_starts) - dump_push (&ctx->object_starts, - list2 (dump_off_to_lisp (XTYPE (object)), - dump_off_to_lisp (offset))); ++ dump_remember_cold_op (ctx, COLD_OP_OBJECT, object); + } ++ return 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 ++ void* obj_in_emacs = dump_object_emacs_ptr (object); ++ if (obj_in_emacs && ctx->flags.defer_copied_objects) + { - /* 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) ++ if (offset != DUMP_OBJECT_ON_COPIED_QUEUE) + { - /* 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. */ ++ 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; - dump_object_1 (ctx, object); ++ 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; + } + - return result; ++ /* 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<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_emacs_reloc_immediate_int ( - ctx, &charset_table_used, charset_table_used); - dump_emacs_reloc_immediate_ptrdiff_t ( - ctx, &charset_table_size, charset_table_used); + 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, - dump_object_for_offset (ctx, make_lisp_ptr (value, Lisp_Misc))); ++ 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 = - Fsort (Fnreverse ( - ctx->copied_queue), ++ 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 - dump_copied_objects (struct dump_context *ctx) ++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. - The overfall result is that to the greatest extent possible while ++ 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); - - /* 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); ++ /* 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; - int cs_i = XFASTINT (XCAR (data)); ++ 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 - dump_cold_data (struct dump_context *ctx) ++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. */ - struct dump_flags old_flags = ctx->flags; + 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); - enum cold_op op = (enum cold_op) XFASTINT (XCAR (item)); ++ 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; - case Lisp_Misc: + 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_hot (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 - dump_user_remembered_data_cold (struct dump_context *ctx) ++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 - and issue a copy relocation. */ ++ 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_user_remembered_data_hot. */ ++ 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. - + */ + 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_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)); - } - +/* 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); +} + - static void - dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc) ++static struct dump_reloc ++dump_decode_dump_reloc (Lisp_Object lreloc) +{ + struct dump_reloc reloc; - dump_object_start (ctx, 1, &reloc, sizeof (reloc)); + dump_reloc_set_type ( + &reloc, - (enum dump_reloc_type) XFASTINT (dump_pop (&lreloc))); ++ (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; ++} + - dump_check_dump_off (ctx, dump_reloc_get_offset (reloc)); - eassert (NILP (lreloc)); - dump_object_finish (ctx, &reloc, sizeof (reloc)); ++#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; - int type = XFASTINT (dump_pop (&lreloc)); ++ 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; - 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; + 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. */ + - if (XFASTINT (XCAR (lreloc_a)) != RELOC_EMACS_COPY_FROM_DUMP || - XFASTINT (XCAR (lreloc_b)) != 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 */ + - return list4 (make_number (RELOC_EMACS_COPY_FROM_DUMP), ++ 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, - void (*handler)(struct dump_context *, Lisp_Object), - Lisp_Object (*merger)(Lisp_Object a, Lisp_Object b), ++ 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)) - dump_do_fixup (ctx, dump_pop (&fixups)); ++ { ++ 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.dump_object_starts = 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; - // ctx->flags.defer_symbols = true; ++ // 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); - dump_user_remembered_data_hot (ctx); ++ 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 - 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)); ++ 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); - const dump_off hot_end = ctx->offset; + + /* 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 - the Emacs data section instead of just used directly. */ - ctx->header.discardable_start = ctx->offset; - ctx->flags.dump_object_starts = false; ++ 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; + - dump_copied_objects (ctx); ++ dump_drain_copied_objects (ctx); + eassert (dump_queue_empty_p (&ctx->dump_queue)); - eassert (NILP (ctx->copied_queue)); ++ + dump_off discardable_end = ctx->offset; + dump_align_output (ctx, dump_get_page_size ()); + ctx->header.cold_start = ctx->offset; + - /* Resume recording object starts, since the cold section will stick - around. */ - ctx->flags.dump_object_starts = true; - + /* 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_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 ++ 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. */ - dump_user_remembered_data_cold (ctx); ++ 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_dump_reloc, NULL, ++ ctx, ++ dump_emit_dump_reloc, ++ emacs_reloc_merger, + &ctx->object_starts, + &ctx->header.object_starts); + drain_reloc_list ( - ctx, dump_emit_emacs_reloc, dump_merge_emacs_relocs, ++ 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); +} + + +/* 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; +} + - static void * - emacs_ptr (const ptrdiff_t offset) - { - // TODO: assert somehow that offset is actually inside Emacs - return (void *) (emacs_basis () + offset); - } - +/* 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: - 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; ++ 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 */ + + + +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 */ +} diff --cc src/search.c index ce21483fb45,f97dbe73341..059f8fc4d2e --- a/src/search.c +++ b/src/search.c @@@ -29,9 -29,8 +29,9 @@@ along with GNU Emacs. If not, see . */ + + #include + + #include "systime.h" + + #include "blockinput.h" + #include "bignum.h" + #include "coding.h" + #include "lisp.h" + + #include + + #include + #include + #include + #include + #include + + #ifdef HAVE_TIMEZONE_T + # include + # 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 -init_timefns (bool 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 (dumping) ++ 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; + } + + + 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); + } diff --cc src/w32uniscribe.c index b2593c3a26a,bec988041ad..c214784fc83 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@@ -36,7 -36,7 +36,8 @@@ along with GNU Emacs. If not, see