[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master d12e5d0 1/2: Add portable dumper
|
From: |
Daniel Colascione |
|
Subject: |
[Emacs-diffs] master d12e5d0 1/2: Add portable dumper |
|
Date: |
Tue, 15 Jan 2019 17:39:39 -0500 (EST) |
branch: master
commit d12e5d003d503025c1c9b0335d6518a6c3bdfae1
Author: Daniel Colascione <address@hidden>
Commit: Daniel Colascione <address@hidden>
Add portable dumper
Add a new portable dumper as an alternative to unexec. Use it by default.
* src/dmpstruct.awk: New file.
* src/doc.c (get_doc_string): use will_dump_p().
* src/editfns.c (styled_format): silence compiler warning
with UNINIT.
* src/emacs-module.c (syms_of_module): staticpro ltv_mark.
* src/emacs.c (gflags): new variable.
(init_cmdargs): unwrap
(string_starts_with_p, find_argument, dump_error_to_string)
(load_pdump): new functions.
(main): detect pdumper and --temacs invocation; actually load
portable dump when detected; set gflags as appropriate; changes to
init functions throughout to avoid passing explicit
'initialized' argument.
* src/eval.c (inhibit_lisp_code): remove unused variable.
(init_eval_once_for_pdumper): new function.
(init_eval_once): call it.
* src/filelock.c: CANNOT_DUMP -> will_dump_p()
* src/fingerprint-dummy.c: new file
* src/fingerprint.h: new file
* src/fns.c: CANNOT_DUMP -> will_dump_p(), etc.
(weak_hash_tables): remove
(hashfn_equal, hashfn_eql): un-staticify
(make_hash_table): set new 'next_weak' hash table field; drop
global weak_hash_tables logic.
(copy_hash_table): drop global weak_hash_tables logic.
(hash_table_rehash): new function.
(hash_lookup, hash_put, hash_remove_from_table, hash_clear):
rehash if needed.
(sweep_weak_table): un-staticify; explain logic; bool-ify.
(sweep_weak_hash_tables): remove function.
* src/font.c (syms_of_font): remember pdumper stuff.
* src/fontset.c (syms_of_fontset): remember pdumper stuff.
* src/frame.c (make_initial_frame): don't reset Vframe_list.
(init_frame_once_for_pdumper, init_frame_once): new functions.
(syms_of_frame): remove redundant staticpro.
* src/fringe.c (init_fringe_once_for_pdumper): new functin.
(init_fringe_once): call it.
* src/ftcrfont.c (syms_of_ftcrfont_for_pdumper): new function.
(syms_of_ftcrfont): call it.
* src/ftfont.c (syms_of_ftfont_for_pdumper): new function.
(syms_of_ftfont): call it.
* src/ftxont.c (syms_of_ftxfont_for_pdumper): new function.
(syms_of_ftxfont): call it.
* src/gmalloc.c: adjust for pdumper througout
(DUMPED): remove weird custom dumped indicator.
* src/gnutls.c (syms_of_gnutls): pdumper note for
gnutls_global_initialized.
* src/image.c (syms_of_image): add pdumper comment,
initializer note.
* src/insdel.c (prepare_to_modify_buffer_1): account
for buffer contents possibly being in dump image.
* src/keyboard.c (syms_of_keyboard_for_pdumper): new function.
(syms_of_keyboard): staticpro more; call pdumper syms function.
* src/lisp.h: add comments throughout
(gflags): declare.
(will_dump_p, will_bootstrap_p, will_dump_with_pdumper_p)
(dumped_with_pdumper_p, will_dump_with_unexec_p)
(dumped_with_unexec_p, definitely_will_not_unexec_p): new
functions.
(POWER_OF_2, ROUNDUP): move macros.
(PSEUDOVECTOR_TYPE, PSEUDOVECTOR_TYPEP): take vectorlike header
pointer instead of vector; constify.
(Lisp_Hash_Table): add comment about need to rehash on access; add
comment for next_weak.
(HASH_KEY, HASH_VALUE, HASH_HASH, HASH_TABLE_SIZE): const-ify.
(hash_table_rehash): declare.
(hash_rehash_needed_p, hash_rehash_if_needed): new functions.
(finalizers, doomed_finalizers): declare extern.
(SUBR_SECTION_ATTRIBUTE): new macro.
(staticvec, staticidx): un-static-ify.
(sweep_weak_hash_tables): remove declaration.
(sweep_weak_table): declare.
(hashfn_eql, hashfn_equal): declare.
(number_finalizers_run): new variable.
(Vdead): externify when ENABLE_CHECKING.
(gc_root_type): new enumeration.
(gc_root_visitor): new struct.
(visit_static_gc_roots): declare.
(vectorlike_nbytes): declare.
(vector_nbytes): define as trivial inline function wrapper for
vectorlike_nbytes.
(init_obarray_once): change signature.
(primary_thread): extern-ify.
(init_buffer): change signature.
(init_frame_once): declare.
* src/lread.c (readevalloop): adjust for new dumped predicates.
(init_obarray_once): new function.
(ndefsubr): new variable.
(defsubr): increment it.
(load_path_check): adjust for pdumper.
(load_path_default): use pdumper functions; adjust for
dump search.
* src/macfont.m (macfont_init_font_change_handler): avoid
shadowing global.
(syms_of_macfont_for_pdumper): new function.
(syms_of_macfont): call it.
* src/menu.c (syms_of_menu): staticpro more stuff.
* src/minibuf.c (Ftry_completion): rehash if needed.
(init_minibuf_once_for_pdumper): new function.
(init_minibuf_once): call it.
* src/nsfont.m (syms_of_nsfns): staticpro more.
* src/nsfont.m (syms_of_nsfont_for_pdumper): new function.
(syms_of_nsfont): call it.
* src/nsterm.m (syms_of_nsfont): remember pdumper stuff.
* src/pdumper.c: new file.
* src/pdumper.h: new file.
* src/process.c (init_process_emacs): use new pdumper functions
instead of CANNOT_DUMP.
* src/profiler.c (syms_of_profiler_for_pdumper): new function.
(syms_of_profiler_for_pdumper): call it.
* src/search.c (syms_of_search_for_pdumper): new function.
(syms_of_search_for_pdumper): call it.
* src/sheap.c (bss_sbrk_did_unexec): remove.
* src/sheap.h (bss_sbrk_did_unexec): remove.
* src/syntax.c (syms_of_syntax): don't redundantly staticpro
re_match_object.
* src/sysdep.c: use will_dump_with_unexec_p() instead of bss
hack thing.
* src/syssignals.h (init_sigsegv): declare.
* src/systime.h (init_timefns): remove bool from signature.
* src/textprop.c (syms_of_textprop): move staticpro.
* src/thread.c (main_thread_p): constify.
* src/thread.h (main_thread_p): constify.
* src/timefns.c (init_timefns): remove bool from signature.
(syms_of_timefns_for_pdumper): new function.
(syms_of_timefns): call it.
* src/w32.c: rearrange code.
* src/w32.h (w32_relocate): declare.
* src/w32fns.c (syms_of_w32fns): add pdumper note.
* src/w32font.c (syms_of_w32font_for_pdumper): new function.
(syms_of_w32font): call it.
* src/w32heap.c (using_dynamic_heap): new variable.
(init_heap): use it.
* src/w32menu.c (syms_of_w32menu): add pdumper note.
* src/w32proc.c
(ctrl_c_handler, mainCRTStartup, _start, open_input_file)
(rva_to_section, close_file_data): move here.
* src/w32uniscribe.c (syms_of_w32uniscribe_for_pdumper):
new function.
(syms_of_w32uniscribe): call it.
* src/window.c (init_window_once_for_pdumper): new function.
(init_window_once): call it; staticpro more stuff.
* src/xfont.c (syms_of_xfont_for_pdumper): new function.
(syms_of_xfont): call it.
* src/xftfont.c (syms_of_xftfont_for_pdumper): new function.
(syms_of_xftfont): call it.
* src/xmenu.c (syms_of_xmenu_for_pdumper): new function.
(syms_of_xmenu): call it.
* src/xselect.c (syms_of_xselect_for_pdumper): new function.
(syms_of_xselect): call it.
* src/xsettings.c (syms_of_xsettings): add more pdumper notes.
* src/term.c (syms_of_xterm): add pdumper note.
* src/dispnew.c (init_faces_initial): new function.
(init_display_interactive): rename from init_display; use
will_dump_p instead of !initialized. Initialize faces early for
pdumper if needed.
(init_display): new function.
(syms_of_display_for_pdumper): new function.
(syms_of_display): call it.
* src/dbusbind.c (syms_of_dbusbind): Add TODO for bus reset
on pdumper load.
* src/data.c (Fdefalias): Use will_dump_p
instead of Vpurify_flag.
(Fmake_variable_buffer_local): silence compiler warning with -Og
by making valcontents UNINIT.
(arith_driver): silence compiler warning with UNINIT.
* src/conf_post.h (ATTRIBUTE_SECTION): new macro.
* src/composite.c (composition_gstring_put_cache): rehash hash
table if needed.
* src/coding.c (init_coding_once, syms_of_coding): remember
pdumper stuff.
* src/charset.h (charset_table_size, charset_table_user): declare.
* src/charset.c (charset_table_used, charset_table_size): un-static.
(init_charset_oncem, syms_of_charset): remember pdumper stuff.
* src/category.c (category_table_version): remove obsolete
variable.
* src/callint.c (syms_of_callint): staticpro 'preserved_fns'
(init_callproc): use will_dump_p instead of !CANNOT_DUMP.
* src/bytecode.c (exec_byte_code): rehash table tables if needed
* src/buffer.c (alloc_buffer_text, free_buffer_text): account for
pdumper
(init_buffer_once): add TODO; remember stuff for pdumper.
(init_buffer): don't take initialized argument; adjust
for pdumper.
* src/atimer.c (init_atimer): initialize subr only if
!initialized.
* src/alloc.c: (vector_marked_p, set_vector_marked)
(vectorlike_marked_p, set_vectorlike_marked, cons_marked_p)
(set_cons_marked, string_marked_p, set_string_marked)
(symbol_marked_p, set_symbol_marked, interval_marked_p)
(set_interval_marked): new accessor routines. Use them
instead of raw GC access throughout.
(Vdead): make non-static when ENABLE_CHECKING.
(vectorlike_nbytes): rename of 'vector_nbytes'; take a vectorlike
header as input instead of a vector.
(number_finalizers_run): new internal C variable.
(mark_maybe_object): check for pdumper objects.
(valid_pointer_p): don't be gratuitously inefficient under rr(1).
(make_pure_c_string): add support for size_byte = -2 mode
indicating that string data points into Emacs image rodata.
(visit_vectorlike_root): visits GC roots embedded in
vectorlike objects.
(visit_buffer_root): visits GC roots embedded in
our totally-not-a-buffer buffer global objects.
(visit_static_gc_roots): visit GC roots in the Emacs data section.
(mark_object_root_visitor): root callback used for conventional GC
marking
(weak_hash_tables): new internal variable for tracking found weak
hash tables during GC.
(mark_and_sweep_weak_table_contents): new weak hash table marking.
(garbage_collect_1): use new GC root visitor machinery.
(mark_vectorlike): accept a vectorlike_header instead of a
Lisp_Vector.
(mark_frame, mark_window, mark_hash_table): new functions.
(mark_object): initialize 'm'; check for pdumper objects and use
new mark-bit accessors throughout. Remove some object-specific
marking code and move to helper functions above.
(survives_gc_p): check for pdumper objects.
(gc-sweep): clear pdumper mark bits.
(init_alloc_once_for_pdumper): new helper function for early init
called both during normal init and pdumper load.
(init_alloc_once): pdumper integration.
* src/Makefile.in: Rewrite dumping for pdumper; add pdumper.o;
invoke temacs with --temacs command line option; build dmpstruct.h
from dmpstruct.awk; stop relying on CANNOT_DUMP; clean up pdumper
intermediate files during build.
* nextstep/Makefile.in: build emacs.pdmp into NS packages
* lisp/startup.el: account for new '--temacs' and '--dump-file'
command line option.
* lisp/loadup.el: rewrite early init to account for pdumper; use
injected 'dump-mode' variable (set via the new '--temacs' option)
instead of parsing command line.
* lisp/cus-start.el: Check 'dump-mode' instead of 'purify-flag',
since the new 'dump-mode'
* lib-src/make-fingerprint.c: new program
* lib-src/Makefile.in: built make-fingerprint utility program
* configure.ac: Add --with-pdumper toggle to control pdumper
support; add --with-unexec toggle to control unexec support.
Add --with-dumping option to control which dumping strategy we use
by default. Adjust for pdumper throughout. Check for
posix_madvise.
* Makefile.in: Add @DUMPING@ substitution; add pdumper mode.
* .gitignore: Add make-fingerprint, temacs.in, fingerprint.c,
dmpstruct.h, and pdumper dump files.
---
.gitignore | 5 +
Makefile.in | 5 +
configure.ac | 140 +-
lib-src/Makefile.in | 5 +-
lib-src/make-fingerprint.c | 113 +
lisp/cus-start.el | 4 +-
lisp/emacs-lisp/pcase.el | 1 +
lisp/files.el | 2 +-
lisp/international/characters.el | 2 +-
lisp/international/mule.el | 2 +-
lisp/loadup.el | 168 +-
lisp/startup.el | 6 +-
nextstep/Makefile.in | 6 +-
src/Makefile.in | 101 +-
src/alloc.c | 815 ++++--
src/atimer.c | 3 +-
src/buffer.c | 68 +-
src/bytecode.c | 3 +-
src/callint.c | 3 +-
src/callproc.c | 4 +-
src/category.c | 11 -
src/charset.c | 50 +-
src/charset.h | 2 +
src/coding.c | 9 +
src/composite.c | 1 +
src/conf_post.h | 2 +
src/data.c | 8 +-
src/dbusbind.c | 2 +
src/dispnew.c | 69 +-
src/dmpstruct.awk | 28 +
src/doc.c | 16 +-
src/editfns.c | 2 +-
src/emacs-module.c | 5 +-
src/emacs.c | 304 ++-
src/eval.c | 30 +-
src/filelock.c | 11 +-
src/fingerprint-dummy.c | 24 +
src/fingerprint.h | 32 +
src/fns.c | 139 +-
src/font.c | 10 +-
src/fontset.c | 2 +
src/frame.c | 28 +-
src/fringe.c | 11 +-
src/ftcrfont.c | 9 +
src/ftfont.c | 10 +
src/ftxfont.c | 9 +
src/gmalloc.c | 13 +-
src/gnutls.c | 2 +
src/image.c | 3 +
src/insdel.c | 9 +
src/intervals.h | 1 -
src/keyboard.c | 41 +-
src/lisp.h | 225 +-
src/lread.c | 203 +-
src/macfont.m | 27 +-
src/menu.c | 3 +-
src/minibuf.c | 30 +-
src/nsfns.m | 3 +-
src/nsfont.m | 11 +-
src/nsmenu.m | 2 +
src/nsterm.m | 2 +
src/pdumper.c | 5593 ++++++++++++++++++++++++++++++++++++++
src/pdumper.h | 267 ++
src/process.c | 4 +-
src/profiler.c | 21 +
src/search.c | 35 +-
src/sheap.c | 1 -
src/sheap.h | 1 -
src/syntax.c | 3 -
src/sysdep.c | 15 +-
src/syssignal.h | 3 +-
src/systime.h | 2 +-
src/textprop.c | 5 +-
src/thread.c | 3 +-
src/thread.h | 2 +-
src/timefns.c | 25 +-
src/unexw32.c | 116 -
src/w32.c | 34 +
src/w32.h | 2 +
src/w32fns.c | 3 +
src/w32font.c | 11 +
src/w32heap.c | 7 +
src/w32menu.c | 2 +
src/w32proc.c | 117 +
src/w32uniscribe.c | 9 +
src/window.c | 60 +-
src/xfont.c | 8 +
src/xftfont.c | 9 +-
src/xmenu.c | 22 +-
src/xselect.c | 26 +-
src/xsettings.c | 6 +
src/xterm.c | 2 +
92 files changed, 8308 insertions(+), 961 deletions(-)
diff --git a/.gitignore b/.gitignore
index d295797..53f41f0 100644
--- a/.gitignore
+++ b/.gitignore
@@ -171,6 +171,7 @@ lib-src/emacsclient
lib-src/etags
lib-src/hexl
lib-src/make-docfile
+lib-src/make-fingerprint
lib-src/movemail
lib-src/profile
lib-src/test-distrib
@@ -184,6 +185,10 @@ src/bootstrap-emacs
src/emacs
src/emacs-[0-9]*
src/temacs
+src/temacs.in
+src/fingerprint.c
+src/dmpstruct.h
+src/*.pdmp
# Character-set info.
admin/charsets/jisx2131-filter
diff --git a/Makefile.in b/Makefile.in
index cd3a0a9..b6cd04d 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -66,6 +66,8 @@
SHELL = @SHELL@
address@hidden@
+
# This only matters when inheriting a CDPATH not starting with the
# current directory.
CDPATH=
@@ -491,6 +493,9 @@ install-arch-dep: src install-arch-indep install-etcdoc
install-$(NTDIR)
$(MAKE) -C lib-src install
ifeq (${ns_self_contained},no)
${INSTALL_PROGRAM} $(INSTALL_STRIP) src/emacs${EXEEXT}
"$(DESTDIR)${bindir}/$(EMACSFULL)"
+ifeq (${DUMPING},pdumper)
+ ${INSTALL_DATA} src/emacs.pdmp
"$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs.pdmp
+endif
-chmod 755 "$(DESTDIR)${bindir}/$(EMACSFULL)"
ifndef NO_BIN_LINK
rm -f "$(DESTDIR)${bindir}/$(EMACS)"
diff --git a/configure.ac b/configure.ac
index 16a2ce0..7529719 100644
--- a/configure.ac
+++ b/configure.ac
@@ -311,6 +311,87 @@ this option's value should be 'yes', 'no', 'alsa', 'oss',
or 'bsd-ossaudio'.])
],
[with_sound=$with_features])
+AC_ARG_WITH([pdumper],
+ AS_HELP_STRING(
+ [--with-pdumper=VALUE],
+ [enable pdumper support unconditionally
+ ('yes', 'no', or 'auto': default 'auto')]),
+ [ case "${withval}" in
+ yes|no|auto) val=$withval ;;
+ *) AC_MSG_ERROR(
+ ['--with-pdumper=$withval' is invalid;
+this option's value should be 'yes' or 'no'.]) ;;
+ esac
+ with_pdumper=$val
+ ],
+ [with_pdumper=auto])
+
+AC_ARG_WITH([unexec],
+ AS_HELP_STRING(
+ [--with-unexec=VALUE],
+ [enable unexec support unconditionally
+ ('yes', 'no', or 'auto': default 'auto')]),
+ [ case "${withval}" in
+ yes|no|auto) val=$withval ;;
+ *) AC_MSG_ERROR(
+ ['--with-unexec=$withval' is invalid;
+this option's value should be 'yes' or 'no'.]) ;;
+ esac
+ with_unexec=$val
+ ],
+ [with_unexec=auto])
+
+AC_ARG_WITH([dumping],[AS_HELP_STRING([--with-dumping=VALUE],
+ [kind of dumping to use for initial Emacs build
+(VALUE one of: pdumper, unexec, none; default pdumper)])],
+ [ case "${withval}" in
+ pdumper|unexec|none) val=$withval ;;
+ *) AC_MSG_ERROR(['--with-dumping=$withval is invalid;
+this option's value should be 'pdumper', 'unexec', or 'none'.])
+ ;;
+ esac
+ with_dumping=$val
+ ],
+ [with_dumping=pdumper])
+
+if test "$with_pdumper" = "auto"; then
+ if test "$with_dumping" = "pdumper"; then
+ with_pdumper=yes
+ else
+ with_pdumper=no
+ fi
+fi
+
+if test "$with_unexec" = "auto"; then
+ if test "$with_dumping" = "unexec"; then
+ with_unexec=yes
+ else
+ with_unexec=no
+ fi
+fi
+
+if test "$with_dumping" = "pdumper" && test "$with_pdumper" = "no"; then
+ AC_MSG_ERROR(['--with-dumping=pdumper' requires pdumper support])
+fi
+
+if test "$with_dumping" = "unexec" && test "$with_unexec" = "no"; then
+ AC_MSG_ERROR(['--with-dumping=unexec' requires unexec support])
+fi
+
+if test "$with_pdumper" = "yes"; then
+ AC_DEFINE(HAVE_PDUMPER, 1, [Define to build with portable dumper support])
+fi
+
+if test "$with_unexec" = "yes"; then
+ CANNOT_DUMP=no
+else
+ CANNOT_DUMP=yes
+fi
+
+DUMPING=$with_dumping
+AC_SUBST(DUMPING)
+AC_SUBST(CANNOT_DUMP)
+
dnl FIXME currently it is not the last.
dnl This should be the last --with option, because --with-x is
dnl added later on when we find the file name of X, and it's best to
@@ -1215,6 +1296,10 @@ AC_PATH_PROG(GZIP_PROG, gzip)
test $with_compress_install != yes && test -n "$GZIP_PROG" && \
GZIP_PROG=" # $GZIP_PROG # (disabled by configure
--without-compress-install)"
+if test "$with_dumping" = "unexec" && test "$opsys" = "nacl"; then
+ AC_MSG_ERROR([nacl is not compatible with --with-dumping=unexec])
+fi
+
AC_CACHE_CHECK([for 'find' args to delete a file],
[emacs_cv_find_delete],
[if touch conftest.tmp && find conftest.tmp -delete 2>/dev/null &&
@@ -1227,25 +1312,21 @@ 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
fi
case $opsys,$PAXCTL_notdumped,$emacs_uname_r in
@@ -1382,22 +1463,12 @@ AC_CACHE_CHECK([whether addresses are sanitized],
[emacs_cv_sanitize_address=yes],
[emacs_cv_sanitize_address=no])])
-dnl The function dump-emacs will not be defined and temacs will do
-dnl (load "loadup") automatically unless told otherwise.
-test "x$CANNOT_DUMP" = "x" && CANNOT_DUMP=no
-case "$opsys" in
- nacl) CANNOT_DUMP=yes ;;
-esac
-
if test "$CANNOT_DUMP" = "yes"; then
- AC_DEFINE(CANNOT_DUMP, 1, [Define if Emacs cannot be dumped on your system.])
+ AC_DEFINE(CANNOT_DUMP, 1, [Define if Emacs should not support unexec.])
elif test "$emacs_cv_sanitize_address" = yes; then
AC_MSG_WARN([[Addresses are sanitized; suggest CANNOT_DUMP=yes]])
fi
-AC_SUBST(CANNOT_DUMP)
-
-
UNEXEC_OBJ=unexelf.o
case "$opsys" in
# MSDOS uses unexcoff.o
@@ -1476,8 +1547,9 @@ case "$opsys" in
LD_SWITCH_SYSTEM="\$(LD_SWITCH_X_SITE_RPATH) $LD_SWITCH_SYSTEM" ;;
esac
-
C_SWITCH_MACHINE=
+
+test "$CANNOT_DUMP" = yes ||
case $canonical in
alpha*)
AC_CHECK_DECL([__ELF__])
@@ -4064,6 +4136,9 @@ dnl No need to check for posix_memalign if aligned_alloc
works.
AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break])
AC_CHECK_DECLS([aligned_alloc], [], [], [[#include <stdlib.h>]])
+# Dump loading
+AC_CHECK_FUNCS([posix_madvise])
+
dnl Cannot use AC_CHECK_FUNCS
AC_CACHE_CHECK([for __builtin_frame_address],
[emacs_cv_func___builtin_frame_address],
@@ -5540,6 +5615,9 @@ AS_ECHO([" Does Emacs use -lXaw3d?
${HAVE_XAW3D
Does Emacs use toolkit scroll bars?
${USE_TOOLKIT_SCROLL_BARS}
Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS}
Does Emacs have threading support in lisp? ${threads_enabled}
+ Does Emacs support the portable dumper? ${with_pdumper}
+ Does Emacs support legacy unexec dumping? ${with_unexec}
+ Which dumping strategy does Emacs use? ${with_dumping}
"])
if test -n "${EMACSDATA}"; then
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index 9c74d8e..387a6e3 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -167,7 +167,7 @@ UTILITIES = profile${EXEEXT} hexl${EXEEXT} \
$(if $(with_mailutils), , movemail${EXEEXT}) \
$(and $(use_gamedir), update-game-score${EXEEXT})
-DONT_INSTALL= make-docfile${EXEEXT}
+DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT}
# Like UTILITIES, but they're not system-dependent, and should not be
# deleted by the distclean target.
@@ -385,6 +385,9 @@ profile${EXEEXT}: ${srcdir}/profile.c $(NTLIB) $(config_h)
make-docfile${EXEEXT}: ${srcdir}/make-docfile.c $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@
+make-fingerprint${EXEEXT}: ${srcdir}/make-fingerprint.c $(NTLIB) $(config_h)
+ $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@
+
movemail${EXEEXT}: ${srcdir}/movemail.c pop.o $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} ${MOVE_FLAGS} $< pop.o \
$(NTLIB) $(LOADLIBES) $(LIBS_MOVE) -o $@
diff --git a/lib-src/make-fingerprint.c b/lib-src/make-fingerprint.c
new file mode 100644
index 0000000..69558a8
--- /dev/null
+++ b/lib-src/make-fingerprint.c
@@ -0,0 +1,113 @@
+/* Hash inputs and generate C file with the digest.
+
+Copyright (C) 1985-1986, 1992-1994, 1997, 1999-2016 Free Software
+Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+
+/* The arguments given to this program are all the object files that
+ go into building GNU Emacs. There is no special search logic to find
+ the files. */
+
+#include <config.h>
+
+#include <stdarg.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sysstdio.h>
+#include <sha256.h>
+#include <getopt.h>
+
+#ifdef WINDOWSNT
+/* Defined to be sys_fopen in ms-w32.h, but only #ifdef emacs, so this
+ is really just insurance. */
+#undef fopen
+#include <direct.h>
+#endif /* WINDOWSNT */
+
+int
+main (int argc, char **argv)
+{
+ int c;
+ bool raw = false;
+ while (0 <= (c = getopt (argc, argv, "rh")))
+ {
+ switch (c)
+ {
+ case 'r':
+ raw = true;
+ break;
+ case 'h':
+ printf ("make-fingerprint [-r] FILES...: compute a hash\n");
+ return 0;
+ default:
+ return 1;
+ }
+ }
+
+ struct sha256_ctx ctx;
+ sha256_init_ctx (&ctx);
+
+ for (int i = optind; i < argc; ++i)
+ {
+ FILE *f = fopen (argv[i], "r" FOPEN_BINARY);
+ if (!f)
+ {
+ fprintf (stderr, "%s: Error: could not open %s\n",
+ argv[0], argv[i]);
+ return 1;
+ }
+
+ char buf[128*1024];
+ do
+ {
+ size_t chunksz = fread (buf, 1, sizeof (buf), f);
+ if (ferror (f))
+ {
+ fprintf (stderr, "%s: Error: could not read %s\n",
+ argv[0], argv[i]);
+ return 1;
+ }
+ sha256_process_bytes (buf, chunksz, &ctx);
+ } while (!feof (f));
+ fclose (f);
+ }
+
+ uint8_t digest[32];
+ sha256_finish_ctx (&ctx, digest);
+
+ if (raw)
+ {
+ for (int i = 0; i < 32; ++i)
+ printf ("%02X", digest[i]);
+ }
+ else
+ {
+ printf ("#include \"fingerprint.h\"\n");
+ printf ("\n");
+ printf ("const uint8_t fingerprint[32] = { ");
+ for (int i = 0; i < 32; ++i)
+ printf ("%s0x%02X", i ? ", " : "", digest[i]);
+ printf (" };\n");
+ }
+
+ return EXIT_SUCCESS;
+}
+
+/* make-fingerprint.c ends here */
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 90ea7ed..44ce292 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -730,7 +730,7 @@ since it could result in memory overflow and make Emacs
crash."
;; If this is NOT while dumping Emacs, set up the rest of the
;; customization info. This is the stuff that is not needed
;; until someone does M-x customize etc.
- (unless purify-flag
+ (unless dump-mode
;; Add it to the right group(s).
(if (listp group)
(dolist (g group)
@@ -752,7 +752,7 @@ since it could result in memory overflow and make Emacs
crash."
;; Record cus-start as loaded if we have set up all the info that we can.
;; Don't record it as loaded if we have only set up the standard values
;; and safe/risky properties.
-(unless purify-flag
+(unless dump-mode
(provide 'cus-start))
;;; cus-start.el ends here
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index b127356..40e9ba1 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -63,6 +63,7 @@
;; FIXME: Now that macroexpansion is also performed when loading an interpreted
;; file, this is not a real problem any more.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
+;; (defconst pcase--memoize (make-hash-table :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
diff --git a/lisp/files.el b/lisp/files.el
index 6ccb001..9948bd4 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1009,7 +1009,7 @@ directory if it does not exist."
;; Make sure `user-emacs-directory' exists,
;; unless we're in batch mode or dumping Emacs.
(or noninteractive
- purify-flag
+ dump-mode
(let (errtype)
(if (file-directory-p user-emacs-directory)
(or (file-accessible-directory-p user-emacs-directory)
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index cdd8ba7..b07f984 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1334,7 +1334,7 @@ Setup char-width-table appropriate for non-CJK language
environment."
;; Setting char-script-table.
-(if purify-flag
+(if dump-mode
;; While dumping, we can't use require, and international is not
;; in load-path.
(load "international/charscript")
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 1c7f6fa..023fcbc 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -343,7 +343,7 @@ Return t if file exists."
;; Have the original buffer current while we eval.
(eval-buffer buffer nil
;; This is compatible with what `load' does.
- (if purify-flag file fullname)
+ (if dump-mode file fullname)
nil t))
(let (kill-buffer-hook kill-buffer-query-functions)
(kill-buffer buffer)))
diff --git a/lisp/loadup.el b/lisp/loadup.el
index f419f0b..0f0ca15 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -26,6 +26,9 @@
;; This is loaded into a bare Emacs to make a dumpable one.
+;; Emacs injects the variable `dump-mode' to tell us how to dump.
+;; We unintern it before allowing user code to run.
+
;; If you add a file to be loaded here, keep the following points in mind:
;; i) If the file is no-byte-compile, explicitly load the .el version.
@@ -54,33 +57,58 @@
;; bidi.c needs for its job.
(setq redisplay--inhibit-bidi t)
+(message "dump mode: %s" dump-mode)
+
;; Add subdirectories to the load-path for files that might get
-;; autoloaded when bootstrapping.
+;; autoloaded when bootstrapping or running Emacs normally.
;; This is because PATH_DUMPLOADSEARCH is just "../lisp".
-(if (or (equal (member "bootstrap" command-line-args) '("bootstrap"))
+(if (or (member dump-mode '("bootstrap" "pbootstrap"))
;; FIXME this is irritatingly fragile.
- (and (stringp (nth 4 command-line-args))
- (string-match "^unidata-gen\\(\\.elc?\\)?$"
- (nth 4 command-line-args)))
- (member (nth 7 command-line-args) '("unidata-gen-file"
- "unidata-gen-charprop"))
- (if (fboundp 'dump-emacs)
- (string-match "src/bootstrap-emacs" (nth 0 command-line-args))
- t))
- (let ((dir (car load-path)))
+ (and (stringp (nth 4 command-line-args))
+ (string-match "^unidata-gen\\(\\.elc?\\)?$"
+ (nth 4 command-line-args)))
+ (member (nth 7 command-line-args) '("unidata-gen-file"
+ "unidata-gen-charprop"))
+ (null dump-mode))
+ (progn
+ ;; Find the entry in load-path that contains Emacs elisp and
+ ;; splice some additional directories in there for the benefit
+ ;; of autoload and regular Emacs use.
+ (let ((subdirs '("emacs-lisp"
+ "progmodes"
+ "language"
+ "international"
+ "textmodes"
+ "vc"))
+ (iter load-path))
+ (while iter
+ (let ((dir (car iter))
+ (subdirs subdirs)
+ esubdirs esubdir)
+ (while subdirs
+ (setq esubdir (expand-file-name (car subdirs) dir))
+ (setq subdirs (cdr subdirs))
+ (if (file-directory-p esubdir)
+ (setq esubdirs (cons esubdir esubdirs))
+ (setq subdirs nil esubdirs nil)))
+ (if esubdirs
+ (progn
+ (setcdr iter (nconc (nreverse esubdirs) (cdr iter)))
+ (setq iter nil))
+ (setq iter (cdr iter))
+ (if (null iter)
+ (signal
+ 'error (list
+ (format-message
+ "Could not find elisp load-path: searched %S"
+ load-path))))))))
;; We'll probably overflow the pure space.
(setq purify-flag nil)
;; Value of max-lisp-eval-depth when compiling initially.
- ;; During bootstrapping the byte-compiler is run interpreted when
- ;; compiling itself, which uses a lot more stack than usual.
- (setq max-lisp-eval-depth 2200)
- (setq load-path (list (expand-file-name "." dir)
- (expand-file-name "emacs-lisp" dir)
- (expand-file-name "progmodes" dir)
- (expand-file-name "language" dir)
- (expand-file-name "international" dir)
- (expand-file-name "textmodes" dir)
- (expand-file-name "vc" dir)))))
+ ;; During bootstrapping the byte-compiler is run interpreted
+ ;; when compiling itself, which uses a lot more stack
+ ;; than usual.
+ (setq max-lisp-eval-depth 2200)))
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
@@ -88,10 +116,7 @@
(message "Using load-path %s" load-path)
-;; This is a poor man's `last', since we haven't loaded subr.el yet.
-(if (and (fboundp 'dump-emacs)
- (or (equal (member "bootstrap" command-line-args) '("bootstrap"))
- (equal (member "dump" command-line-args) '("dump"))))
+(if dump-mode
(progn
;; To reduce the size of dumped Emacs, we avoid making huge char-tables.
(setq inhibit-load-charset-map t)
@@ -350,15 +375,16 @@ lost after dumping")))
;; file primitive. So the only workable solution to support building
;; in non-ASCII directories is to manipulate unibyte strings in the
;; current locale's encoding.
-(if (and (member (car (last command-line-args)) '("dump" "bootstrap"))
- (fboundp 'dump-emacs)
- (multibyte-string-p default-directory))
+(if (and dump-mode (multibyte-string-p default-directory))
(error "default-directory must be unibyte when dumping Emacs!"))
;; Determine which build number to use
;; based on the executables that now exist.
-(if (and (equal (last command-line-args) '("dump"))
- (fboundp 'dump-emacs)
+(if (and (or
+ (and (equal dump-mode "dump")
+ (fboundp 'dump-emacs))
+ (and (equal dump-mode "pdump")
+ (fboundp 'dump-emacs-portable)))
(not (eq system-type 'ms-dos)))
(let* ((base (concat "emacs-" emacs-version "."))
(exelen (if (eq system-type 'windows-nt) -4))
@@ -376,8 +402,10 @@ lost after dumping")))
(message "Finding pointers to doc strings...")
-(if (and (fboundp 'dump-emacs)
- (equal (last command-line-args) '("dump")))
+(if (and (or (and (fboundp 'dump-emacs)
+ (equal dump-mode "dump"))
+ (and (fboundp 'dump-emacs-portable)
+ (equal dump-mode "pdump"))))
(Snarf-documentation "DOC")
(condition-case nil
(Snarf-documentation "DOC")
@@ -446,43 +474,55 @@ 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.
+ (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
;; building bootstrap-emacs.
- (equal (last command-line-args) '("bootstrap"))))
- (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
- (exe (if (eq system-type 'windows-nt) ".exe" "")))
- (while (string-match "[^-+_.a-zA-Z0-9]+" name)
- (setq name (concat (downcase (substring name 0 (match-beginning
0)))
- "-"
- (substring name (match-end 0)))))
- (setq name (concat name exe))
- (message "Adding name %s" name)
- ;; When this runs on Windows, invocation-directory is not
- ;; necessarily the current directory.
- (add-name-to-file (expand-file-name (concat "emacs" exe)
- invocation-directory)
- (expand-file-name name invocation-directory)
- t)))
+ (member dump-mode '("pbootstrap" "bootstrap"))))
+ (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
+ (exe (if (eq system-type 'windows-nt) ".exe" "")))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning
0)))
+ "-"
+ (substring name (match-end 0)))))
+ (message "Adding name %s" (concat name exe))
+ ;; When this runs on Windows, invocation-directory is not
+ ;; necessarily the current directory.
+ (add-name-to-file (expand-file-name (concat "emacs" exe)
+ invocation-directory)
+ (expand-file-name (concat name exe)
+ invocation-directory)
+ t)
+ (when (equal dump-mode "pdump")
+ (message "Adding name %s" (concat name ".pdmp"))
+ (add-name-to-file (expand-file-name "emacs.pdmp"
+ invocation-directory)
+ (expand-file-name (concat name ".pdmp")
+ invocation-directory)
+ t))))
(kill-emacs)))
;; For machines with CANNOT_DUMP defined in config.h,
diff --git a/lisp/startup.el b/lisp/startup.el
index 1011d5f..f2410f6 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1056,7 +1056,8 @@ please check its value")
(let* ((longopts '(("--no-init-file") ("--no-site-file")
("--no-x-resources") ("--debug-init")
("--user") ("--iconic") ("--icon-type") ("--quick")
- ("--no-blinking-cursor") ("--basic-display")))
+ ("--no-blinking-cursor") ("--basic-display")
+ ("--dump-file") ("--temacs")))
(argi (pop args))
(orig-argi argi)
argval)
@@ -1108,6 +1109,9 @@ please check its value")
(push '(visibility . icon) initial-frame-alist))
((member argi '("-nbc" "-no-blinking-cursor"))
(setq no-blinking-cursor t))
+ ((member argi '("-dump-file" "-temacs")) ; Handled in C
+ (or argval (pop args))
+ (setq argval nil))
;; Push the popped arg back on the list of arguments.
(t
(push argi args)
diff --git a/nextstep/Makefile.in b/nextstep/Makefile.in
index a1966f0..ea64af6 100644
--- a/nextstep/Makefile.in
+++ b/nextstep/Makefile.in
@@ -44,7 +44,7 @@ ns_check_file = @ns_appdir@/@ns_check_file@
.PHONY: all
-all: ${ns_appdir} ${ns_appbindir}/Emacs
+all: ${ns_appdir} ${ns_appbindir}/Emacs ${ns_appbindir}/emacs.pdmp
${ns_check_file} ${ns_appdir}: ${srcdir}/${ns_appsrc} ${ns_appsrc}
rm -rf ${ns_appdir}
@@ -63,6 +63,10 @@ ${ns_appbindir}/Emacs: ${ns_appdir} ${ns_check_file}
../src/emacs${EXEEXT}
${MKDIR_P} ${ns_appbindir}
cp -f ../src/emacs${EXEEXT} $@
+${ns_appbindir}/emacs.pdmp: ${ns_appdir} ${ns_check_file}
../src/emacs${EXEEXT}.pdmp
+ ${MKDIR_P} ${ns_appbindir}
+ cp -f ../src/emacs${EXEEXT}.pdmp $@
+
.PHONY: FORCE
../src/emacs${EXEEXT}: FORCE
diff --git a/src/Makefile.in b/src/Makefile.in
index f409ed4..980bd6d 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -54,8 +54,6 @@ lwlibdir = ../lwlib
# Configuration files for .o files to depend on.
config_h = config.h $(srcdir)/conf_post.h
-bootstrap_exe = ../src/bootstrap-emacs$(EXEEXT)
-
## ns-app if HAVE_NS, else empty.
OTHER_FILES = @OTHER_FILES@
@@ -332,7 +330,7 @@ BUILD_DETAILS = @BUILD_DETAILS@
UNEXEC_OBJ = @UNEXEC_OBJ@
address@hidden@
address@hidden@
# 'make' verbosity.
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
@@ -357,6 +355,15 @@ am__v_at_ = $(address@hidden@)
am__v_at_0 = @
am__v_at_1 =
+bootstrap_exe = ../src/bootstrap-emacs$(EXEEXT)
+ifeq ($(DUMPING),pdumper)
+bootstrap_pdmp := bootstrap-emacs.pdmp # Keep in sync with loadup.el
+pdmp := emacs.pdmp
+else
+bootstrap_pdmp :=
+pdmp :=
+endif
+
# Flags that might be in WARN_CFLAGS but are not valid for Objective C.
NON_OBJC_CFLAGS = -Wignored-attributes -Wignored-qualifiers -Wopenmp-simd
@@ -395,7 +402,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o
$(XMENU_OBJ) window.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-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 \
@@ -446,9 +453,17 @@ address@hidden@
ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj)
# Must be first, before dep inclusion!
-all: emacs$(EXEEXT) $(OTHER_FILES)
+all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES)
.PHONY: all
+dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \
+ $(srcdir)/intervals.h $(srcdir)/charset.h $(srcdir)/bignum.h
+pdumper.o: dmpstruct.h
+dmpstruct.h: $(srcdir)/dmpstruct.awk
+dmpstruct.h: $(libsrc)/make-fingerprint$(EXEEXT) $(dmpstruct_headers)
+ POSIXLY_CORRECT=1 awk -f $(srcdir)/dmpstruct.awk \
+ $(dmpstruct_headers) > $@
+
AUTO_DEPEND = @AUTO_DEPEND@
DEPDIR = deps
ifeq ($(AUTO_DEPEND),yes)
@@ -511,7 +526,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE)
$(LIBIMAGE) \
## and emacs (which recreates bootstrap-emacs) depends on charprop,
## in practice this rule was always run anyway.
$(srcdir)/macuvs.h $(lispsource)/international/charprop.el: \
- bootstrap-emacs$(EXEEXT) FORCE
+ bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) FORCE
$(MAKE) -C ../admin/unidata all EMACS="../$(bootstrap_exe)"
## We require charprop.el to exist before ucs-normalize.el is
@@ -542,14 +557,20 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc}
emacs$(EXEEXT): temacs$(EXEEXT) \
lisp.mk $(etc)/DOC $(lisp) \
$(lispsource)/international/charprop.el ${charsets}
-ifeq ($(CANNOT_DUMP),yes)
- ln -f temacs$(EXEEXT) $@
-else
- LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup dump
+ifeq ($(DUMPING),unexec)
+ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump
ifneq ($(PAXCTL_dumped),)
- $(PAXCTL_dumped) $@
+ $(PAXCTL_dumped) emacs$(EXEEXT)
endif
- ln -f $@ bootstrap-emacs$(EXEEXT)
+ cp -f $@ bootstrap-emacs$(EXEEXT)
+else
+ cp -f temacs$(EXEEXT) emacs$(EXEEXT)
+endif
+
+ifeq ($(DUMPING),pdumper)
+$(pdmp): emacs$(EXEEXT)
+ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump
+ cp -f $@ $(bootstrap_pdmp)
endif
## We run make-docfile twice because the command line may get too long
@@ -602,16 +623,30 @@ LIBEGNU_ARCHIVE = $(lib)/lib$(if $(HYBRID_MALLOC),e)gnu.a
$(LIBEGNU_ARCHIVE): $(config_h)
$(MAKE) -C $(lib) all
+EMACS_DEPS_PRE=$(LIBXMENU) $(ALLOBJS)
+EMACS_DEPS_POST=$(LIBEGNU_ARCHIVE) $(EMACSRES) ${charsets} ${charscript}
+BUILD_EMACS_PRE=$(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
+ -o $@ $(ALLOBJS)
+BUILD_EMACS_POST=$(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES)
+
+## We hash this file to generate the build fingerprint
+temacs.in$(EXEEXT): $(EMACS_DEPS_PRE) fingerprint-dummy.o $(EMACS_DEPS_POST)
+ $(BUILD_EMACS_PRE) fingerprint-dummy.o $(BUILD_EMACS_POST)
+
+$(libsrc)/make-fingerprint$(EXEEXT): $(libsrc)/make-fingerprint.c
$(lib)/libgnu.a
+ $(MAKE) -C $(libsrc) make-fingerprint$(EXEEXT)
+
+fingerprint.c: temacs.in$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT)
+ $(libsrc)/make-fingerprint$(EXEEXT) temacs.in$(EXEEXT) > fingerprint.c
+
## We have to create $(etc) here because init_cmdargs tests its
## existence when setting Vinstallation_directory (FIXME?).
## This goes on to affect various things, and the emacs binary fails
## to start if Vinstallation_directory has the wrong value.
-temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) \
- $(LIBEGNU_ARCHIVE) $(EMACSRES) ${charsets} ${charscript}
- $(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \
- -o temacs $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES)
+temacs$(EXEEXT): $(EMACS_DEPS_PRE) fingerprint.o $(EMACS_DEPS_POST)
+ $(BUILD_EMACS_PRE) fingerprint.o $(BUILD_EMACS_POST)
$(MKDIR_P) $(etc)
-ifneq ($(CANNOT_DUMP),yes)
+ifeq ($(DUMPING),unexec)
ifneq ($(PAXCTL_notdumped),)
$(PAXCTL_notdumped) $@
endif
@@ -638,7 +673,7 @@ emacs.res: FORCE
$(MAKE) -C ../nt ../src/emacs.res
.PHONY: ns-app
-ns-app: emacs$(EXEEXT)
+ns-app: emacs$(EXEEXT) $(pdmp)
$(MAKE) -C ../nextstep all
.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean
@@ -646,8 +681,11 @@ ns-app: emacs$(EXEEXT)
mostlyclean:
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
@@ -732,7 +770,7 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS
## but now that we require GNU make, we can simply specify
## bootstrap-emacs$(EXEEXT) as an order-only prerequisite.
-%.elc: %.el | bootstrap-emacs$(EXEEXT)
+%.elc: %.el | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
@$(MAKE) -C ../lisp EMACS="$(bootstrap_exe)" THEFILE=$< $<c
## VCSWITNESS points to the file that holds info about the current checkout.
@@ -740,24 +778,35 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS
## If empty it is ignored; the parent makefile can set it to some other value.
VCSWITNESS =
-$(lispsource)/loaddefs.el: $(VCSWITNESS) | bootstrap-emacs$(EXEEXT)
+$(lispsource)/loaddefs.el: $(VCSWITNESS) | \
+ bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../lisp autoloads EMACS="$(bootstrap_exe)"
## Dump an Emacs executable named bootstrap-emacs containing the
## files from loadup.el in source form.
+
bootstrap-emacs$(EXEEXT): temacs$(EXEEXT)
$(MAKE) -C ../lisp update-subdirs
-ifeq ($(CANNOT_DUMP),yes)
- ln -f temacs$(EXEEXT) $@
-else
- $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap
+ifeq ($(DUMPING),unexec)
+ $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=bootstrap
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:
diff --git a/src/alloc.c b/src/alloc.c
index 31e8da7..8054aa5 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -44,6 +44,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
+#include "pdumper.h"
#include "termhooks.h" /* For struct terminal. */
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -65,16 +66,13 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
# include <malloc.h>
#endif
-#if (defined ENABLE_CHECKING \
- && defined HAVE_VALGRIND_VALGRIND_H \
- && !defined USE_VALGRIND)
+#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND
# define USE_VALGRIND 1
#endif
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
-static bool valgrind_p;
#endif
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
@@ -194,9 +192,6 @@ alloc_unexec_pre (void)
if (!malloc_state_ptr)
fatal ("malloc_get_state: %s", strerror (errno));
# endif
-# ifdef HYBRID_MALLOC
- bss_sbrk_did_unexec = true;
-# endif
}
void
@@ -205,22 +200,19 @@ alloc_unexec_post (void)
# ifdef DOUG_LEA_MALLOC
free (malloc_state_ptr);
# endif
-# ifdef HYBRID_MALLOC
- bss_sbrk_did_unexec = false;
-# endif
}
#endif
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
-#define MARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
-#define UNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
-#define STRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
+#define XMARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
+#define XUNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
+#define XSTRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
-#define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
-#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
-#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
+#define XMARK_VECTOR(V) ((V)->header.size |= ARRAY_MARK_FLAG)
+#define XUNMARK_VECTOR(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
+#define XVECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
/* Default value of gc_cons_threshold (see below). */
@@ -242,6 +234,12 @@ byte_ct gc_relative_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;
@@ -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 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. */
@@ -400,7 +419,10 @@ enum mem_type
/* A unique object in pure space used to make some Lisp objects
on free lists recognizable in O(1). */
-static Lisp_Object Vdead;
+#ifndef ENABLE_CHECKING
+static
+#endif
+Lisp_Object Vdead;
#define DEADP(x) EQ (x, Vdead)
#ifdef GC_MALLOC_CHECK
@@ -478,30 +500,21 @@ static struct mem_node *mem_find (void *);
#endif
/* Addresses of staticpro'd variables. Initialize it to a nonzero
- value; otherwise some compilers put it into BSS. */
+ value if we might dump; otherwise some compilers put it into
+ BSS. */
-enum { NSTATICS = 2048 };
-static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
+Lisp_Object *staticvec[NSTATICS]
+#ifndef CANNOT_DUMP
+= {&Vpurify_flag}
+#endif
+ ;
/* Index of next unused slot in staticvec. */
-static int staticidx;
+int staticidx;
static void *pure_alloc (size_t, int);
-/* True if N is a power of 2. N should be positive. */
-
-#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
-
-/* Return X rounded to the next multiple of Y. Y should be positive,
- and Y - 1 + X should not overflow. Arguments should not have side
- effects, as they are evaluated more than once. Tune for Y being a
- power of 2. */
-
-#define ROUNDUP(x, y) (POWER_OF_2 (y) \
- ? ((y) - 1 + (x)) & ~ ((y) - 1) \
- : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
-
/* Return PTR rounded up to the next multiple of ALIGNMENT. */
static void *
@@ -571,18 +584,18 @@ mmap_lisp_allowed_p (void)
over our address space. We also can't use mmap for lisp objects
if we might dump: unexec doesn't preserve the contents of mmapped
regions. */
- return pointers_fit_in_lispobj_p () && !might_dump;
+ return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p ();
}
#endif
/* Head of a circularly-linked list of extant finalizers. */
-static struct Lisp_Finalizer finalizers;
+struct Lisp_Finalizer finalizers;
/* Head of a circularly-linked list of finalizers that must be invoked
because we deemed them unreachable. This list must be global, and
not a local inside garbage_collect_1, in case we GC again while
running finalizers. */
-static struct Lisp_Finalizer doomed_finalizers;
+struct Lisp_Finalizer doomed_finalizers;
/************************************************************************
@@ -931,6 +944,8 @@ xfree (void *block)
{
if (!block)
return;
+ if (pdumper_object_p (block))
+ return;
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
@@ -1153,6 +1168,9 @@ lisp_malloc (size_t nbytes, enum mem_type type)
static void
lisp_free (void *block)
{
+ if (pdumper_object_p (block))
+ return;
+
MALLOC_BLOCK_INPUT;
free (block);
#ifndef GC_MALLOC_CHECK
@@ -1569,22 +1587,23 @@ make_interval (void)
/* Mark Lisp objects in interval I. */
static void
-mark_interval (INTERVAL i, void *dummy)
+mark_interval_tree_1 (INTERVAL i, void *dummy)
{
/* Intervals should never be shared. So, if extra internal checking is
enabled, GC aborts if it seems to have visited an interval twice. */
- eassert (!i->gcmarkbit);
- i->gcmarkbit = 1;
+ eassert (!interval_marked_p (i));
+ set_interval_marked (i);
mark_object (i->plist);
}
/* Mark the interval tree rooted in I. */
-#define MARK_INTERVAL_TREE(i) \
- do { \
- if (i && !i->gcmarkbit) \
- traverse_intervals_noorder (i, mark_interval, NULL); \
- } while (0)
+static void
+mark_interval_tree (INTERVAL i)
+{
+ if (i && !interval_marked_p (i))
+ traverse_intervals_noorder (i, mark_interval_tree_1, NULL);
+}
/***********************************************************************
String Allocation
@@ -1820,7 +1839,9 @@ static void
init_strings (void)
{
empty_unibyte_string = make_pure_string ("", 0, 0, 0);
+ staticpro (&empty_unibyte_string);
empty_multibyte_string = make_pure_string ("", 0, 0, 1);
+ staticpro (&empty_multibyte_string);
}
@@ -2114,10 +2135,10 @@ sweep_strings (void)
if (s->u.s.data)
{
/* String was not on free-list before. */
- if (STRING_MARKED_P (s))
+ if (XSTRING_MARKED_P (s))
{
/* String is live; unmark it and its intervals. */
- UNMARK_STRING (s);
+ XUNMARK_STRING (s);
/* Do not use string_(set|get)_intervals here. */
s->u.s.intervals = balance_intervals (s->u.s.intervals);
@@ -2619,7 +2640,8 @@ make_formatted_string (char *buf, const char *format, ...)
&= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
#define FLOAT_BLOCK(fptr) \
- ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
+ (eassert (!pdumper_object_p (fptr)), \
+ ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1))))
#define FLOAT_INDEX(fptr) \
((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
@@ -2632,13 +2654,13 @@ struct float_block
struct float_block *next;
};
-#define FLOAT_MARKED_P(fptr) \
+#define XFLOAT_MARKED_P(fptr) \
GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
-#define FLOAT_MARK(fptr) \
+#define XFLOAT_MARK(fptr) \
SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
-#define FLOAT_UNMARK(fptr) \
+#define XFLOAT_UNMARK(fptr) \
UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
/* Current float_block. */
@@ -2686,7 +2708,7 @@ make_float (double float_value)
MALLOC_UNBLOCK_INPUT;
XFLOAT_INIT (val, float_value);
- eassert (!FLOAT_MARKED_P (XFLOAT (val)));
+ eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
total_free_floats--;
@@ -2711,7 +2733,8 @@ make_float (double float_value)
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
- ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
+ (eassert (!pdumper_object_p (fptr)), \
+ ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1))))
#define CONS_INDEX(fptr) \
(((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
@@ -2724,13 +2747,13 @@ struct cons_block
struct cons_block *next;
};
-#define CONS_MARKED_P(fptr) \
+#define XCONS_MARKED_P(fptr) \
GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
-#define CONS_MARK(fptr) \
+#define XMARK_CONS(fptr) \
SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
-#define CONS_UNMARK(fptr) \
+#define XUNMARK_CONS(fptr) \
UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
/* Current cons_block. */
@@ -2803,7 +2826,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
XSETCAR (val, car);
XSETCDR (val, cdr);
- eassert (!CONS_MARKED_P (XCONS (val)));
+ eassert (!XCONS_MARKED_P (XCONS (val)));
consing_since_gc += sizeof (struct Lisp_Cons);
total_free_conses--;
cons_cells_consed++;
@@ -3103,6 +3126,7 @@ static void
init_vectors (void)
{
zero_vector = make_pure_vector (0);
+ staticpro (&zero_vector);
}
/* Allocate vector from a vector block. */
@@ -3173,17 +3197,17 @@ allocate_vector_from_block (ptrdiff_t nbytes)
/* Return the memory footprint of V in bytes. */
-static ptrdiff_t
-vector_nbytes (struct Lisp_Vector *v)
+ptrdiff_t
+vectorlike_nbytes (const union vectorlike_header *hdr)
{
- ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
+ ptrdiff_t size = hdr->size & ~ARRAY_MARK_FLAG;
ptrdiff_t nwords;
if (size & PSEUDOVECTOR_FLAG)
{
- if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
+ if (PSEUDOVECTOR_TYPEP (hdr, PVEC_BOOL_VECTOR))
{
- struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
+ struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) hdr;
ptrdiff_t word_bytes = (bool_vector_words (bv->size)
* sizeof (bits_word));
ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
@@ -3281,9 +3305,9 @@ 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++;
ptrdiff_t nbytes = vector_nbytes (vector);
total_vector_slots += nbytes / word_size;
@@ -3304,7 +3328,7 @@ sweep_vectors (void)
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);
@@ -3335,9 +3359,9 @@ sweep_vectors (void)
for (lv = large_vectors; lv; lv = *lvprev)
{
vector = large_vector_vec (lv);
- if (VECTOR_MARKED_P (vector))
+ if (XVECTOR_MARKED_P (vector))
{
- VECTOR_UNMARK (vector);
+ XUNMARK_VECTOR (vector);
total_vectors++;
if (vector->header.size & PSEUDOVECTOR_FLAG)
total_vector_slots += vector_nbytes (vector) / word_size;
@@ -3847,7 +3871,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head)
finalizer != head;
finalizer = finalizer->next)
{
- VECTOR_MARK (finalizer);
+ set_vectorlike_marked (&finalizer->header);
mark_object (finalizer->function);
}
}
@@ -3864,7 +3888,8 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest,
while (finalizer != src)
{
struct Lisp_Finalizer *next = finalizer->next;
- if (!VECTOR_MARKED_P (finalizer) && !NILP (finalizer->function))
+ if (!vectorlike_marked_p (&finalizer->header)
+ && !NILP (finalizer->function))
{
unchain_finalizer (finalizer);
finalizer_insert (dest, finalizer);
@@ -3885,6 +3910,9 @@ static void
run_finalizer_function (Lisp_Object function)
{
ptrdiff_t count = SPECPDL_INDEX ();
+#ifdef HAVE_PDUMPER
+ ++number_finalizers_run;
+#endif
specbind (Qinhibit_quit, Qt);
internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
@@ -3929,6 +3957,126 @@ FUNCTION. FUNCTION will be run once per finalizer
object. */)
/************************************************************************
+ 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
+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
************************************************************************/
@@ -4626,14 +4774,29 @@ static void
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 (FIXNUMP (obj))
return;
void *po = XPNTR (obj);
+
+ /* If the pointer is in the dumped image and the dump has a record
+ of the object starting at the place where the pointer points, we
+ definitely have an object. If the pointer is in the dumped image
+ and the dump has no idea what the pointer is pointing at, we
+ definitely _don't_ have an object. */
+ if (pdumper_object_p (po))
+ {
+ /* Don't use pdumper_object_p_precise here! It doesn't check the
+ tag bits. OBJ here might be complete garbage, so we need to
+ verify both the pointer and the tag. */
+ if (XTYPE (obj) == pdumper_find_object_type (po))
+ mark_object (obj);
+ return;
+ }
+
struct mem_node *m = mem_find (po);
if (m != MEM_NIL)
@@ -4703,9 +4866,8 @@ mark_maybe_pointer (void *p)
{
struct mem_node *m;
-#if USE_VALGRIND
- if (valgrind_p)
- VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
+#ifdef USE_VALGRIND
+ VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
if (sizeof (Lisp_Object) == sizeof (void *) || !HAVE_MODULES)
@@ -4720,6 +4882,17 @@ mark_maybe_pointer (void *p)
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)
{
@@ -5076,6 +5249,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.
@@ -5115,6 +5294,9 @@ valid_lisp_object_p (Lisp_Object obj)
if (p == &buffer_defaults || p == &buffer_local_symbols)
return 2;
+ if (pdumper_object_p (p))
+ return pdumper_object_p_precise (p) ? 1 : 0;
+
struct mem_node *m = mem_find (p);
if (m == MEM_NIL)
@@ -5324,7 +5506,7 @@ make_pure_c_string (const char *data, ptrdiff_t nchars)
Lisp_Object string;
struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
s->u.s.size = nchars;
- s->u.s.size_byte = -1;
+ s->u.s.size_byte = -2;
s->u.s.data = (unsigned char *) data;
s->u.s.intervals = NULL;
XSETSTRING (string, s);
@@ -5617,7 +5799,7 @@ compact_font_cache_entry (Lisp_Object entry)
/* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
- && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj)))
+ && !vectorlike_marked_p (&GC_XFONT_SPEC (XCAR (obj))->header)
/* Don't use VECTORP here, as that calls ASIZE, which could
hit assertion violation during GC. */
&& (VECTORLIKEP (XCDR (obj))
@@ -5633,7 +5815,8 @@ compact_font_cache_entry (Lisp_Object entry)
{
Lisp_Object objlist;
- if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr, i))))
+ if (vectorlike_marked_p (
+ &GC_XFONT_ENTITY (AREF (obj_cdr, i))->header))
break;
objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
@@ -5643,7 +5826,7 @@ compact_font_cache_entry (Lisp_Object entry)
struct font *font = GC_XFONT_OBJECT (val);
if (!NILP (AREF (val, FONT_TYPE_INDEX))
- && VECTOR_MARKED_P(font))
+ && vectorlike_marked_p(&font->header))
break;
}
if (CONSP (objlist))
@@ -5712,7 +5895,7 @@ compact_undo_list (Lisp_Object list)
{
if (CONSP (XCAR (tail))
&& MARKERP (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);
@@ -5745,6 +5928,105 @@ mark_pinned_symbols (void)
}
}
+static void
+visit_vectorlike_root (struct gc_root_visitor visitor,
+ struct Lisp_Vector *ptr,
+ enum gc_root_type type)
+{
+ ptrdiff_t size = ptr->header.size;
+ ptrdiff_t i;
+
+ if (size & PSEUDOVECTOR_FLAG)
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ for (i = 0; i < size; i++)
+ visitor.visit (&ptr->contents[i], type, visitor.data);
+}
+
+static void
+visit_buffer_root (struct gc_root_visitor visitor,
+ struct buffer *buffer,
+ enum gc_root_type type)
+{
+ /* Buffers that are roots don't have intervals, an undo list, or
+ other constructs that real buffers have. */
+ eassert (buffer->base_buffer == NULL);
+ eassert (buffer->overlays_before == NULL);
+ eassert (buffer->overlays_after == NULL);
+
+ /* Visit the buffer-locals. */
+ visit_vectorlike_root (visitor, (struct Lisp_Vector *) buffer, type);
+}
+
+/* Visit GC roots stored in the Emacs data section. Used by both core
+ GC and by the portable dumping code.
+
+ There are other GC roots of course, but these roots are dynamic
+ runtime data structures that pdump doesn't care about and so we can
+ continue to mark those directly in garbage_collect_1. */
+void
+visit_static_gc_roots (struct gc_root_visitor visitor)
+{
+ visit_buffer_root (visitor,
+ &buffer_defaults,
+ GC_ROOT_BUFFER_LOCAL_DEFAULT);
+ visit_buffer_root (visitor,
+ &buffer_local_symbols,
+ GC_ROOT_BUFFER_LOCAL_NAME);
+
+ for (int i = 0; i < ARRAYELTS (lispsym); i++)
+ {
+ Lisp_Object sptr = builtin_lisp_symbol (i);
+ visitor.visit (&sptr, GC_ROOT_C_SYMBOL, visitor.data);
+ }
+
+ for (int i = 0; i < staticidx; i++)
+ visitor.visit (staticvec[i], GC_ROOT_STATICPRO, visitor.data);
+}
+
+static void
+mark_object_root_visitor (Lisp_Object *root_ptr,
+ enum gc_root_type type,
+ void *data)
+{
+ mark_object (*root_ptr);
+}
+
+/* List of weak hash tables we found during marking the Lisp heap.
+ Will be NULL on entry to garbage_collect_1 and after it
+ returns. */
+static struct Lisp_Hash_Table *weak_hash_tables;
+
+NO_INLINE /* For better stack traces */
+static void
+mark_and_sweep_weak_table_contents (void)
+{
+ struct Lisp_Hash_Table *h;
+ bool marked;
+
+ /* Mark all keys and values that are in use. Keep on marking until
+ there is no more change. This is necessary for cases like
+ value-weak table A containing an entry X -> Y, where Y is used in a
+ key-weak table B, Z -> Y. If B comes after A in the list of weak
+ tables, X -> Y might be removed from A, although when looking at B
+ one finds that it shouldn't. */
+ do
+ {
+ marked = false;
+ for (h = weak_hash_tables; h; h = h->next_weak)
+ marked |= sweep_weak_table (h, false);
+ }
+ while (marked);
+
+ /* Remove hash table entries that aren't used. */
+ while (weak_hash_tables)
+ {
+ h = weak_hash_tables;
+ weak_hash_tables = h->next_weak;
+ h->next_weak = NULL;
+ sweep_weak_table (h, true);
+ }
+}
+
/* Subroutine of Fgarbage_collect that does most of the work. It is a
separate function so that we could limit mark_stack in searching
the stack frames below this function, thus avoiding the rare cases
@@ -5757,13 +6039,14 @@ garbage_collect_1 (void *end)
{
struct buffer *nextb;
char stack_top_variable;
- ptrdiff_t i;
bool message_p;
ptrdiff_t count = SPECPDL_INDEX ();
struct timespec start;
Lisp_Object retval = Qnil;
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)
@@ -5839,14 +6122,10 @@ garbage_collect_1 (void *end)
/* Mark all the special slots that serve as the roots of accessibility. */
- mark_buffer (&buffer_defaults);
- mark_buffer (&buffer_local_symbols);
-
- for (i = 0; i < ARRAYELTS (lispsym); i++)
- mark_object (builtin_lisp_symbol (i));
-
- for (i = 0; i < staticidx; i++)
- mark_object (*staticvec[i]);
+ struct gc_root_visitor visitor;
+ memset (&visitor, 0, sizeof (visitor));
+ visitor.visit = mark_object_root_visitor;
+ visit_static_gc_roots (visitor);
mark_pinned_objects ();
mark_pinned_symbols ();
@@ -5891,11 +6170,11 @@ garbage_collect_1 (void *end)
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 ();
@@ -6043,7 +6322,7 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
for (; glyph < end_glyph; ++glyph)
if (STRINGP (glyph->object)
- && !STRING_MARKED_P (XSTRING (glyph->object)))
+ && !string_marked_p (XSTRING (glyph->object)))
mark_object (glyph->object);
}
}
@@ -6060,13 +6339,18 @@ static int last_marked_index;
ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
static void
-mark_vectorlike (struct Lisp_Vector *ptr)
+mark_vectorlike (union vectorlike_header *header)
{
+ struct Lisp_Vector *ptr = (struct Lisp_Vector *) header;
ptrdiff_t size = ptr->header.size;
ptrdiff_t i;
- eassert (!VECTOR_MARKED_P (ptr));
- VECTOR_MARK (ptr); /* Else mark it. */
+ eassert (!vector_marked_p (ptr));
+
+ /* Bool vectors have a different case in mark_object. */
+ eassert (PSEUDOVECTOR_TYPE (ptr) != PVEC_BOOL_VECTOR);
+
+ set_vector_marked (ptr); /* Else mark it. */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
@@ -6089,17 +6373,18 @@ mark_char_table (struct Lisp_Vector *ptr, enum
pvec_type pvectype)
/* Consult the Lisp_Sub_Char_Table layout before changing this. */
int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
- eassert (!VECTOR_MARKED_P (ptr));
- VECTOR_MARK (ptr);
+ eassert (!vector_marked_p (ptr));
+ set_vector_marked (ptr);
for (i = idx; i < size; i++)
{
Lisp_Object val = ptr->contents[i];
- 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))
{
- if (! VECTOR_MARKED_P (XVECTOR (val)))
+ if (! vector_marked_p (XVECTOR (val)))
mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
}
else
@@ -6113,7 +6398,7 @@ mark_compiled (struct Lisp_Vector *ptr)
{
int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- VECTOR_MARK (ptr);
+ set_vector_marked (ptr);
for (i = 0; i < size; i++)
if (i != COMPILED_CONSTANTS)
mark_object (ptr->contents[i]);
@@ -6125,12 +6410,12 @@ mark_compiled (struct Lisp_Vector *ptr)
static void
mark_overlay (struct Lisp_Overlay *ptr)
{
- for (; ptr && !VECTOR_MARKED_P (ptr); ptr = ptr->next)
+ for (; ptr && !vectorlike_marked_p (&ptr->header); ptr = ptr->next)
{
- 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);
}
}
@@ -6141,11 +6426,11 @@ static void
mark_buffer (struct buffer *buffer)
{
/* This is handled much like other pseudovectors... */
- mark_vectorlike ((struct Lisp_Vector *) buffer);
+ mark_vectorlike (&buffer->header);
/* ...but there are some buffer-specific things. */
- MARK_INTERVAL_TREE (buffer_intervals (buffer));
+ mark_interval_tree (buffer_intervals (buffer));
/* For now, we just don't mark the undo_list. It's done later in
a special way just before the sweep phase, and after stripping
@@ -6155,7 +6440,8 @@ mark_buffer (struct buffer *buffer)
mark_overlay (buffer->overlays_after);
/* If this is an indirect buffer, mark its base buffer. */
- if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
+ if (buffer->base_buffer &&
+ !vectorlike_marked_p (&buffer->base_buffer->header))
mark_buffer (buffer->base_buffer);
}
@@ -6174,8 +6460,8 @@ mark_face_cache (struct face_cache *c)
if (face)
{
- if (face->font && !VECTOR_MARKED_P (face->font))
- mark_vectorlike ((struct Lisp_Vector *) face->font);
+ if (face->font && !vectorlike_marked_p (&face->font->header))
+ mark_vectorlike (&face->font->header);
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
mark_object (face->lface[j]);
@@ -6206,7 +6492,7 @@ mark_discard_killed_buffers (Lisp_Object list)
{
Lisp_Object tail, *prev = &list;
- for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
+ for (tail = list; CONSP (tail) && !cons_marked_p (XCONS (tail));
tail = XCDR (tail))
{
Lisp_Object tem = XCAR (tail);
@@ -6216,7 +6502,7 @@ mark_discard_killed_buffers (Lisp_Object list)
*prev = XCDR (tail);
else
{
- CONS_MARK (XCONS (tail));
+ set_cons_marked (XCONS (tail));
mark_object (XCAR (tail));
prev = xcdr_addr (tail);
}
@@ -6225,6 +6511,72 @@ mark_discard_killed_buffers (Lisp_Object list)
return list;
}
+static void
+mark_frame (struct Lisp_Vector *ptr)
+{
+ struct frame *f = (struct frame *) ptr;
+ mark_vectorlike (&ptr->header);
+ mark_face_cache (f->face_cache);
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
+ {
+ struct font *font = FRAME_FONT (f);
+
+ if (font && !vectorlike_marked_p (&font->header))
+ mark_vectorlike (&font->header);
+ }
+#endif
+}
+
+static void
+mark_window (struct Lisp_Vector *ptr)
+{
+ struct window *w = (struct window *) ptr;
+
+ mark_vectorlike (&ptr->header);
+
+ /* Mark glyph matrices, if any. Marking window
+ matrices is sufficient because frame matrices
+ use the same glyph memory. */
+ if (w->current_matrix)
+ {
+ mark_glyph_matrix (w->current_matrix);
+ mark_glyph_matrix (w->desired_matrix);
+ }
+
+ /* Filter out killed buffers from both buffer lists
+ in attempt to help GC to reclaim killed buffers faster.
+ We can do it elsewhere for live windows, but this is the
+ best place to do it for dead windows. */
+ wset_prev_buffers
+ (w, mark_discard_killed_buffers (w->prev_buffers));
+ wset_next_buffers
+ (w, mark_discard_killed_buffers (w->next_buffers));
+}
+
+static void
+mark_hash_table (struct Lisp_Vector *ptr)
+{
+ struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
+
+ mark_vectorlike (&h->header);
+ mark_object (h->test.name);
+ mark_object (h->test.user_hash_function);
+ mark_object (h->test.user_cmp_function);
+ /* If hash table is not weak, mark all keys and values. For weak
+ tables, mark only the vector and not its contents --- that's what
+ makes it weak. */
+ if (NILP (h->weak))
+ mark_object (h->key_and_value);
+ else
+ {
+ eassert (h->next_weak == NULL);
+ h->next_weak = weak_hash_tables;
+ weak_hash_tables = h;
+ set_vector_marked (XVECTOR (h->key_and_value));
+ }
+}
+
/* Determine type of generic Lisp_Object and mark it accordingly.
This function implements a straightforward depth-first marking
@@ -6239,7 +6591,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;
@@ -6262,6 +6614,12 @@ mark_object (Lisp_Object arg)
structure allocated from the heap. */
#define CHECK_ALLOCATED() \
do { \
+ if (pdumper_object_p(po)) \
+ { \
+ if (!pdumper_object_p_precise (po)) \
+ emacs_abort (); \
+ break; \
+ } \
m = mem_find (po); \
if (m == MEM_NIL) \
emacs_abort (); \
@@ -6271,6 +6629,8 @@ mark_object (Lisp_Object arg)
function LIVEP. */
#define CHECK_LIVE(LIVEP) \
do { \
+ if (pdumper_object_p(po)) \
+ break; \
if (!LIVEP (m, po)) \
emacs_abort (); \
} while (0)
@@ -6305,11 +6665,11 @@ mark_object (Lisp_Object arg)
case Lisp_String:
{
register struct Lisp_String *ptr = XSTRING (obj);
- if (STRING_MARKED_P (ptr))
- break;
+ if (string_marked_p (ptr))
+ break;
CHECK_ALLOCATED_AND_LIVE (live_string_p);
- MARK_STRING (ptr);
- MARK_INTERVAL_TREE (ptr->u.s.intervals);
+ set_string_marked (ptr);
+ mark_interval_tree (ptr->u.s.intervals);
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
@@ -6322,22 +6682,25 @@ mark_object (Lisp_Object arg)
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
- if (VECTOR_MARKED_P (ptr))
+ if (vector_marked_p (ptr))
break;
-#if GC_CHECK_MARKED_OBJECTS
- m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
- emacs_abort ();
+#ifdef GC_CHECK_MARKED_OBJECTS
+ if (!pdumper_object_p(po))
+ {
+ m = mem_find (po);
+ if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
+ emacs_abort ();
+ }
#endif /* GC_CHECK_MARKED_OBJECTS */
enum pvec_type pvectype
= PSEUDOVECTOR_TYPE (ptr);
- if (pvectype != PVEC_SUBR
- && pvectype != PVEC_BUFFER
- && !main_thread_p (po))
- CHECK_LIVE (live_vector_p);
+ if (pvectype != PVEC_SUBR &&
+ pvectype != PVEC_BUFFER &&
+ !main_thread_p (po))
+ CHECK_LIVE (live_vector_p);
switch (pvectype)
{
@@ -6353,77 +6716,28 @@ mark_object (Lisp_Object arg)
}
#endif /* GC_CHECK_MARKED_OBJECTS */
mark_buffer ((struct buffer *) ptr);
- break;
-
- case PVEC_COMPILED:
- /* Although we could treat this just like a vector, mark_compiled
- returns the COMPILED_CONSTANTS element, which is marked at the
- next iteration of goto-loop here. This is done to avoid a few
- recursive calls to mark_object. */
- obj = mark_compiled (ptr);
- if (!NILP (obj))
- goto loop;
- break;
-
- case PVEC_FRAME:
- {
- struct frame *f = (struct frame *) ptr;
-
- mark_vectorlike (ptr);
- mark_face_cache (f->face_cache);
-#ifdef HAVE_WINDOW_SYSTEM
- if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
- {
- struct font *font = FRAME_FONT (f);
-
- if (font && !VECTOR_MARKED_P (font))
- mark_vectorlike ((struct Lisp_Vector *) font);
- }
-#endif
- }
- break;
-
- case PVEC_WINDOW:
- {
- struct window *w = (struct window *) ptr;
-
- mark_vectorlike (ptr);
-
- /* Mark glyph matrices, if any. Marking window
- matrices is sufficient because frame matrices
- use the same glyph memory. */
- if (w->current_matrix)
- {
- mark_glyph_matrix (w->current_matrix);
- mark_glyph_matrix (w->desired_matrix);
- }
-
- /* Filter out killed buffers from both buffer lists
- in attempt to help GC to reclaim killed buffers faster.
- We can do it elsewhere for live windows, but this is the
- best place to do it for dead windows. */
- wset_prev_buffers
- (w, mark_discard_killed_buffers (w->prev_buffers));
- wset_next_buffers
- (w, mark_discard_killed_buffers (w->next_buffers));
- }
- break;
+ break;
+
+ case PVEC_COMPILED:
+ /* Although we could treat this just like a vector, mark_compiled
+ returns the COMPILED_CONSTANTS element, which is marked at the
+ next iteration of goto-loop here. This is done to avoid a few
+ recursive calls to mark_object. */
+ obj = mark_compiled (ptr);
+ if (!NILP (obj))
+ goto loop;
+ break;
+
+ case PVEC_FRAME:
+ mark_frame (ptr);
+ break;
+
+ case PVEC_WINDOW:
+ mark_window (ptr);
+ break;
case PVEC_HASH_TABLE:
- {
- struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
-
- mark_vectorlike (ptr);
- mark_object (h->test.name);
- mark_object (h->test.user_hash_function);
- mark_object (h->test.user_cmp_function);
- /* If hash table is not weak, mark all keys and values.
- For weak tables, mark only the vector. */
- if (NILP (h->weak))
- mark_object (h->key_and_value);
- else
- VECTOR_MARK (XVECTOR (h->key_and_value));
- }
+ mark_hash_table (ptr);
break;
case PVEC_CHAR_TABLE:
@@ -6431,7 +6745,17 @@ mark_object (Lisp_Object arg)
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;
@@ -6444,7 +6768,7 @@ mark_object (Lisp_Object arg)
default:
/* A regular vector, or a pseudovector needing no special
treatment. */
- mark_vectorlike (ptr);
+ mark_vectorlike (&ptr->header);
}
}
break;
@@ -6453,10 +6777,10 @@ mark_object (Lisp_Object arg)
{
struct Lisp_Symbol *ptr = XSYMBOL (obj);
nextsym:
- if (ptr->u.s.gcmarkbit)
- break;
- CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
- ptr->u.s.gcmarkbit = 1;
+ if (symbol_marked_p (ptr))
+ break;
+ CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
+ set_symbol_marked(ptr);
/* Attempt to catch bogus objects. */
eassert (valid_lisp_object_p (ptr->u.s.function));
mark_object (ptr->u.s.function);
@@ -6483,8 +6807,8 @@ mark_object (Lisp_Object arg)
default: emacs_abort ();
}
if (!PURE_P (XSTRING (ptr->u.s.name)))
- MARK_STRING (XSTRING (ptr->u.s.name));
- MARK_INTERVAL_TREE (string_intervals (ptr->u.s.name));
+ set_string_marked (XSTRING (ptr->u.s.name));
+ mark_interval_tree (string_intervals (ptr->u.s.name));
/* Inner loop to mark next symbol in this bucket, if any. */
po = ptr = ptr->u.s.next;
if (ptr)
@@ -6495,10 +6819,10 @@ mark_object (Lisp_Object arg)
case Lisp_Cons:
{
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 (NILP (ptr->u.s.u.cdr))
{
@@ -6516,7 +6840,12 @@ mark_object (Lisp_Object arg)
case Lisp_Float:
CHECK_ALLOCATED_AND_LIVE (live_float_p);
- FLOAT_MARK (XFLOAT (obj));
+ /* Do not mark floats stored in a dump image: these floats are
+ "cold" and do not have mark bits. */
+ if (pdumper_object_p (XFLOAT (obj)))
+ eassert (pdumper_cold_object_p (XFLOAT (obj)));
+ else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
+ XFLOAT_MARK (XFLOAT (obj));
break;
case_Lisp_Int:
@@ -6530,6 +6859,7 @@ mark_object (Lisp_Object arg)
#undef CHECK_ALLOCATED
#undef CHECK_ALLOCATED_AND_LIVE
}
+
/* Mark the Lisp pointers in the terminal objects.
Called by Fgarbage_collect. */
@@ -6546,13 +6876,11 @@ mark_terminals (void)
gets marked. */
mark_image_cache (t->image_cache);
#endif /* HAVE_WINDOW_SYSTEM */
- if (!VECTOR_MARKED_P (t))
- mark_vectorlike ((struct Lisp_Vector *)t);
+ if (!vectorlike_marked_p (&t->header))
+ mark_vectorlike (&t->header);
}
}
-
-
/* Value is non-zero if OBJ will survive the current GC because it's
either marked or does not need to be marked to survive. */
@@ -6564,27 +6892,29 @@ survives_gc_p (Lisp_Object obj)
switch (XTYPE (obj))
{
case_Lisp_Int:
- survives_p = 1;
+ survives_p = true;
break;
case Lisp_Symbol:
- survives_p = XSYMBOL (obj)->u.s.gcmarkbit;
+ survives_p = symbol_marked_p (XSYMBOL (obj));
break;
case Lisp_String:
- survives_p = STRING_MARKED_P (XSTRING (obj));
+ survives_p = string_marked_p (XSTRING (obj));
break;
case Lisp_Vectorlike:
- survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
+ survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj));
break;
case Lisp_Cons:
- survives_p = CONS_MARKED_P (XCONS (obj));
+ survives_p = cons_marked_p (XCONS (obj));
break;
case Lisp_Float:
- survives_p = FLOAT_MARKED_P (XFLOAT (obj));
+ survives_p =
+ XFLOAT_MARKED_P (XFLOAT (obj)) ||
+ pdumper_object_p (XFLOAT (obj));
break;
default:
@@ -6638,7 +6968,7 @@ sweep_conses (void)
{
struct Lisp_Cons *acons
= ptr_bounds_copy (&cblk->conses[pos], cblk);
- if (!CONS_MARKED_P (acons))
+ if (!XCONS_MARKED_P (acons))
{
this_free++;
cblk->conses[pos].u.s.u.chain = cons_free_list;
@@ -6648,7 +6978,7 @@ sweep_conses (void)
else
{
num_used++;
- CONS_UNMARK (acons);
+ XUNMARK_CONS (acons);
}
}
}
@@ -6691,7 +7021,7 @@ sweep_floats (void)
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;
@@ -6700,7 +7030,7 @@ sweep_floats (void)
else
{
num_used++;
- FLOAT_UNMARK (afloat);
+ XFLOAT_UNMARK (afloat);
}
}
lim = FLOAT_BLOCK_SIZE;
@@ -6850,7 +7180,7 @@ unchain_dead_markers (struct buffer *buffer)
struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer);
while ((this = *prev))
- if (VECTOR_MARKED_P (this))
+ if (vectorlike_marked_p (&this->header))
prev = &this->next;
else
{
@@ -6867,14 +7197,15 @@ sweep_buffers (void)
total_buffers = 0;
for (buffer = all_buffers; buffer; buffer = *bprev)
- if (!VECTOR_MARKED_P (buffer))
+ if (!vectorlike_marked_p (&buffer->header))
{
*bprev = buffer->next;
lisp_free (buffer);
}
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);
@@ -6887,10 +7218,6 @@ sweep_buffers (void)
static void
gc_sweep (void)
{
- /* Remove or mark entries in weak hash tables.
- This must be done before any object is unmarked. */
- sweep_weak_hash_tables ();
-
sweep_strings ();
check_string_bytes (!noninteractive);
sweep_conses ();
@@ -6899,6 +7226,7 @@ gc_sweep (void)
sweep_symbols ();
sweep_buffers ();
sweep_vectors ();
+ pdumper_clear_marks ();
check_string_bytes (!noninteractive);
}
@@ -7151,19 +7479,34 @@ verify_alloca (void)
/* Initialization. */
+static void init_alloc_once_for_pdumper (void);
+
void
init_alloc_once (void)
{
+ gc_cons_threshold = GC_DEFAULT_THRESHOLD;
/* Even though Qt's contents are not set up, its address is known. */
Vpurify_flag = Qt;
- purebeg = PUREBEG;
- pure_size = PURESIZE;
+ PDUMPER_REMEMBER_SCALAR (buffer_defaults.header);
+ PDUMPER_REMEMBER_SCALAR (buffer_local_symbols.header);
+
+ /* Call init_alloc_once_for_pdumper now so we run mem_init early.
+ Keep in mind that when we reload from a dump, we'll run _only_
+ init_alloc_once_for_pdumper and not init_alloc_once at all. */
+ pdumper_do_now_and_after_load (init_alloc_once_for_pdumper);
verify_alloca ();
- init_finalizer_list (&finalizers);
- init_finalizer_list (&doomed_finalizers);
+ init_strings ();
+ init_vectors ();
+}
+
+static void
+init_alloc_once_for_pdumper (void)
+{
+ purebeg = PUREBEG;
+ pure_size = PURESIZE;
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
@@ -7172,11 +7515,11 @@ init_alloc_once (void)
mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
#endif
- init_strings ();
- init_vectors ();
+
+ init_finalizer_list (&finalizers);
+ init_finalizer_list (&doomed_finalizers);
refill_memory_reserve ();
- gc_cons_threshold = GC_DEFAULT_THRESHOLD;
}
void
@@ -7184,10 +7527,6 @@ init_alloc (void)
{
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
-
-#if USE_VALGRIND
- valgrind_p = RUNNING_ON_VALGRIND != 0;
-#endif
}
void
diff --git a/src/atimer.c b/src/atimer.c
index 4d97470a..d36c4f1 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -584,6 +584,7 @@ init_atimer (void)
sigaction (SIGALRM, &action, 0);
#ifdef ENABLE_CHECKING
- defsubr (&Sdebug_timer_check);
+ if (!initialized)
+ defsubr (&Sdebug_timer_check);
#endif
}
diff --git a/src/buffer.c b/src/buffer.c
index cc08996..a12c80e 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -44,6 +44,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "keymap.h"
#include "frame.h"
#include "xwidget.h"
+#include "pdumper.h"
#ifdef WINDOWSNT
#include "w32heap.h" /* for mmap_* */
@@ -529,6 +530,8 @@ even if it is dead. The return value is never nil. */)
/* No one shows us now. */
b->window_count = 0;
+ memset (&b->local_flags, 0, sizeof (b->local_flags));
+
BUF_GAP_SIZE (b) = 20;
block_input ();
/* We allocate extra 1-byte at the tail and keep it always '\0' for
@@ -781,6 +784,8 @@ CLONE nil means the indirect buffer's state is reset to
default values. */)
/* Always -1 for an indirect buffer. */
b->window_count = -1;
+ memset (&b->local_flags, 0, sizeof (b->local_flags));
+
b->pt = b->base_buffer->pt;
b->begv = b->base_buffer->begv;
b->zv = b->base_buffer->zv;
@@ -5001,24 +5006,37 @@ alloc_buffer_text (struct buffer *b, ptrdiff_t nbytes)
void
enlarge_buffer_text (struct buffer *b, ptrdiff_t delta)
{
- void *p;
- ptrdiff_t nbytes = (BUF_Z_BYTE (b) - BUF_BEG_BYTE (b) + BUF_GAP_SIZE (b) + 1
- + delta);
block_input ();
+ void *p;
+ unsigned char *old_beg = b->text->beg;
+ ptrdiff_t old_nbytes =
+ BUF_Z_BYTE (b) - BUF_BEG_BYTE (b) + BUF_GAP_SIZE (b) + 1;
+ ptrdiff_t new_nbytes = old_nbytes + delta;
+
+ if (pdumper_object_p (old_beg))
+ b->text->beg = NULL;
+ else
+ old_beg = NULL;
+
#if defined USE_MMAP_FOR_BUFFERS
- p = mmap_realloc ((void **) &b->text->beg, nbytes);
+ p = mmap_realloc ((void **) &b->text->beg, new_nbytes);
#elif defined REL_ALLOC
- p = r_re_alloc ((void **) &b->text->beg, nbytes);
+ p = r_re_alloc ((void **) &b->text->beg, new_nbytes);
#else
- p = xrealloc (b->text->beg, nbytes);
+ p = xrealloc (b->text->beg, new_nbytes);
#endif
if (p == NULL)
{
+ if (old_beg)
+ b->text->beg = old_beg;
unblock_input ();
- memory_full (nbytes);
+ memory_full (new_nbytes);
}
+ if (old_beg)
+ memcpy (p, old_beg, min (old_nbytes, new_nbytes));
+
BUF_BEG_ADDR (b) = p;
unblock_input ();
}
@@ -5031,13 +5049,16 @@ free_buffer_text (struct buffer *b)
{
block_input ();
+ if (!pdumper_object_p (b->text->beg))
+ {
#if defined USE_MMAP_FOR_BUFFERS
- mmap_free ((void **) &b->text->beg);
+ mmap_free ((void **) &b->text->beg);
#elif defined REL_ALLOC
- r_alloc_free ((void **) &b->text->beg);
+ r_alloc_free ((void **) &b->text->beg);
#else
- xfree (b->text->beg);
+ xfree (b->text->beg);
#endif
+ }
BUF_BEG_ADDR (b) = NULL;
unblock_input ();
@@ -5048,14 +5069,25 @@ free_buffer_text (struct buffer *b)
/***********************************************************************
Initialization
***********************************************************************/
-
void
init_buffer_once (void)
{
+ /* TODO: clean up the buffer-local machinery. Right now,
+ we have:
+
+ buffer_defaults: default values of buffer-locals
+ buffer_local_flags: metadata
+ buffer_permanent_local_flags: metadata
+ buffer_local_symbols: metadata
+
+ There must be a simpler way to store the metadata.
+ */
+
int idx;
/* Items flagged permanent get an explicit permanent-local property
added in bindings.el, for clarity. */
+ PDUMPER_REMEMBER_SCALAR (buffer_permanent_local_flags);
memset (buffer_permanent_local_flags, 0, sizeof
buffer_permanent_local_flags);
/* 0 means not a lisp var, -1 means always local, else mask. */
@@ -5144,10 +5176,15 @@ init_buffer_once (void)
XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows),
idx); ++idx;
+ /* buffer_local_flags contains no pointers, so it's safe to treat it
+ as a blob for pdumper. */
+ PDUMPER_REMEMBER_SCALAR (buffer_local_flags);
+
/* Need more room? */
if (idx >= MAX_PER_BUFFER_VARS)
emacs_abort ();
last_per_buffer_idx = idx;
+ PDUMPER_REMEMBER_SCALAR (last_per_buffer_idx);
/* Make sure all markable slots in buffer_defaults
are initialized reasonably, so mark_buffer won't choke. */
@@ -5242,7 +5279,9 @@ init_buffer_once (void)
Vbuffer_alist = Qnil;
current_buffer = 0;
+ pdumper_remember_lv_ptr_raw (¤t_buffer, Lisp_Vectorlike);
all_buffers = 0;
+ pdumper_remember_lv_ptr_raw (&all_buffers, Lisp_Vectorlike);
QSFundamental = build_pure_c_string ("Fundamental");
@@ -5266,12 +5305,12 @@ init_buffer_once (void)
}
void
-init_buffer (int initialized)
+init_buffer (void)
{
Lisp_Object temp;
#ifdef USE_MMAP_FOR_BUFFERS
- if (initialized)
+ if (dumped_with_unexec_p ())
{
struct buffer *b;
@@ -5312,9 +5351,6 @@ init_buffer (int initialized)
eassert (b->text->beg != NULL);
}
}
-#else /* not USE_MMAP_FOR_BUFFERS */
- /* Avoid compiler warnings. */
- (void) initialized;
#endif /* USE_MMAP_FOR_BUFFERS */
AUTO_STRING (scratch, "*scratch*");
diff --git a/src/bytecode.c b/src/bytecode.c
index bb7d796..4097779 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1398,10 +1398,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object
vector, Lisp_Object maxdepth,
search as the jump table. */
Lisp_Object jmp_table = POP;
if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table))
- emacs_abort ();
+ emacs_abort ();
Lisp_Object v1 = POP;
ptrdiff_t i;
struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table);
+ hash_rehash_if_needed (h);
/* h->count is a faster approximation for HASH_TABLE_SIZE (h)
here. */
diff --git a/src/callint.c b/src/callint.c
index 0911c49..ba6e335 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -818,7 +818,8 @@ syms_of_callint (void)
intern_c_string ("region-beginning"),
intern_c_string ("region-end"),
intern_c_string ("point"),
- intern_c_string ("mark"));
+ intern_c_string ("mark"));
+ staticpro (&preserved_fns);
DEFSYM (Qlist, "list");
DEFSYM (Qlet, "let");
diff --git a/src/callproc.c b/src/callproc.c
index 19882e6..d455838 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -1588,9 +1588,7 @@ init_callproc (void)
}
}
-#ifndef CANNOT_DUMP
- if (initialized)
-#endif
+ if (!will_dump_p ())
{
tempdir = Fdirectory_file_name (Vexec_directory);
if (! file_accessible_directory_p (tempdir))
diff --git a/src/category.c b/src/category.c
index c504d2d..132fae9 100644
--- a/src/category.c
+++ b/src/category.c
@@ -42,15 +42,6 @@ bset_category_table (struct buffer *b, Lisp_Object val)
b->category_table_ = val;
}
-/* The version number of the latest category table. Each category
- table has a unique version number. It is assigned a new number
- also when it is modified. When a regular expression is compiled
- into the struct re_pattern_buffer, the version number of the
- category table (of the current buffer) at that moment is also
- embedded in the structure.
-
- For the moment, we are not using this feature. */
-static int category_table_version;
/* Category set staff. */
@@ -512,6 +503,4 @@ See the documentation of the variable
`word-combining-categories'. */);
defsubr (&Schar_category_set);
defsubr (&Scategory_set_mnemonics);
defsubr (&Smodify_category_entry);
-
- category_table_version = 0;
}
diff --git a/src/charset.c b/src/charset.c
index 724b355..28f6203 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -39,6 +39,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "buffer.h"
#include "sysstdio.h"
+#include "pdumper.h"
/*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) ***
@@ -61,9 +62,8 @@ Lisp_Object Vcharset_hash_table;
/* Table of struct charset. */
struct charset *charset_table;
-
-static ptrdiff_t charset_table_size;
-static int charset_table_used;
+ptrdiff_t charset_table_size;
+int charset_table_used;
/* Special charsets corresponding to symbols. */
int charset_ascii;
@@ -851,6 +851,8 @@ usage: (define-charset-internal ...) */)
bool new_definition_p;
int nchars;
+ memset (&charset, 0, sizeof (charset));
+
if (nargs != charset_arg_max)
Fsignal (Qwrong_number_of_arguments,
Fcons (intern ("define-charset-internal"),
@@ -1142,9 +1144,9 @@ usage: (define-charset-internal ...) */)
struct charset *new_table =
xpalloc (0, &new_size, 1,
min (INT_MAX, MOST_POSITIVE_FIXNUM),
- sizeof *charset_table);
- memcpy (new_table, charset_table, old_size * sizeof *new_table);
- charset_table = new_table;
+ sizeof *charset_table);
+ memcpy (new_table, charset_table, old_size * sizeof *new_table);
+ charset_table = new_table;
charset_table_size = new_size;
/* FIXME: This leaks memory, as the old charset_table becomes
unreachable. If the old charset table is charset_table_init
@@ -2316,15 +2318,26 @@ init_charset_once (void)
for (i = 0; i < ISO_MAX_DIMENSION; i++)
for (j = 0; j < ISO_MAX_CHARS; j++)
for (k = 0; k < ISO_MAX_FINAL; k++)
- iso_charset_table[i][j][k] = -1;
+ iso_charset_table[i][j][k] = -1;
+
+ PDUMPER_REMEMBER_SCALAR (iso_charset_table);
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);
}
/* Allocate an initial charset table that is large enough to handle
@@ -2365,7 +2378,9 @@ syms_of_charset (void)
charset_table = charset_table_init;
charset_table_size = ARRAYELTS (charset_table_init);
+ PDUMPER_REMEMBER_SCALAR (charset_table_size);
charset_table_used = 0;
+ PDUMPER_REMEMBER_SCALAR (charset_table_used);
defsubr (&Scharsetp);
defsubr (&Smap_charset_chars);
@@ -2411,19 +2426,30 @@ the value may be a list of mnemonics. */);
charset_ascii
= define_charset_internal (Qascii, 1, "\x00\x7F\0\0\0\0\0",
- 0, 127, 'B', -1, 0, 1, 0, 0);
+ 0, 127, 'B', -1, 0, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_ascii);
+
charset_iso_8859_1
= define_charset_internal (Qiso_8859_1, 1, "\x00\xFF\0\0\0\0\0",
- 0, 255, -1, -1, -1, 1, 0, 0);
+ 0, 255, -1, -1, -1, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_iso_8859_1);
+
charset_unicode
= define_charset_internal (Qunicode, 3, "\x00\xFF\x00\xFF\x00\x10\0",
- 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
+ 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_unicode);
+
charset_emacs
= define_charset_internal (Qemacs, 3, "\x00\xFF\x00\xFF\x00\x3F\0",
- 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
+ 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
+ PDUMPER_REMEMBER_SCALAR (charset_emacs);
+
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);
}
diff --git a/src/charset.h b/src/charset.h
index 0822f2d..f4bed55 100644
--- a/src/charset.h
+++ b/src/charset.h
@@ -248,6 +248,8 @@ extern Lisp_Object Vcharset_hash_table;
/* Table of struct charset. */
extern struct charset *charset_table;
+extern ptrdiff_t charset_table_size;
+extern int charset_table_used;
#define CHARSET_FROM_ID(id) (charset_table + (id))
diff --git a/src/coding.c b/src/coding.c
index 1c14621..665aefa 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -298,6 +298,7 @@ encode_coding_XXX (struct coding_system *coding)
#include "composite.h"
#include "coding.h"
#include "termhooks.h"
+#include "pdumper.h"
Lisp_Object Vcoding_system_hash_table;
@@ -10737,6 +10738,9 @@ init_coding_once (void)
coding_priorities[i] = i;
}
+ PDUMPER_REMEMBER_SCALAR (coding_categories);
+ PDUMPER_REMEMBER_SCALAR (coding_priorities);
+
/* ISO2022 specific initialize routine. */
for (i = 0; i < 0x20; i++)
iso_code_class[i] = ISO_control_0;
@@ -10756,6 +10760,8 @@ init_coding_once (void)
iso_code_class[ISO_CODE_SS3] = ISO_single_shift_3;
iso_code_class[ISO_CODE_CSI] = ISO_control_sequence_introducer;
+ PDUMPER_REMEMBER_SCALAR (iso_code_class);
+
for (i = 0; i < 256; i++)
{
emacs_mule_bytes[i] = 1;
@@ -10764,6 +10770,8 @@ 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);
}
void
@@ -10785,6 +10793,7 @@ syms_of_coding (void)
Vcode_conversion_workbuf_name = build_pure_c_string ("
*code-conversion-work*");
reused_workbuf_in_use = 0;
+ PDUMPER_REMEMBER_SCALAR (reused_workbuf_in_use);
DEFSYM (Qcharset, "charset");
DEFSYM (Qtarget_idx, "target-idx");
diff --git a/src/composite.c b/src/composite.c
index cd8364a..c426cbb 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -654,6 +654,7 @@ Lisp_Object
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);
Lisp_Object header = LGSTRING_HEADER (gstring);
EMACS_UINT hash = h->test.hashfn (&h->test, header);
if (len < 0)
diff --git a/src/conf_post.h b/src/conf_post.h
index 002ef6c..125dbf0 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -299,8 +299,10 @@ extern int emacs_setenv_TZ (char const *);
#if 3 <= __GNUC__
# define ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+# define ATTRIBUTE_SECTION(name) __attribute__((section (name)))
#else
# define ATTRIBUTE_MALLOC
+#define ATTRIBUTE_SECTION(name)
#endif
#if __has_attribute (alloc_size)
diff --git a/src/data.c b/src/data.c
index a9908a3..92a1062 100644
--- a/src/data.c
+++ b/src/data.c
@@ -804,7 +804,7 @@ The return value is undefined. */)
{
bool autoload = AUTOLOADP (definition);
- if (NILP (Vpurify_flag) || !autoload)
+ if (!will_dump_p () || !autoload)
{ /* Only add autoload entries after dumping, because the ones before are
not useful and else we get loads of them from the loaddefs.el. */
@@ -1826,7 +1826,7 @@ The function `default-value' gets the default value and
`set-default' sets it.
{
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);
@@ -1893,7 +1893,7 @@ Instead, use `add-hook' and specify t for the LOCAL
argument. */)
{
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;
@@ -2958,7 +2958,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs,
Lisp_Object *args,
/* Set ACCUM to the next operation's result if it fits,
else exit the loop. */
bool overflow = false;
- intmax_t a;
+ intmax_t a UNINIT;
switch (code)
{
case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break;
diff --git a/src/dbusbind.c b/src/dbusbind.c
index e1c4eda..0afae6b 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -1831,6 +1831,8 @@ be called when the D-Bus reply message arrives. */);
xd_registered_buses = Qnil;
staticpro (&xd_registered_buses);
+ // TODO: reset buses on dump load
+
Fprovide (intern_c_string ("dbusbind"), Qnil);
}
diff --git a/src/dispnew.c b/src/dispnew.c
index 55cdaf5..88783cd 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -42,6 +42,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "tparam.h"
#include "xwidget.h"
+#include "pdumper.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -5987,12 +5988,24 @@ pass nil for VARIABLE. */)
Initialization
***********************************************************************/
+static void
+init_faces_initial (void)
+{
+ /* For the initial frame, we don't have any way of knowing what
+ are the foreground and background colors of the terminal. */
+ struct frame *sf = SELECTED_FRAME ();
+
+ FRAME_FOREGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_FG_COLOR;
+ FRAME_BACKGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_BG_COLOR;
+ call0 (intern ("tty-set-up-initial-frame-faces"));
+}
+
/* Initialization done when Emacs fork is started, before doing stty.
Determine terminal type and set terminal_driver. Then invoke its
decoding routine to set up variables in the terminal package. */
-void
-init_display (void)
+static void
+init_display_interactive (void)
{
char *terminal_type;
@@ -6012,9 +6025,7 @@ init_display (void)
with. Otherwise newly opened tty frames will not resize
automatically. */
#ifdef SIGWINCH
-#ifndef CANNOT_DUMP
- if (initialized)
-#endif /* CANNOT_DUMP */
+ if (!will_dump_p ())
{
struct sigaction action;
emacs_sigaction_init (&action, deliver_window_change_signal);
@@ -6078,11 +6089,7 @@ init_display (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_fixnum (10);
@@ -6170,22 +6177,23 @@ init_display (void)
calculate_costs (XFRAME (selected_frame));
- /* Set up faces of the initial terminal frame of a dumped Emacs. */
- if (initialized
- && !noninteractive
- && NILP (Vinitial_window_system))
- {
- /* For the initial frame, we don't have any way of knowing what
- are the foreground and background colors of the terminal. */
- struct frame *sf = SELECTED_FRAME ();
+ /* Set up faces of the initial terminal frame. */
+ if (!noninteractive && NILP (Vinitial_window_system))
+ init_faces_initial ();
+}
- FRAME_FOREGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_FG_COLOR;
- FRAME_BACKGROUND_PIXEL (sf) = FACE_TTY_DEFAULT_BG_COLOR;
- call0 (intern ("tty-set-up-initial-frame-faces"));
+void
+init_display (void)
+{
+ if (noninteractive)
+ {
+ if (dumped_with_pdumper_p ())
+ init_faces_initial ();
}
+ else
+ init_display_interactive ();
}
-
/***********************************************************************
Blinking cursor
@@ -6220,6 +6228,8 @@ WINDOW nil or omitted means report on the selected
window. */)
Initialization
***********************************************************************/
+static void syms_of_display_for_pdumper (void);
+
void
syms_of_display (void)
{
@@ -6327,11 +6337,12 @@ See `buffer-display-table' for more information. */);
beginning of the next redisplay). */
redisplay_dont_pause = true;
-#ifdef CANNOT_DUMP
- if (noninteractive)
-#endif
- {
- Vinitial_window_system = Qnil;
- Vwindow_system_version = Qnil;
- }
+ pdumper_do_now_and_after_load (syms_of_display_for_pdumper);
+}
+
+static void
+syms_of_display_for_pdumper (void)
+{
+ Vinitial_window_system = Qnil;
+ Vwindow_system_version = Qnil;
}
diff --git a/src/dmpstruct.awk b/src/dmpstruct.awk
new file mode 100755
index 0000000..d222d11
--- /dev/null
+++ b/src/dmpstruct.awk
@@ -0,0 +1,28 @@
+BEGIN {
+ print "/* Generated by dmpstruct.awk */"
+ print "#ifndef EMACS_DMPSTRUCT_H"
+ print "#define EMACS_DMPSTRUCT_H"
+ struct_name = ""
+ tmpfile = "dmpstruct.tmp"
+}
+# Match a type followed by optional syntactic whitespace
+/^(enum|struct|union) [a-zA-Z0-9_]+([\t ]|\/\*.*\*\/)*$/ {
+ struct_name = $2
+ close (tmpfile)
+}
+/^(enum|struct|union) [a-zA-Z0-9_]+([\t ]|\/\*.*\*\/)*$/, /^( )?};$/ {
+ print $0 > tmpfile
+}
+/^( )?} *(GCALIGNED_STRUCT)? *;$/ {
+ if (struct_name != "") {
+ fflush (tmpfile)
+ cmd = "../lib-src/make-fingerprint -r " tmpfile
+ cmd | getline hash
+ close (cmd)
+ printf "#define HASH_%s_%.10s\n", struct_name, hash
+ struct_name = ""
+ }
+}
+END {
+ print "#endif /* EMACS_DMPSTRUCT_H */"
+}
diff --git a/src/doc.c b/src/doc.c
index 04370f7..3e43d6d 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -118,17 +118,15 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool
definition)
Lisp_Object docdir
= NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string;
ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1;
-#ifndef CANNOT_DUMP
- docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
-#endif
+ if (will_dump_p ())
+ docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file));
lispstpcpy (lispstpcpy (name, docdir), file);
fd = emacs_open (name, O_RDONLY, 0);
if (fd < 0)
{
-#ifndef CANNOT_DUMP
- if (!NILP (Vpurify_flag))
+ if (will_dump_p ())
{
/* Preparing to dump; DOC file is probably not installed.
So check in ../etc. */
@@ -136,7 +134,6 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool
definition)
fd = emacs_open (name, O_RDONLY, 0);
}
-#endif
if (fd < 0)
{
if (errno == EMFILE || errno == ENFILE)
@@ -545,12 +542,7 @@ the same file name is found in the `doc-directory'. */)
CHECK_STRING (filename);
- if
-#ifndef CANNOT_DUMP
- (!NILP (Vpurify_flag))
-#else /* CANNOT_DUMP */
- (0)
-#endif /* CANNOT_DUMP */
+ if (will_dump_p ())
{
dirname = sibling_etc;
dirlen = sizeof sibling_etc - 1;
diff --git a/src/editfns.c b/src/editfns.c
index 5512701..01376b0 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -3454,7 +3454,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
bool format_as_long_double = false;
double darg;
- long double ldarg;
+ long double ldarg UNINIT;
if (FLOATP (arg))
darg = XFLOAT_DATA (arg);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index e695a3d..cbab023 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -1191,7 +1191,10 @@ void
syms_of_module (void)
{
if (!plain_values)
- ltv_mark = Fcons (Qnil, Qnil);
+ {
+ ltv_mark = Fcons (Qnil, Qnil);
+ staticpro (<v_mark);
+ }
eassert (NILP (value_to_lisp (module_nil)));
DEFSYM (Qmodule_refs_hash, "module-refs-hash");
diff --git a/src/emacs.c b/src/emacs.c
index 221b074..9c88b6e 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -118,6 +118,9 @@ extern char etext;
#include <sys/resource.h>
#endif
+#include "pdumper.h"
+#include "epaths.h"
+
static const char emacs_version[] = PACKAGE_VERSION;
static const char emacs_copyright[] = COPYRIGHT;
static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
@@ -130,19 +133,9 @@ Lisp_Object empty_unibyte_string, empty_multibyte_string;
Lisp_Object Vlibrary_cache;
#endif
-/* Set after Emacs has started up the first time.
- Prevents reinitialization of the Lisp world and keymaps
- on subsequent starts. */
+struct gflags gflags;
bool initialized;
-#ifndef CANNOT_DUMP
-/* Set to true if this instance of Emacs might dump. */
-# ifndef DOUG_LEA_MALLOC
-static
-# endif
-bool might_dump;
-#endif
-
/* If true, Emacs should not attempt to use a window-specific code,
but instead should use the virtual terminal under which it was started. */
bool inhibit_window_system;
@@ -519,8 +512,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char
const *original_pwd)
etc_exists = Ffile_exists_p (tem);
if (!NILP (etc_exists))
{
- Vinstallation_directory
- = Ffile_name_as_directory (dir);
+ Vinstallation_directory = Ffile_name_as_directory (dir);
break;
}
}
@@ -545,8 +537,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char
const *original_pwd)
if (!NILP (etc_exists))
{
tem = Fexpand_file_name (build_string (".."), dir);
- Vinstallation_directory
- = Ffile_name_as_directory (tem);
+ Vinstallation_directory = Ffile_name_as_directory (tem);
break;
}
}
@@ -659,6 +650,43 @@ argmatch (char **argv, int argc, const char *sstr, const
char *lstr,
}
}
+static bool
+string_starts_with_p (const char* string, const char* prefix)
+{
+ return strncmp (string, prefix, strlen (prefix)) == 0;
+}
+
+/* Return the value of GNU-style long argument ARGUMENT if given on
+ command line. ARGUMENT must begin with "-". If ARGUMENT is not
+ given, return NULL. */
+static char *
+find_argument (const char *argument, int argc, char **argv)
+{
+ char *found = NULL;
+ int i;
+
+ eassert (argument[0] == '-');
+
+ for (i = 1; i < argc; ++i)
+ if (string_starts_with_p (argv[i], argument) &&
+ ((argv[i] + strlen (argument))[0] == '=' ||
+ (argv[i] + strlen (argument))[0] == '\0'))
+ {
+ int j = i;
+ found = argv[j++] + strlen (argument);
+ if (*found == '=')
+ ++found;
+ else if (i < argc)
+ found = argv[j++];
+ else
+ fatal ("no argument given for %s", argument);
+ break;
+ }
+ else if (strcmp (argv[i], "--") == 0)
+ break;
+ return found;
+}
+
/* Close standard output and standard error, reporting any write
errors as best we can. This is intended for use with atexit. */
static void
@@ -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 (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)
@@ -686,7 +822,6 @@ main (int argc, char **argv)
void *stack_bottom_variable;
bool do_initial_setlocale;
- bool dumping;
int skip_args = 0;
bool no_loadup = false;
char *junk = 0;
@@ -702,25 +837,62 @@ main (int argc, char **argv)
/* Record (approximately) where the stack begins. */
stack_bottom = (char *) &stack_bottom_variable;
-#ifndef CANNOT_DUMP
- dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
- || strcmp (argv[argc - 1], "bootstrap") == 0);
-#else
- dumping = false;
+ const char *dump_mode = NULL;
+ const char *temacs = find_argument ("--temacs", argc, argv);
+#ifdef HAVE_PDUMPER
+ bool attempt_load_pdump = false;
#endif
- argc = maybe_disable_address_randomization (dumping, argc, argv);
-
+ /* Look for this argument first, before any heap allocation, so we
+ can set heap flags properly if we're going to unexec. */
+ if (!initialized && temacs)
+ {
#ifndef CANNOT_DUMP
- might_dump = !initialized;
-
-# ifdef GNU_LINUX
- if (!initialized)
+ if (strcmp (temacs, "dump") == 0 ||
+ strcmp (temacs, "bootstrap") == 0)
+ gflags.will_dump_with_unexec_ = true;
+#endif
+#ifdef HAVE_PDUMPER
+ if (strcmp (temacs, "pdump") == 0 ||
+ strcmp (temacs, "pbootstrap") == 0)
+ gflags.will_dump_with_pdumper_ = true;
+#endif
+#if defined (HAVE_PDUMPER) || !defined (CANNOT_DUMP)
+ if (strcmp (temacs, "bootstrap") == 0 ||
+ strcmp (temacs, "pbootstrap") == 0)
+ gflags.will_bootstrap_ = true;
+ gflags.will_dump_ =
+ will_dump_with_pdumper_p () ||
+ will_dump_with_unexec_p ();
+ if (will_dump_p ())
+ dump_mode = temacs;
+#endif
+ if (!dump_mode)
+ fatal ("Invalid temacs mode '%s'", temacs);
+ }
+ else if (temacs)
{
- char *heap_start = my_heap_start ();
- heap_bss_diff = heap_start - max (my_endbss, my_endbss_static);
+ fatal ("--temacs not supported for unexeced emacs");
}
-# endif
+ else if (initialized)
+ {
+#ifdef HAVE_PDUMPER
+ if (find_argument (PDUMP_FILE_ARG, argc, argv))
+ fatal ("%s not supported in unexeced emacs", PDUMP_FILE_ARG);
+#endif
+ }
+ else
+ {
+ eassert (!initialized);
+ eassert (!temacs);
+#ifdef PDUMP_FILE_ARG
+ attempt_load_pdump = true;
+#endif
+ }
+
+#ifndef CANNOT_DUMP
+ if (!will_dump_with_unexec_p ())
+ gflags.will_not_unexec_ = true;
#endif
#if defined WINDOWSNT || defined HAVE_NTGUI
@@ -742,6 +914,22 @@ main (int argc, char **argv)
w32_init_main_thread ();
#endif
+#ifdef HAVE_PDUMPER
+ if (attempt_load_pdump)
+ load_pdump (argc, argv);
+#endif
+
+ 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]);
@@ -850,10 +1038,7 @@ main (int argc, char **argv)
frames. */
int extra = (30 * 1000) * 50;
- bool try_to_grow_stack = true;
-#ifndef CANNOT_DUMP
- try_to_grow_stack = !noninteractive || initialized;
-#endif
+ bool try_to_grow_stack = !noninteractive || initialized;
if (try_to_grow_stack)
{
@@ -1184,17 +1369,15 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#if defined HAVE_PTHREAD && !defined SYSTEM_MALLOC \
&& !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
-# ifndef CANNOT_DUMP
/* Do not make gmalloc thread-safe when creating bootstrap-emacs, as
that causes an infinite recursive loop with FreeBSD. See
Bug#14569. The part of this bug involving Cygwin is no longer
relevant, now that Cygwin defines HYBRID_MALLOC. */
- if (!noninteractive || initialized)
-# endif
+ if (!noninteractive || !will_dump_p ())
malloc_enable_thread ();
#endif
- init_signals (dumping);
+ init_signals ();
noninteractive1 = noninteractive;
@@ -1204,7 +1387,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
{
init_alloc_once ();
init_threads_once ();
- init_obarray ();
+ init_obarray_once ();
init_eval_once ();
init_charset_once ();
init_coding_once ();
@@ -1242,7 +1425,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
/* Before init_window_once, because it sets up the
Vcoding_system_hash_table. */
syms_of_coding (); /* This should be after syms_of_fileio. */
-
+ init_frame_once (); /* Before init_window_once. */
init_window_once (); /* Init the window system. */
#ifdef HAVE_WINDOW_SYSTEM
init_fringe_once (); /* Swap bitmaps if necessary. */
@@ -1282,7 +1465,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
bool module_assertions
= argmatch (argv, argc, "-module-assertions", "--module-assertions", 15,
NULL, &skip_args);
- if (dumping && module_assertions)
+ if (will_dump_p () && module_assertions)
{
fputs ("Module assertions are not supported during dumping\n", stderr);
exit (1);
@@ -1419,7 +1602,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
/* egetenv is a pretty low-level facility, which may get called in
many circumstances; it seems flimsy to put off initializing it
until calling init_callproc. Do not do it when dumping. */
- if (! dumping)
+ if (!will_dump_p ())
set_initial_environment ();
#ifdef WINDOWSNT
@@ -1433,7 +1616,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
variables from the parent process without modifications from
Emacs. */
init_environment (argv);
- init_ntproc (dumping); /* must precede init_editfns. */
+ init_ntproc (will_dump_p ()); /* must precede init_editfns. */
#endif
/* AIX crashes are reported in system versions 3.2.3 and 3.2.4
@@ -1445,7 +1628,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#endif
/* Init buffer storage and default directory of main buffer. */
- init_buffer (initialized);
+ init_buffer ();
init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */
@@ -1620,6 +1803,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
syms_of_threads ();
syms_of_profiler ();
+ syms_of_pdumper ();
#ifdef HAVE_JSON
syms_of_json ();
@@ -1650,7 +1834,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
init_charset ();
/* 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 ();
@@ -1669,10 +1853,9 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
init_process_emacs (sockfd);
init_keyboard (); /* This too must precede init_sys_modes. */
- if (!noninteractive)
- init_display (); /* Determine terminal type. Calls init_sys_modes. */
+ init_display (); /* Determine terminal type. Calls init_sys_modes. */
#if HAVE_W32NOTIFY
- else
+ if (noninteractive)
init_crit (); /* w32notify.c needs this in batch mode. */
#endif /* HAVE_W32NOTIFY */
init_xdisp ();
@@ -1716,7 +1899,10 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
moncontrol (0);
#endif
- initialized = 1;
+ initialized = true;
+
+ if (dump_mode)
+ Vdump_mode = build_string (dump_mode);
/* Enter editor command loop. This never returns. */
Frecursive_edit ();
@@ -2166,8 +2352,11 @@ You must run Emacs in batch mode in order to dump it.
*/)
if (! noninteractive)
error ("Dumping Emacs works only in batch mode");
- if (!might_dump)
- error ("Emacs can be dumped only once");
+ if (dumped_with_unexec_p ())
+ error ("Emacs can be dumped using unexec only once");
+
+ if (definitely_will_not_unexec_p ())
+ error ("This Emacs instance was not started in temacs mode");
#if defined GNU_LINUX && !defined CANNOT_DUMP
@@ -2231,12 +2420,19 @@ You must run Emacs in batch mode in order to dump it.
*/)
#endif /* not WINDOWSNT */
#endif /* not SYSTEM_MALLOC and not HYBRID_MALLOC */
+ struct gflags old_gflags = gflags;
+ gflags.will_dump_ = false;
+ gflags.will_dump_with_unexec_ = false;
+ gflags.dumped_with_unexec_ = true;
+
alloc_unexec_pre ();
unexec (SSDATA (filename), !NILP (symfile) ? SSDATA (symfile) : 0);
alloc_unexec_post ();
+ gflags = old_gflags;
+
#ifdef WINDOWSNT
Vlibrary_cache = Qnil;
#endif
@@ -2250,6 +2446,7 @@ You must run Emacs in batch mode in order to dump it. */)
}
#endif /* not CANNOT_DUMP */
+
#if HAVE_SETLOCALE
/* Recover from setlocale (LC_ALL, ""). */
@@ -2585,7 +2782,7 @@ Don't rely on it for testing whether a feature you want
to use is available. */
Vsystem_configuration_features = build_string (EMACS_CONFIG_FEATURES);
DEFVAR_BOOL ("noninteractive", noninteractive1,
- doc: /* Non-nil means Emacs is running without interactive
terminal. */);
+ doc: /* Non-nil means Emacs is running without interactive
terminal. */);
DEFVAR_LISP ("kill-emacs-hook", Vkill_emacs_hook,
doc: /* Hook run when `kill-emacs' is called.
@@ -2670,6 +2867,9 @@ component .BUILD is present. This is now stored
separately in
doc: /* Address of mailing list for GNU Emacs bugs. */);
Vreport_emacs_bug_address = build_string (emacs_bugreport);
+ DEFVAR_LISP ("dump-mode", Vdump_mode,
+ doc: /* Non-nil when Emacs is dumping itself. */);
+
DEFVAR_LISP ("dynamic-library-alist", Vdynamic_library_alist,
doc: /* Alist of dynamic libraries vs external files implementing them.
Each element is a list (LIBRARY FILE...), where the car is a symbol
diff --git a/src/eval.c b/src/eval.c
index 2847895..b094fc2 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "dispextern.h"
#include "buffer.h"
+#include "pdumper.h"
/* CACHEABLE is ordinarily nothing, except it is 'volatile' if
necessary to cajole GCC into not warning incorrectly that a
@@ -89,10 +90,6 @@ static EMACS_INT when_entered_debugger;
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
-/* If non-nil, Lisp code must not be run since some part of Emacs is in
- an inconsistent state. Currently unused. */
-Lisp_Object inhibit_lisp_code;
-
/* These would ordinarily be static, but they need to be visible to GDB. */
bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
@@ -235,6 +232,8 @@ 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)
{
@@ -247,15 +246,20 @@ backtrace_thread_next (struct thread_state *tstate, union
specbinding *pdl)
void
init_eval_once (void)
{
- enum { size = 50 };
- union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
- specpdl_size = size;
- specpdl = specpdl_ptr = pdlvec + 1;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
max_lisp_eval_depth = 800;
-
Vrun_hooks = Qnil;
+ pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
+}
+
+static void
+init_eval_once_for_pdumper (void)
+{
+ enum { size = 50 };
+ union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl);
+ specpdl_size = size;
+ specpdl = specpdl_ptr = pdlvec + 1;
}
/* static struct handler handlerlist_sentinel; */
@@ -2084,7 +2088,7 @@ it defines a macro. */)
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p () && !will_bootstrap_p ())
error ("Attempt to autoload %s while preparing to dump",
SDATA (SYMBOL_NAME (funname)));
@@ -4002,7 +4006,7 @@ mark_specpdl (union specbinding *first, union specbinding
*ptr)
for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
- {
+ {
case SPECPDL_UNWIND:
mark_object (specpdl_arg (pdl));
break;
@@ -4039,7 +4043,7 @@ mark_specpdl (union specbinding *first, union specbinding
*ptr)
case SPECPDL_UNWIND_PTR:
case SPECPDL_UNWIND_INT:
- case SPECPDL_UNWIND_VOID:
+ case SPECPDL_UNWIND_VOID:
break;
default:
@@ -4225,8 +4229,6 @@ alist of active lexical bindings. */);
staticpro (&Vsignaling_function);
Vsignaling_function = Qnil;
- inhibit_lisp_code = Qnil;
-
DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
Funintern (Qcatch_all_memory_full, Qnil);
diff --git a/src/filelock.c b/src/filelock.c
index 81d98f3..64310f5 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -171,13 +171,10 @@ get_boot_time (void)
}
#if defined (BOOT_TIME)
-#ifndef CANNOT_DUMP
- /* The utmp routines maintain static state.
- Don't touch that state unless we are initialized,
- since it might not survive dumping. */
- if (! initialized)
+ /* The utmp routines maintain static state. Don't touch that state
+ if we are going to dump, since it might not survive dumping. */
+ if (will_dump_p ())
return boot_time;
-#endif /* not CANNOT_DUMP */
/* Try to get boot time from utmp before wtmp,
since utmp is typically much smaller than wtmp.
@@ -666,7 +663,7 @@ lock_file (Lisp_Object fn)
/* Don't do locking while dumping Emacs.
Uncompressing wtmp files uses call-process, which does not work
in an uninitialized Emacs. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p ())
return;
orig_fn = fn;
diff --git a/src/fingerprint-dummy.c b/src/fingerprint-dummy.c
new file mode 100644
index 0000000..295654a
--- /dev/null
+++ b/src/fingerprint-dummy.c
@@ -0,0 +1,24 @@
+/* Dummy fingerprint
+
+Copyright (C) 2016 Free Software Foundation,
+Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#include "fingerprint.h"
+
+/* Dummy fingerprint to use as hash input. */
+const uint8_t fingerprint[32] = { 0 };
diff --git a/src/fingerprint.h b/src/fingerprint.h
new file mode 100644
index 0000000..b48d40f
--- /dev/null
+++ b/src/fingerprint.h
@@ -0,0 +1,32 @@
+/* Header file for the Emacs build fingerprint.
+
+Copyright (C) 2016 Free Software Foundation,
+Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_FINGERPRINT_H
+#define EMACS_FINGERPRINT_H
+
+#include <stdint.h>
+
+/* We generate fingerprint.c and fingerprint.o from all the sources in
+ Emacs. This way, we have a unique value that we can use to pair
+ data files (like a portable dump image) with a specific build of
+ Emacs. */
+extern const uint8_t fingerprint[32];
+
+#endif
diff --git a/src/fns.c b/src/fns.c
index 6fcb38e..1ac6032 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2949,7 +2949,7 @@ suppressed. */)
/* This is to make sure that loadup.el gives a clear picture
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ if (will_dump_p () && !will_bootstrap_p ())
error ("(require %s) while preparing to dump",
SDATA (SYMBOL_NAME (feature)));
@@ -3648,10 +3648,6 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t
length,
if a `:linear-search t' argument is given to make-hash-table. */
-/* The list of all weak hash tables. Don't staticpro this one. */
-
-static struct Lisp_Hash_Table *weak_hash_tables;
-
/***********************************************************************
Utilities
@@ -3866,7 +3862,7 @@ hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
`equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static EMACS_UINT
+EMACS_UINT
hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
return sxhash (key, 0);
@@ -3876,7 +3872,7 @@ hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
`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) || BIGNUMP (key))
@@ -3984,6 +3980,7 @@ make_hash_table (struct hash_table_test test, EMACS_INT
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. */
@@ -3995,13 +3992,6 @@ make_hash_table (struct hash_table_test test, EMACS_INT
size,
eassert (HASH_TABLE_P (table));
eassert (XHASH_TABLE (table) == h);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (! NILP (weak))
- {
- h->next_weak = weak_hash_tables;
- weak_hash_tables = h;
- }
-
return table;
}
@@ -4023,13 +4013,6 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
h2->index = Fcopy_sequence (h1->index);
XSET_HASH_TABLE (table, h2);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (!NILP (h2->weak))
- {
- h2->next_weak = h1->next_weak;
- h1->next_weak = h2;
- }
-
return table;
}
@@ -4115,6 +4098,43 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
}
}
+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_fixnum (hash_code));
+ }
+
+ /* Reset the index so that any slot we don't fill below is marked
+ invalid. */
+ 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 = 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
@@ -4126,6 +4146,8 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key,
EMACS_UINT *hash)
EMACS_UINT hash_code;
ptrdiff_t start_of_bucket, i;
+ hash_rehash_if_needed (h);
+
hash_code = h->test.hashfn (&h->test, key);
eassert ((hash_code & ~INTMASK) == 0);
if (hash)
@@ -4154,6 +4176,8 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key,
Lisp_Object value,
{
ptrdiff_t start_of_bucket, i;
+ hash_rehash_if_needed (h);
+
eassert ((hash & ~INTMASK) == 0);
/* Increment count after resizing because resizing may fail. */
@@ -4187,6 +4211,8 @@ hash_remove_from_table (struct Lisp_Hash_Table *h,
Lisp_Object key)
ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
ptrdiff_t prev = -1;
+ hash_rehash_if_needed (h);
+
for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
0 <= i;
i = HASH_NEXT (h, i))
@@ -4255,7 +4281,7 @@ hash_clear (struct Lisp_Hash_Table *h)
!REMOVE_ENTRIES_P means mark entries that are in use. Value is
true if anything was marked. */
-static bool
+bool
sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
{
ptrdiff_t n = gc_asize (h->index);
@@ -4263,12 +4289,14 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool
remove_entries_p)
for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
{
- /* Follow collision chain, removing entries that
- don't survive this garbage collection. */
+ /* Follow collision chain, removing entries that don't survive
+ this garbage collection. It's okay if hash_rehash_needed_p
+ (h) is true, since we're operating entirely on the cached
+ hash values. */
ptrdiff_t prev = -1;
ptrdiff_t next;
for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next)
- {
+ {
bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
bool remove_p;
@@ -4303,10 +4331,11 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool
remove_entries_p)
/* Clear key, value, and hash. */
set_hash_key_slot (h, i, Qnil);
set_hash_value_slot (h, i, Qnil);
- set_hash_hash_slot (h, i, Qnil);
+ set_hash_hash_slot (h, i, Qnil);
- h->count--;
- }
+ eassert (h->count != 0);
+ h->count += h->count > 0 ? -1 : 1;
+ }
else
{
prev = i;
@@ -4320,13 +4349,13 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool
remove_entries_p)
if (!key_known_to_survive_p)
{
mark_object (HASH_KEY (h, i));
- marked = 1;
+ marked = true;
}
if (!value_known_to_survive_p)
{
mark_object (HASH_VALUE (h, i));
- marked = 1;
+ marked = true;
}
}
}
@@ -4336,55 +4365,6 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool
remove_entries_p)
return marked;
}
-/* Remove elements from weak hash tables that don't survive the
- current garbage collection. Remove weak tables that don't survive
- from Vweak_hash_tables. Called from gc_sweep. */
-
-NO_INLINE /* For better stack traces */
-void
-sweep_weak_hash_tables (void)
-{
- struct Lisp_Hash_Table *h, *used, *next;
- bool marked;
-
- /* Mark all keys and values that are in use. Keep on marking until
- there is no more change. This is necessary for cases like
- value-weak table A containing an entry X -> Y, where Y is used in a
- key-weak table B, Z -> Y. If B comes after A in the list of weak
- tables, X -> Y might be removed from A, although when looking at B
- one finds that it shouldn't. */
- do
- {
- marked = 0;
- for (h = weak_hash_tables; h; h = h->next_weak)
- {
- if (h->header.size & ARRAY_MARK_FLAG)
- marked |= sweep_weak_table (h, 0);
- }
- }
- while (marked);
-
- /* Remove tables and entries that aren't used. */
- for (h = weak_hash_tables, used = NULL; h; h = next)
- {
- next = h->next_weak;
-
- if (h->header.size & ARRAY_MARK_FLAG)
- {
- /* TABLE is marked as used. Sweep its contents. */
- if (h->count > 0)
- sweep_weak_table (h, 1);
-
- /* Add table to the list of used weak hash tables. */
- h->next_weak = used;
- used = h;
- }
- }
-
- weak_hash_tables = used;
-}
-
-
/***********************************************************************
Hash Code Computation
@@ -5294,6 +5274,7 @@ disregarding any coding systems. If nil, use the current
buffer. */ )
}
+
void
syms_of_fns (void)
{
diff --git a/src/font.c b/src/font.c
index 3fc77a1..4ca4494 100644
--- a/src/font.c
+++ b/src/font.c
@@ -38,6 +38,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "fontset.h"
#include "font.h"
#include "termhooks.h"
+#include "pdumper.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -5309,9 +5310,10 @@ syms_of_font (void)
sort_shift_bits[FONT_SIZE_INDEX] = 16;
sort_shift_bits[FONT_WIDTH_INDEX] = 23;
/* Note that the other elements in sort_shift_bits are not used. */
+ PDUMPER_REMEMBER_SCALAR (sort_shift_bits);
- staticpro (&font_charset_alist);
font_charset_alist = Qnil;
+ staticpro (&font_charset_alist);
DEFSYM (Qopentype, "opentype");
@@ -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);
- staticpro (&Vfont_log_deferred);
Vfont_log_deferred = make_nil_vector (3);
+ staticpro (&Vfont_log_deferred);
#if 0
#ifdef HAVE_LIBOTF
diff --git a/src/fontset.c b/src/fontset.c
index 55a3f78..2729fae 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -39,6 +39,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
#include "font.h"
+#include "pdumper.h"
/* FONTSET
@@ -2127,6 +2128,7 @@ syms_of_fontset (void)
build_pure_c_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default"));
ASET (Vfontset_table, 0, Vdefault_fontset);
next_fontset_id = 1;
+ PDUMPER_REMEMBER_SCALAR (next_fontset_id);
auto_fontset_alist = Qnil;
staticpro (&auto_fontset_alist);
diff --git a/src/frame.c b/src/frame.c
index 6d93abd..aa1a15f 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -53,6 +53,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#ifdef USE_X_TOOLKIT
#include "widget.h"
#endif
+#include "pdumper.h"
/* The currently selected frame. */
Lisp_Object selected_frame;
@@ -1051,10 +1052,7 @@ make_initial_frame (void)
Lisp_Object frame;
eassert (initial_kboard);
-
- /* The first call must initialize Vframe_list. */
- if (! (NILP (Vframe_list) || CONSP (Vframe_list)))
- Vframe_list = Qnil;
+ eassert (NILP (Vframe_list) || CONSP (Vframe_list));
terminal = init_initial_terminal ();
@@ -5626,6 +5624,26 @@ make_monitor_attribute_list (struct MonitorInfo
*monitors,
Initialization
***********************************************************************/
+static void init_frame_once_for_pdumper (void);
+
+void
+init_frame_once (void)
+{
+ staticpro (&Vframe_list);
+ staticpro (&selected_frame);
+ PDUMPER_IGNORE (last_nonminibuf_frame);
+ Vframe_list = Qnil;
+ selected_frame = Qnil;
+ pdumper_do_now_and_after_load (init_frame_once_for_pdumper);
+}
+
+static void
+init_frame_once_for_pdumper (void)
+{
+ PDUMPER_RESET_LV (Vframe_list, Qnil);
+ PDUMPER_RESET_LV (selected_frame, Qnil);
+}
+
void
syms_of_frame (void)
{
@@ -6107,8 +6125,6 @@ making the child frame unresponsive to user actions, the
default is to
iconify the top level frame instead. */);
iconify_child_frame = Qiconify_top_level;
- staticpro (&Vframe_list);
-
defsubr (&Sframep);
defsubr (&Sframe_live_p);
defsubr (&Swindow_system);
diff --git a/src/fringe.c b/src/fringe.c
index 74f41f0..335a6eb 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -30,6 +30,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "blockinput.h"
#include "termhooks.h"
+#include "pdumper.h"
/* Fringe bitmaps are represented in three different ways:
@@ -1739,12 +1740,18 @@ mark_fringe_data (void)
/* Initialize this module when Emacs starts. */
+static void init_fringe_once_for_pdumper (void);
+
void
init_fringe_once (void)
{
- int bt;
+ pdumper_do_now_and_after_load (init_fringe_once_for_pdumper);
+}
- for (bt = NO_FRINGE_BITMAP + 1; bt < MAX_STANDARD_FRINGE_BITMAPS; bt++)
+static void
+init_fringe_once_for_pdumper (void)
+{
+ for (int bt = NO_FRINGE_BITMAP + 1; bt < MAX_STANDARD_FRINGE_BITMAPS; bt++)
init_fringe_bitmap (bt, &standard_bitmaps[bt], 1);
}
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index 314fa5b..7c18e04 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -26,6 +26,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "blockinput.h"
#include "font.h"
#include "ftfont.h"
+#include "pdumper.h"
/* FTCR font driver. */
@@ -282,6 +283,8 @@ ftcrfont_draw (struct glyph_string *s,
+static void syms_of_ftcrfont_for_pdumper (void);
+
struct font_driver const ftcrfont_driver =
{
.type = LISPSYM_INITIALLY (Qftcr),
@@ -317,5 +320,11 @@ syms_of_ftcrfont (void)
abort ();
DEFSYM (Qftcr, "ftcr");
+ pdumper_do_now_and_after_load (syms_of_ftcrfont_for_pdumper);
+}
+
+static void
+syms_of_ftcrfont_for_pdumper (void)
+{
register_font_driver (&ftcrfont_driver, NULL);
}
diff --git a/src/ftfont.c b/src/ftfont.c
index f5a225b..bcc3460 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "ftfont.h"
+#include "pdumper.h"
static struct font_driver const ftfont_driver;
@@ -2701,6 +2702,8 @@ ftfont_combining_capability (struct font *font)
#endif
}
+static void syms_of_ftfont_for_pdumper (void);
+
static struct font_driver const ftfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -2752,5 +2755,12 @@ syms_of_ftfont (void)
staticpro (&ft_face_cache);
ft_face_cache = Qnil;
+ pdumper_do_now_and_after_load (syms_of_ftfont_for_pdumper);
+}
+
+static void
+syms_of_ftfont_for_pdumper (void)
+{
+ PDUMPER_RESET_LV (ft_face_cache, Qnil);
register_font_driver (&ftfont_driver, NULL);
}
diff --git a/src/ftxfont.c b/src/ftxfont.c
index 726e0a8..f9a69c3 100644
--- a/src/ftxfont.c
+++ b/src/ftxfont.c
@@ -28,6 +28,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "blockinput.h"
#include "font.h"
+#include "pdumper.h"
/* FTX font driver. */
@@ -339,6 +340,8 @@ ftxfont_end_for_frame (struct frame *f)
+static void syms_of_ftxfont_for_pdumper (void);
+
struct font_driver const ftxfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -373,5 +376,11 @@ void
syms_of_ftxfont (void)
{
DEFSYM (Qftx, "ftx");
+ pdumper_do_now_and_after_load (syms_of_ftxfont_for_pdumper);
+}
+
+static void
+syms_of_ftxfont_for_pdumper (void)
+{
register_font_driver (&ftxfont_driver, NULL);
}
diff --git a/src/gmalloc.c b/src/gmalloc.c
index c19885d..b6a96d5 100644
--- a/src/gmalloc.c
+++ b/src/gmalloc.c
@@ -76,7 +76,6 @@ extern void *(*__morecore) (ptrdiff_t);
#ifdef HYBRID_MALLOC
# include "sheap.h"
-# define DUMPED bss_sbrk_did_unexec
#endif
#ifdef __cplusplus
@@ -1508,7 +1507,7 @@ static void *
gdefault_morecore (ptrdiff_t increment)
{
#ifdef HYBRID_MALLOC
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
{
return bss_sbrk (increment);
}
@@ -1726,6 +1725,8 @@ extern int posix_memalign (void **memptr, size_t
alignment, size_t size);
static bool
allocated_via_gmalloc (void *ptr)
{
+ if (!__malloc_initialized)
+ return false;
size_t block = BLOCK (ptr);
size_t blockmax = _heaplimit - 1;
return block <= blockmax && _heapinfo[block].busy.type != 0;
@@ -1737,7 +1738,7 @@ allocated_via_gmalloc (void *ptr)
void *
hybrid_malloc (size_t size)
{
- if (DUMPED)
+ if (definitely_will_not_unexec_p ())
return malloc (size);
return gmalloc (size);
}
@@ -1745,7 +1746,7 @@ hybrid_malloc (size_t size)
void *
hybrid_calloc (size_t nmemb, size_t size)
{
- if (DUMPED)
+ if (definitely_will_not_unexec_p ())
return calloc (nmemb, size);
return gcalloc (nmemb, size);
}
@@ -1763,7 +1764,7 @@ hybrid_free (void *ptr)
void *
hybrid_aligned_alloc (size_t alignment, size_t size)
{
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
return galigned_alloc (alignment, size);
/* The following is copied from alloc.c */
#ifdef HAVE_ALIGNED_ALLOC
@@ -1786,7 +1787,7 @@ hybrid_realloc (void *ptr, size_t size)
return hybrid_malloc (size);
if (!allocated_via_gmalloc (ptr))
return realloc (ptr, size);
- if (!DUMPED)
+ if (!definitely_will_not_unexec_p ())
return grealloc (ptr, size);
/* The dumped emacs is trying to realloc storage allocated before
diff --git a/src/gnutls.c b/src/gnutls.c
index 1fe20d7..d0cb28d 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "gnutls.h"
#include "coding.h"
#include "buffer.h"
+#include "pdumper.h"
#if GNUTLS_VERSION_NUMBER >= 0x030014
# define HAVE_GNUTLS_X509_SYSTEM_TRUST
@@ -2626,6 +2627,7 @@ syms_of_gnutls (void)
);
#ifdef HAVE_GNUTLS
gnutls_global_initialized = 0;
+ PDUMPER_IGNORE (gnutls_global_initialized);
DEFSYM (Qgnutls_code, "gnutls-code");
DEFSYM (Qgnutls_anon, "gnutls-anon");
diff --git a/src/image.c b/src/image.c
index 2fae105..2f0b63c 100644
--- a/src/image.c
+++ b/src/image.c
@@ -46,6 +46,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "termhooks.h"
#include "font.h"
+#include "pdumper.h"
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
@@ -10003,7 +10004,9 @@ void
syms_of_image (void)
{
/* Initialize this only once; it will be reset before dumping. */
+ /* The portable dumper will just leave it NULL, so no need to reset. */
image_types = NULL;
+ PDUMPER_IGNORE (image_types);
/* Must be defined now because we're going to update it below, while
defining the supported image types. */
diff --git a/src/insdel.c b/src/insdel.c
index 08f04d3..a6f006a 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "window.h"
#include "region-cache.h"
+#include "pdumper.h"
static void insert_from_string_1 (Lisp_Object, ptrdiff_t, ptrdiff_t, ptrdiff_t,
ptrdiff_t, bool, bool);
@@ -1927,6 +1928,14 @@ prepare_to_modify_buffer_1 (ptrdiff_t start, ptrdiff_t
end,
if (!NILP (BVAR (current_buffer, read_only)))
Fbarf_if_buffer_read_only (temp);
+ /* If we're about to modify a buffer the contents of which come from
+ a dump file, copy the contents to private storage first so we
+ don't take a COW fault on the buffer text and keep it around
+ forever. */
+ if (pdumper_object_p (BEG_ADDR))
+ enlarge_buffer_text (current_buffer, 0);
+ eassert (!pdumper_object_p (BEG_ADDR));
+
run_undoable_change();
bset_redisplay (current_buffer);
diff --git a/src/intervals.h b/src/intervals.h
index 3cee788..9c5adf3 100644
--- a/src/intervals.h
+++ b/src/intervals.h
@@ -29,7 +29,6 @@ INLINE_HEADER_BEGIN
struct interval
{
/* The first group of entries deal with the tree structure. */
-
ptrdiff_t total_length; /* Length of myself and both children. */
ptrdiff_t position; /* Cache of interval's character position. */
/* This field is usually updated
diff --git a/src/keyboard.c b/src/keyboard.c
index 9e38bb2..2d6fa91 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -68,6 +68,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <ignore-value.h>
+#include "pdumper.h"
+
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -10977,6 +10979,8 @@ static const struct event_head head_table[] = {
{SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)}
};
+static void syms_of_keyboard_for_pdumper (void);
+
void
syms_of_keyboard (void)
{
@@ -10987,9 +10991,11 @@ syms_of_keyboard (void)
staticpro (&Vlispy_mouse_stem);
regular_top_level_message = build_pure_c_string ("Back to top level");
+ staticpro (®ular_top_level_message);
#ifdef HAVE_STACK_OVERFLOW_HANDLING
recover_top_level_message
= build_pure_c_string ("Re-entering top level after C stack overflow");
+ staticpro (&recover_top_level_message);
#endif
DEFVAR_LISP ("internal--top-level-message", Vinternal__top_level_message,
doc: /* Message displayed by `normal-top-level'. */);
@@ -11828,7 +11834,38 @@ 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",
@@ -11940,8 +11977,8 @@ mark_kboards (void)
for (kb = all_kboards; kb; kb = kb->next_kboard)
{
if (kb->kbd_macro_buffer)
- for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
- mark_object (*p);
+ for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
+ mark_object (*p);
mark_object (KVAR (kb, Voverriding_terminal_local_map));
mark_object (KVAR (kb, Vlast_command));
mark_object (KVAR (kb, Vreal_last_command));
diff --git a/src/lisp.h b/src/lisp.h
index faf5a4a..5c48905 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -527,6 +527,7 @@ enum Lisp_Type
/* 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
};
@@ -623,16 +624,110 @@ extern void char_table_set (Lisp_Object, int,
Lisp_Object);
extern _Noreturn void wrong_type_argument (Lisp_Object, Lisp_Object);
-#ifdef CANNOT_DUMP
-enum { might_dump = false };
-#elif defined DOUG_LEA_MALLOC
/* Defined in emacs.c. */
-extern bool might_dump;
-#endif
-/* True means Emacs has already been initialized.
- Used during startup to detect startup of dumped Emacs. */
+
+/* Set after Emacs has started up the first time.
+ Prevents reinitialization of the Lisp world and keymaps on
+ subsequent starts. */
extern bool initialized;
+extern struct gflags {
+ /* True means this Emacs instance was born to dump. */
+#if defined (HAVE_PDUMPER) || !defined (CANNOT_DUMP)
+ bool will_dump_ : 1;
+ bool will_bootstrap_ : 1;
+#endif
+#if defined (HAVE_PDUMPER)
+ /* Set in an Emacs process that will likely dump with pdumper; all
+ Emacs processes may dump with pdumper, however. */
+ bool will_dump_with_pdumper_ : 1;
+ /* Set in an Emacs process that has been restored from a portable
+ dump. */
+ bool dumped_with_pdumper_ : 1;
+#endif
+#ifndef CANNOT_DUMP
+ bool will_dump_with_unexec_ : 1;
+ /* Set in an Emacs process that has been restored from an unexec
+ dump. */
+ bool dumped_with_unexec_ : 1;
+ /* We promise not to unexec: useful for hybrid malloc. */
+ bool will_not_unexec_ : 1;
+#endif
+} gflags;
+
+INLINE bool
+will_dump_p (void)
+{
+#if HAVE_PDUMPER || !defined (CANNOT_DUMP)
+ return gflags.will_dump_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_bootstrap_p (void)
+{
+#if HAVE_PDUMPER || !defined (CANNOT_DUMP)
+ return gflags.will_bootstrap_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_dump_with_pdumper_p (void)
+{
+#if HAVE_PDUMPER
+ return gflags.will_dump_with_pdumper_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+dumped_with_pdumper_p (void)
+{
+#if HAVE_PDUMPER
+ return gflags.dumped_with_pdumper_;
+#else
+ return false;
+#endif
+}
+
+INLINE bool
+will_dump_with_unexec_p (void)
+{
+#ifdef CANNOT_DUMP
+ return false;
+#else
+ return gflags.will_dump_with_unexec_;
+#endif
+}
+
+INLINE bool
+dumped_with_unexec_p (void)
+{
+#ifdef CANNOT_DUMP
+ return false;
+#else
+ return gflags.dumped_with_unexec_;
+#endif
+}
+
+/* This function is the opposite of will_dump_with_unexec_p(), except
+ that it returns false before main runs. It's important to use
+ gmalloc for any pre-main allocations if we're going to unexec. */
+INLINE bool
+definitely_will_not_unexec_p (void)
+{
+#ifdef CANNOT_DUMP
+ return true;
+#else
+ return gflags.will_not_unexec_;
+#endif
+}
+
/* Defined in floatfns.c. */
extern double extract_float (Lisp_Object);
@@ -862,6 +957,19 @@ typedef EMACS_UINT Lisp_Word_tag;
# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true
#endif
+/* True if N is a power of 2. N should be positive. */
+
+#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
+
+/* Return X rounded to the next multiple of Y. Y should be positive,
+ and Y - 1 + X should not overflow. Arguments should not have side
+ effects, as they are evaluated more than once. Tune for Y being a
+ power of 2. */
+
+#define ROUNDUP(x, y) (POWER_OF_2 (y) \
+ ? ((y) - 1 + (x)) & ~ ((y) - 1) \
+ : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
+
#include "globals.h"
/* Header of vector-like objects. This documents the layout constraints on
@@ -1568,7 +1676,7 @@ CHECK_VECTOR (Lisp_Object x)
/* A pseudovector is like a vector, but has other non-Lisp components. */
INLINE enum pvec_type
-PSEUDOVECTOR_TYPE (struct Lisp_Vector *v)
+PSEUDOVECTOR_TYPE (const struct Lisp_Vector *v)
{
ptrdiff_t size = v->header.size;
return (size & PSEUDOVECTOR_FLAG
@@ -1578,7 +1686,7 @@ PSEUDOVECTOR_TYPE (struct Lisp_Vector *v)
/* Can't be used with PVEC_NORMAL_VECTOR. */
INLINE bool
-PSEUDOVECTOR_TYPEP (union vectorlike_header *a, enum pvec_type code)
+PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code)
{
/* We don't use PSEUDOVECTOR_TYPE here so as to avoid a shift
* operation when `code' is known. */
@@ -2168,6 +2276,12 @@ struct hash_table_test
struct Lisp_Hash_Table
{
+ /* Change pdumper.c if you change the fields here.
+
+ IMPORTANT!!!!!!!
+
+ Call hash_rehash_if_needed() before accessing. */
+
/* This is for Lisp; the hash table code does not refer to it. */
union vectorlike_header header;
@@ -2224,8 +2338,9 @@ struct Lisp_Hash_Table
/* 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;
@@ -2250,32 +2365,47 @@ XHASH_TABLE (Lisp_Object a)
/* Value is the key part of entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_KEY (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_KEY (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->key_and_value, 2 * idx);
}
/* Value is the value part of entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_VALUE (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_VALUE (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->key_and_value, 2 * idx + 1);
}
/* Value is the hash code computed for entry IDX in hash table H. */
INLINE Lisp_Object
-HASH_HASH (struct Lisp_Hash_Table *h, ptrdiff_t idx)
+HASH_HASH (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
return AREF (h->hash, idx);
}
/* Value is the size of hash table H. */
INLINE ptrdiff_t
-HASH_TABLE_SIZE (struct Lisp_Hash_Table *h)
+HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h)
{
return ASIZE (h->next);
}
+void hash_table_rehash (struct Lisp_Hash_Table *h);
+
+INLINE bool
+hash_rehash_needed_p (const struct Lisp_Hash_Table *h)
+{
+ return h->count < 0;
+}
+
+INLINE void
+hash_rehash_if_needed (struct Lisp_Hash_Table *h)
+{
+ if (hash_rehash_needed_p (h))
+ hash_table_rehash (h);
+}
+
/* Default size for hash tables if not specified. */
enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 };
@@ -2441,6 +2571,9 @@ struct Lisp_Finalizer
struct Lisp_Finalizer *next;
} GCALIGNED_STRUCT;
+extern struct Lisp_Finalizer finalizers;
+extern struct Lisp_Finalizer doomed_finalizers;
+
INLINE bool
FINALIZERP (Lisp_Object x)
{
@@ -2895,6 +3028,20 @@ CHECK_INTEGER (Lisp_Object x)
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.
@@ -2923,7 +3070,8 @@ CHECK_INTEGER (Lisp_Object x)
/* 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) \
- 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}}; \
@@ -3169,6 +3317,11 @@ extern Lisp_Object Vascii_canon_table;
/* Call staticpro (&var) to protect static variable `var'. */
void staticpro (Lisp_Object *);
+
+enum { NSTATICS = 2048 };
+extern Lisp_Object *staticvec[NSTATICS];
+extern int staticidx;
+
/* Forward declarations for prototypes. */
struct window;
@@ -3416,12 +3569,14 @@ 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);
+EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key);
+EMACS_UINT hashfn_equal (struct hash_table_test *ht, Lisp_Object key);
Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
- Lisp_Object, bool);
+ Lisp_Object, bool);
ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
EMACS_UINT);
@@ -3592,6 +3747,12 @@ 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);
@@ -3601,6 +3762,21 @@ extern Lisp_Object list5 (Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object,
enum constype {CONSTYPE_HEAP, CONSTYPE_PURE};
extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...);
+enum gc_root_type {
+ GC_ROOT_STATICPRO,
+ GC_ROOT_BUFFER_LOCAL_DEFAULT,
+ GC_ROOT_BUFFER_LOCAL_NAME,
+ GC_ROOT_C_SYMBOL
+};
+
+struct gc_root_visitor {
+ void (*visit)(Lisp_Object *root_ptr,
+ enum gc_root_type type,
+ void *data);
+ void *data;
+};
+extern void visit_static_gc_roots (struct gc_root_visitor visitor);
+
/* Build a frequently used 2/3/4-integer lists. */
INLINE Lisp_Object
@@ -3629,6 +3805,13 @@ extern Lisp_Object make_string (const char *, ptrdiff_t);
extern Lisp_Object make_formatted_string (char *, const char *, ...)
ATTRIBUTE_FORMAT_PRINTF (2, 3);
extern Lisp_Object make_unibyte_string (const char *, ptrdiff_t);
+extern ptrdiff_t vectorlike_nbytes (const union vectorlike_header *hdr);
+
+INLINE ptrdiff_t
+vector_nbytes (const struct Lisp_Vector *v)
+{
+ return vectorlike_nbytes (&v->header);
+}
/* Make unibyte string from C string when the length isn't known. */
@@ -3824,7 +4007,7 @@ extern Lisp_Object string_to_number (char const *, int,
ptrdiff_t *);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
Lisp_Object);
extern void dir_warning (const char *, Lisp_Object);
-extern void init_obarray (void);
+extern void init_obarray_once (void);
extern void init_lread (void);
extern void syms_of_lread (void);
@@ -3989,6 +4172,7 @@ 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);
@@ -4017,7 +4201,7 @@ extern bool overlay_touches_p (ptrdiff_t);
extern Lisp_Object other_buffer_safely (Lisp_Object);
extern Lisp_Object get_truename_buffer (Lisp_Object);
extern void init_buffer_once (void);
-extern void init_buffer (int);
+extern void init_buffer (void);
extern void syms_of_buffer (void);
extern void keys_of_buffer (void);
@@ -4160,6 +4344,7 @@ extern void store_in_alist (Lisp_Object *, Lisp_Object,
Lisp_Object);
extern Lisp_Object do_switch_frame (Lisp_Object, int, int, Lisp_Object);
extern Lisp_Object get_frame_param (struct frame *, Lisp_Object);
extern void frames_discard_buffer (Lisp_Object);
+extern void init_frame_once (void);
extern void syms_of_frame (void);
/* Defined in emacs.c. */
diff --git a/src/lread.c b/src/lread.c
index 5a595f2..dde9cce 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -42,6 +42,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "systime.h"
#include "termhooks.h"
#include "blockinput.h"
+#include "pdumper.h"
#include <c-ctype.h>
#ifdef MSDOS
@@ -1969,7 +1970,7 @@ readevalloop (Lisp_Object readcharfun,
? Qnil : list1 (Qt)));
/* Try to ensure sourcename is a truename, except whilst preloading. */
- if (NILP (Vpurify_flag)
+ if (!will_dump_p ()
&& !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
&& !NILP (Ffboundp (Qfile_truename)))
sourcename = call1 (Qfile_truename, sourcename) ;
@@ -4373,7 +4374,7 @@ OBARRAY defaults to the value of `obarray'. */)
#define OBARRAY_SIZE 15121
void
-init_obarray (void)
+init_obarray_once (void)
{
Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0));
initial_obarray = Vobarray;
@@ -4394,12 +4395,15 @@ init_obarray (void)
make_symbol_constant (Qt);
XSYMBOL (Qt)->u.s.declared_special = true;
- /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
+ /* Qt is correct even if not dumping. loadup.el will set to nil at end. */
Vpurify_flag = Qt;
DEFSYM (Qvariable_documentation, "variable-documentation");
}
+
+int ndefsubr;
+
void
defsubr (union Aligned_Lisp_Subr *aname)
{
@@ -4409,6 +4413,7 @@ defsubr (union Aligned_Lisp_Subr *aname)
XSETPVECTYPE (sname, PVEC_SUBR);
XSETSUBR (tem, sname);
set_symbol_function (sym, tem);
+ ++ndefsubr;
}
#ifdef NOTDEF /* Use fset in subr.el now! */
@@ -4526,11 +4531,9 @@ load_path_check (Lisp_Object lpath)
are running uninstalled.
Uses the following logic:
- If CANNOT_DUMP:
- If Vinstallation_directory is not nil (ie, running uninstalled),
- use PATH_DUMPLOADSEARCH (ie, build path). Else use PATH_LOADSEARCH.
- The remainder is what happens when dumping works:
- If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH.
+ If !will_dump: Use PATH_LOADSEARCH.
+ The remainder is what happens when dumping is about to happen:
+ If dumping, just use PATH_DUMPLOADSEARCH.
Otherwise use PATH_LOADSEARCH.
If !initialized, then just return PATH_DUMPLOADSEARCH.
@@ -4553,131 +4556,109 @@ load_path_check (Lisp_Object lpath)
static Lisp_Object
load_path_default (void)
{
+ if (will_dump_p ())
+ /* PATH_DUMPLOADSEARCH is the lisp dir in the source directory.
+ We used to add ../lisp (ie the lisp dir in the build
+ directory) at the front here, but that should not be
+ necessary, since in out of tree builds lisp/ is empty, save
+ for Makefile. */
+ return decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
+
Lisp_Object lpath = Qnil;
- const char *normal;
+ const char *normal = PATH_LOADSEARCH;
+ const char *loadpath = NULL;
-#ifdef CANNOT_DUMP
#ifdef HAVE_NS
- const char *loadpath = ns_load_path ();
+ loadpath = ns_load_path ();
#endif
- normal = PATH_LOADSEARCH;
- if (!NILP (Vinstallation_directory)) normal = PATH_DUMPLOADSEARCH;
-
-#ifdef HAVE_NS
lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
-#else
- lpath = decode_env_path (0, normal, 0);
-#endif
-
-#else /* !CANNOT_DUMP */
-
- normal = NILP (Vpurify_flag) ? PATH_LOADSEARCH : PATH_DUMPLOADSEARCH;
- if (initialized)
+ if (!NILP (Vinstallation_directory))
{
-#ifdef HAVE_NS
- const char *loadpath = ns_load_path ();
- lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
-#else
- lpath = decode_env_path (0, normal, 0);
-#endif
- if (!NILP (Vinstallation_directory))
+ Lisp_Object tem, tem1;
+
+ /* Add to the path the lisp subdir of the installation
+ dir, if it is accessible. Note: in out-of-tree builds,
+ this directory is empty save for Makefile. */
+ tem = Fexpand_file_name (build_string ("lisp"),
+ Vinstallation_directory);
+ tem1 = Ffile_accessible_directory_p (tem);
+ if (!NILP (tem1))
+ {
+ if (NILP (Fmember (tem, lpath)))
+ {
+ /* We are running uninstalled. The default load-path
+ points to the eventual installed lisp directories.
+ We should not use those now, even if they exist,
+ so start over from a clean slate. */
+ lpath = list1 (tem);
+ }
+ }
+ else
+ /* That dir doesn't exist, so add the build-time
+ Lisp dirs instead. */
{
- Lisp_Object tem, tem1;
+ Lisp_Object dump_path =
+ decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
+ lpath = nconc2 (lpath, dump_path);
+ }
- /* Add to the path the lisp subdir of the installation
- dir, if it is accessible. Note: in out-of-tree builds,
- this directory is empty save for Makefile. */
- tem = Fexpand_file_name (build_string ("lisp"),
+ /* Add site-lisp under the installation dir, if it exists. */
+ if (!no_site_lisp)
+ {
+ tem = Fexpand_file_name (build_string ("site-lisp"),
Vinstallation_directory);
tem1 = Ffile_accessible_directory_p (tem);
if (!NILP (tem1))
{
if (NILP (Fmember (tem, lpath)))
- {
- /* We are running uninstalled. The default load-path
- points to the eventual installed lisp directories.
- We should not use those now, even if they exist,
- so start over from a clean slate. */
- lpath = list1 (tem);
- }
- }
- else
- /* That dir doesn't exist, so add the build-time
- Lisp dirs instead. */
- {
- Lisp_Object dump_path =
- decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
- lpath = nconc2 (lpath, dump_path);
+ lpath = Fcons (tem, lpath);
}
+ }
- /* Add site-lisp under the installation dir, if it exists. */
- if (!no_site_lisp)
- {
- tem = Fexpand_file_name (build_string ("site-lisp"),
- Vinstallation_directory);
- tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
- {
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
- }
- }
+ /* If Emacs was not built in the source directory,
+ and it is run from where it was built, add to load-path
+ the lisp and site-lisp dirs under that directory. */
- /* If Emacs was not built in the source directory,
- and it is run from where it was built, add to load-path
- the lisp and site-lisp dirs under that directory. */
+ if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
+ {
+ Lisp_Object tem2;
+
+ tem = Fexpand_file_name (build_string ("src/Makefile"),
+ Vinstallation_directory);
+ tem1 = Ffile_exists_p (tem);
- if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
+ /* Don't be fooled if they moved the entire source tree
+ AFTER dumping Emacs. If the build directory is indeed
+ different from the source dir, src/Makefile.in and
+ src/Makefile will not be found together. */
+ tem = Fexpand_file_name (build_string ("src/Makefile.in"),
+ Vinstallation_directory);
+ tem2 = Ffile_exists_p (tem);
+ if (!NILP (tem1) && NILP (tem2))
{
- Lisp_Object tem2;
-
- tem = Fexpand_file_name (build_string ("src/Makefile"),
- Vinstallation_directory);
- tem1 = Ffile_exists_p (tem);
-
- /* Don't be fooled if they moved the entire source tree
- AFTER dumping Emacs. If the build directory is indeed
- different from the source dir, src/Makefile.in and
- src/Makefile will not be found together. */
- tem = Fexpand_file_name (build_string ("src/Makefile.in"),
- Vinstallation_directory);
- tem2 = Ffile_exists_p (tem);
- if (!NILP (tem1) && NILP (tem2))
- {
- tem = Fexpand_file_name (build_string ("lisp"),
- Vsource_directory);
+ tem = Fexpand_file_name (build_string ("lisp"),
+ Vsource_directory);
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
+ if (NILP (Fmember (tem, lpath)))
+ lpath = Fcons (tem, lpath);
- if (!no_site_lisp)
+ if (!no_site_lisp)
+ {
+ tem = Fexpand_file_name (build_string ("site-lisp"),
+ Vsource_directory);
+ tem1 = Ffile_accessible_directory_p (tem);
+ if (!NILP (tem1))
{
- tem = Fexpand_file_name (build_string ("site-lisp"),
- Vsource_directory);
- tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
- {
- if (NILP (Fmember (tem, lpath)))
- lpath = Fcons (tem, lpath);
- }
+ if (NILP (Fmember (tem, lpath)))
+ lpath = Fcons (tem, lpath);
}
}
- } /* Vinstallation_directory != Vsource_directory */
+ }
+ } /* Vinstallation_directory != Vsource_directory */
- } /* if Vinstallation_directory */
- }
- else /* !initialized */
- {
- /* NORMAL refers to PATH_DUMPLOADSEARCH, ie the lisp dir in the
- source directory. We used to add ../lisp (ie the lisp dir in
- the build directory) at the front here, but that should not
- be necessary, since in out of tree builds lisp/ is empty, save
- for Makefile. */
- lpath = decode_env_path (0, normal, 0);
- }
-#endif /* !CANNOT_DUMP */
+ } /* if Vinstallation_directory */
return lpath;
}
@@ -4691,11 +4672,7 @@ init_lread (void)
/* First, set Vload_path. */
/* Ignore EMACSLOADPATH when dumping. */
-#ifdef CANNOT_DUMP
- bool use_loadpath = true;
-#else
- bool use_loadpath = NILP (Vpurify_flag);
-#endif
+ bool use_loadpath = !will_dump_p ();
if (use_loadpath && egetenv ("EMACSLOADPATH"))
{
@@ -4746,7 +4723,7 @@ init_lread (void)
load_path_check (Vload_path);
/* Add the site-lisp directories at the front. */
- if (initialized && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
+ if (!will_dump_p () && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
{
Lisp_Object sitelisp;
sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
diff --git a/src/macfont.m b/src/macfont.m
index 09c4ff3..5962782 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -35,6 +35,7 @@ Original author: YAMAMOTO Mitsuharu
#include "nsterm.h"
#include "macfont.h"
#include "macuvs.h"
+#include "pdumper.h"
#include <libkern/OSByteOrder.h>
@@ -1029,12 +1030,12 @@ macfont_handle_font_change_notification
(CFNotificationCenterRef center,
static void
macfont_init_font_change_handler (void)
{
- static bool initialized = false;
+ static bool xinitialized = false;
- if (initialized)
+ if (xinitialized)
return;
- initialized = true;
+ xinitialized = true;
CFNotificationCenterAddObserver
(CFNotificationCenterGetLocalCenter (), NULL,
macfont_handle_font_change_notification,
@@ -1646,7 +1647,7 @@ static int macfont_variation_glyphs (struct font *, int c,
unsigned variations[256]);
static void macfont_filter_properties (Lisp_Object, Lisp_Object);
-static struct font_driver const macfont_driver =
+static struct font_driver macfont_driver =
{
.type = LISPSYM_INITIALLY (Qmac_ct),
.get_cache = macfont_get_cache,
@@ -4028,12 +4029,14 @@ mac_register_font_driver (struct frame *f)
}
+
+static void syms_of_macfont_for_pdumper (void);
+
void
syms_of_macfont (void)
{
/* Core Text, for macOS. */
DEFSYM (Qmac_ct, "mac-ct");
- register_font_driver (&macfont_driver, NULL);
/* The font property key specifying the font design destination. The
value is an unsigned integer code: 0 for WYSIWYG, and 1 for Video
@@ -4048,4 +4051,18 @@ syms_of_macfont (void)
macfont_family_cache = Qnil;
staticpro (&macfont_family_cache);
+
+ pdumper_do_now_and_after_load (syms_of_macfont_for_pdumper);
+}
+
+static void
+syms_of_macfont_for_pdumper (void)
+{
+ if (dumped_with_pdumper_p ())
+ macfont_family_cache = Qnil;
+ else
+ eassert (NILP (macfont_family_cache));
+
+ macfont_driver.type = Qmac_ct;
+ register_font_driver (&macfont_driver, NULL);
}
diff --git a/src/menu.c b/src/menu.c
index c0e5bd9..ea387da 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -1576,9 +1576,10 @@ for instance using the window manager, then this
produces a quit and
void
syms_of_menu (void)
{
- staticpro (&menu_items);
menu_items = Qnil;
+ staticpro (&menu_items);
menu_items_inuse = Qnil;
+ staticpro (&menu_items_inuse);
defsubr (&Sx_popup_menu);
defsubr (&Sx_popup_dialog);
diff --git a/src/minibuf.c b/src/minibuf.c
index c1fbfb4..321fda1 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -32,6 +32,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "keymap.h"
#include "sysstdio.h"
#include "systty.h"
+#include "pdumper.h"
/* List of buffers for use as minibuffers.
The first element of the list is used for the outermost minibuffer
@@ -1198,6 +1199,9 @@ is used to further constrain the set of candidates. */)
bucket = AREF (collection, idx);
}
+ if (HASH_TABLE_P (collection))
+ hash_rehash_if_needed (XHASH_TABLE (collection));
+
while (1)
{
/* Get the next element of the alist, obarray, or hash-table. */
@@ -1858,21 +1862,36 @@ If no minibuffer is active, return nil. */)
}
+
+static void init_minibuf_once_for_pdumper (void);
+
void
init_minibuf_once (void)
{
- Vminibuffer_list = Qnil;
staticpro (&Vminibuffer_list);
+ pdumper_do_now_and_after_load (init_minibuf_once_for_pdumper);
}
-void
-syms_of_minibuf (void)
+static void
+init_minibuf_once_for_pdumper (void)
{
+ PDUMPER_IGNORE (minibuf_level);
+ PDUMPER_IGNORE (minibuf_prompt_width);
+
+ /* We run this function on first initialization and whenever we
+ restore from a pdumper image. pdumper doesn't try to preserve
+ frames, windows, and so on, so reset everything related here. */
+ Vminibuffer_list = Qnil;
minibuf_level = 0;
minibuf_prompt = Qnil;
- staticpro (&minibuf_prompt);
-
minibuf_save_list = Qnil;
+ last_minibuf_string = Qnil;
+}
+
+void
+syms_of_minibuf (void)
+{
+ staticpro (&minibuf_prompt);
staticpro (&minibuf_save_list);
DEFSYM (Qcompletion_ignore_case, "completion-ignore-case");
@@ -1882,7 +1901,6 @@ 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);
diff --git a/src/nsfns.m b/src/nsfns.m
index 887d6b1..60d6231 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -49,7 +49,6 @@ GNUstep port and post-20 update by Adrian Robert
(address@hidden)
#include "macfont.h"
#endif
-
#ifdef HAVE_NS
static EmacsTooltip *ns_tooltip = nil;
@@ -3125,7 +3124,6 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent)
==========================================================================
*/
-
void
syms_of_nsfns (void)
{
@@ -3215,5 +3213,6 @@ Default is t. */);
as_status = 0;
as_script = Qnil;
+ staticpro (&as_script);
as_result = 0;
}
diff --git a/src/nsfont.m b/src/nsfont.m
index b59f87f..9721e48 100644
--- a/src/nsfont.m
+++ b/src/nsfont.m
@@ -36,6 +36,7 @@ Author: Adrian Robert (address@hidden)
#include "character.h"
#include "font.h"
#include "termchar.h"
+#include "pdumper.h"
/* TODO: Drop once we can assume gnustep-gui 0.17.1. */
#ifdef NS_IMPL_GNUSTEP
@@ -1483,6 +1484,8 @@ ns_dump_glyphstring (struct glyph_string *s)
fprintf (stderr, "\n");
}
+static void syms_of_nsfont_for_pdumper (void);
+
struct font_driver const nsfont_driver =
{
.type = LISPSYM_INITIALLY (Qns),
@@ -1502,13 +1505,17 @@ struct font_driver const nsfont_driver =
void
syms_of_nsfont (void)
{
- register_font_driver (&nsfont_driver, NULL);
DEFSYM (Qcondensed, "condensed");
DEFSYM (Qexpanded, "expanded");
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.
*/);
+ 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 --git a/src/nsmenu.m b/src/nsmenu.m
index de5db86..34ec980 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -37,6 +37,7 @@ Carbon version by Yamamoto Mitsuharu. */
#include "termhooks.h"
#include "keyboard.h"
#include "menu.h"
+#include "pdumper.h"
#define NSMENUPROFILE 0
@@ -1893,6 +1894,7 @@ syms_of_nsmenu (void)
/* Don't know how to keep track of this in Next/Open/GNUstep. Always
update menus there. */
trackingMenu = 1;
+ PDUMPER_REMEMBER_SCALAR (trackingMenu);
#endif
defsubr (&Sns_reset_menu);
defsubr (&Smenu_or_popup_active_p);
diff --git a/src/nsterm.m b/src/nsterm.m
index 6383e4b..29aa621 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -60,6 +60,7 @@ GNUstep port and post-20 update by Adrian Robert
(address@hidden)
#include "keyboard.h"
#include "buffer.h"
#include "font.h"
+#include "pdumper.h"
#ifdef NS_IMPL_GNUSTEP
#include "process.h"
@@ -9326,6 +9327,7 @@ 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. */
DEFSYM (Qmodifier_value, "modifier-value");
diff --git a/src/pdumper.c b/src/pdumper.c
new file mode 100644
index 0000000..cf2aaf4
--- /dev/null
+++ b/src/pdumper.c
@@ -0,0 +1,5593 @@
+#include <config.h>
+
+#include <errno.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdarg.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <sys/param.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <unistd.h>
+
+#include "blockinput.h"
+#include "buffer.h"
+#include "charset.h"
+#include "coding.h"
+#include "fingerprint.h"
+#include "frame.h"
+#include "getpagesize.h"
+#include "intervals.h"
+#include "lisp.h"
+#include "pdumper.h"
+#include "window.h"
+#include "systime.h"
+#include "thread.h"
+#include "bignum.h"
+
+#include "dmpstruct.h"
+
+/*
+ TODO:
+
+ - Two-pass dumping: first assemble object list, then write all.
+ This way, we can perform arbitrary reordering or maybe use fancy
+ graph algorithms to get better locality.
+
+ - Don't emit relocations that happen to set Emacs memory locations
+ to values they will already have.
+
+ - 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
+#endif
+
+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)
+# pragma GCC diagnostic error "-Wconversion"
+# pragma GCC diagnostic error "-Wshadow"
+# define ALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic push") \
+ _Pragma ("GCC diagnostic ignored \"-Wconversion\"")
+ _Pragma ("GCC diagnostic ignored \"-Wsign-conversion\"")
+# define DISALLOW_IMPLICIT_CONVERSION \
+ _Pragma ("GCC diagnostic pop")
+#else
+# define ALLOW_IMPLICIT_CONVERSION ((void)0)
+# define DISALLOW_IMPLICIT_CONVERSION ((void)0)
+#endif
+
+#define VM_POSIX 1
+#define VM_MS_WINDOWS 2
+
+#if defined (HAVE_MMAP) && defined (MAP_FIXED)
+# define VM_SUPPORTED VM_POSIX
+# if !defined (MAP_POPULATE) && defined (MAP_PREFAULT_READ)
+# define MAP_POPULATE MAP_PREFAULT_READ
+# elif !defined (MAP_POPULATE)
+# define MAP_POPULATE 0
+# endif
+#elif defined (WINDOWSNT)
+ /* Use a float infinity, to avoid compiler warnings in comparing vs
+ candidates' score. */
+# undef INFINITY
+# define INFINITY __builtin_inff ()
+# include <windows.h>
+# define VM_SUPPORTED VM_MS_WINDOWS
+#else
+# define VM_SUPPORTED 0
+#endif
+
+#define DANGEROUS 0
+
+/* PDUMPER_CHECK_REHASHING being true causes the portable dumper to
+ check, for each hash table it dumps, that the hash table means the
+ same thing after rehashing. */
+#ifndef PDUMPER_CHECK_REHASHING
+# if ENABLE_CHECKING
+# define PDUMPER_CHECK_REHASHING 1
+# else
+# define PDUMPER_CHECK_REHASHING 0
+# endif
+#endif
+
+/* We require an architecture in which all pointers are the same size
+ and have the same layout, where pointers are either 32 or 64 bits
+ long, and where bytes have eight bits --- that is, a
+ general-purpose computer made after 1990. */
+verify (sizeof (ptrdiff_t) == sizeof (void*));
+verify (sizeof (intptr_t) == sizeof (ptrdiff_t));
+verify (sizeof (void (*)(void)) == sizeof (void*));
+verify (sizeof (ptrdiff_t) <= sizeof (Lisp_Object));
+verify (sizeof (ptrdiff_t) <= sizeof (EMACS_INT));
+verify (sizeof (off_t) == sizeof (int32_t) ||
+ sizeof (off_t) == sizeof (int64_t));
+verify (CHAR_BIT == 8);
+
+#define DIVIDE_ROUND_UP(x, y) (((x) + (y) - 1) / (y))
+
+static const char dump_magic[16] = {
+ 'D', 'U', 'M', 'P', 'E', 'D',
+ 'G', 'N', 'U',
+ 'E', 'M', 'A', 'C', 'S'
+};
+
+static pdumper_hook dump_hooks[24];
+static int nr_dump_hooks = 0;
+
+static struct
+{
+ void *mem;
+ int sz;
+} remembered_data[32];
+static int nr_remembered_data = 0;
+
+typedef int32_t dump_off;
+#define DUMP_OFF_MIN INT32_MIN
+#define DUMP_OFF_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_MIN <= value);
+ eassert (value <= DUMP_OFF_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_mpz = [rebuild bignum] */
+ RELOC_BIGNUM,
+ /* 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. 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 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. 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. 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;
+ } 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 efficiently
+ binary search over the relocation entries. */
+ dump_off nr_entries;
+};
+
+#define DUMP_RELOC_TYPE_BITS 5
+verify (RELOC_DUMP_TO_EMACS_LV + 8 < (1 << DUMP_RELOC_TYPE_BITS));
+
+#define DUMP_RELOC_ALIGNMENT_BITS 2
+#define DUMP_RELOC_OFFSET_BITS \
+ (sizeof (dump_off) * CHAR_BIT - DUMP_RELOC_TYPE_BITS)
+
+/* Minimum alignment required by dump file format. */
+#define DUMP_RELOCATION_ALIGNMENT (1<<DUMP_RELOC_ALIGNMENT_BITS)
+
+/* The alignment granularity (in bytes) for objects we store in the
+ dump. Always suitable for heap objects; may be more aligned. */
+#define DUMP_ALIGNMENT (max (GCALIGNMENT, DUMP_RELOCATION_ALIGNMENT))
+verify (DUMP_ALIGNMENT >= GCALIGNMENT);
+
+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,
+ COLD_OP_BIGNUM,
+ };
+
+/* 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 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.
+ */
+ 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;
+
+ /* Hash table mapping bignums to their _data_ blobs, which we store
+ in the cold section. The actual Lisp_Bignum objects are normal
+ heap objects. */
+ Lisp_Object bignum_data;
+
+ 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 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);
+
+/* 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 the result is actually in the Emacs
+ image. */
+ return (void *) (emacs_basis () + offset);
+}
+
+static dump_off
+emacs_offset (const void *emacs_ptr)
+{
+ /* TODO: assert that EMACS_PTR is actually in the Emacs image. */
+ 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. 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 = FIXNUMP (object) || dump_builtin_symbol_p (object);
+ DISALLOW_IMPLICIT_CONVERSION;
+ return result;
+}
+
+#define DEFINE_FROMLISP_FUNC(fn, type) \
+ static type \
+ fn (Lisp_Object value) \
+ { \
+ ALLOW_IMPLICIT_CONVERSION; \
+ if (FIXNUMP (value)) \
+ return XFIXNUM (value); \
+ eassert (BIGNUMP (value)); \
+ return TYPE_SIGNED (type) \
+ ? bignum_to_intmax (value) \
+ : bignum_to_uintmax (value); \
+ DISALLOW_IMPLICIT_CONVERSION; \
+ }
+
+#define DEFINE_TOLISP_FUNC(fn, type) \
+ static Lisp_Object \
+ fn (type 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,
+ void *out,
+ dump_off outsz)
+{
+ /* We dump only one object at a time, so obj_offset should be
+ invalid on entry to this function. */
+ eassert (ctx->obj_offset == 0);
+ int alignment = ctx->flags.pack_objects ? 1 : DUMP_ALIGNMENT;
+ 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 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_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_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 (
+ 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) 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_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)
+ {
+ if (state == DUMP_OBJECT_NOT_SEEN)
+ {
+ state = DUMP_OBJECT_ON_NORMAL_QUEUE;
+ dump_remember_object (ctx, object, state);
+ }
+ /* 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 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_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 (make_fixnum (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_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 (make_fixnum (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 (make_fixnum (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_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 (make_fixnum (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_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_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_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_lv (struct dump_context *ctx,
+ Lisp_Object *emacs_ptr,
+ Lisp_Object value)
+{
+ if (dump_object_self_representing_p (value))
+ dump_emacs_reloc_immediate_lv (ctx, emacs_ptr, value);
+ else
+ {
+ if (ctx->flags.dump_object_contents)
+ /* Conditionally use RELOC_EMACS_EMACS_LV or
+ RELOC_EMACS_DUMP_LV depending on where the target object
+ lives. We could just have decode_emacs_reloc pick the
+ right type, but we might as well maintain the invariant
+ that the types on ctx->emacs_relocs correspond to the types
+ of emacs_relocs we actually emit. */
+ dump_push (
+ &ctx->emacs_relocs,
+ list3 (make_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_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,
+ DUMP_FIXUP_BIGNUM_DATA,
+ };
+
+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_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_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_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;
+ 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_String:
+ case Lisp_Vectorlike:
+ case Lisp_Cons:
+ case Lisp_Float:
+ value = make_lisp_ptr (ptrval, *ptr_raw_type);
+ break;
+ default:
+ emacs_abort ();
+ }
+ }
+
+ /* Now value is the Lisp_Object to which we want to point whether or
+ not the field is a raw pointer (in which case we just synthesized
+ the Lisp_Object outselves) or a Lisp_Object (in which case we
+ just copied the thing). Add a fixup or relocation. */
+
+ intptr_t out_value;
+ dump_off out_field_offset = ctx->obj_offset + relpos;
+ dump_off target_offset = dump_recall_object (ctx, value);
+ if (DANGEROUS &&
+ target_offset > 0 && dump_object_emacs_ptr (value) == NULL)
+ {
+ /* We've already dumped the referenced object, so we can emit
+ the value and a relocation directly instead of indirecting
+ through a fixup. */
+ out_value = target_offset;
+ if (is_ptr_raw)
+ dump_reloc_dump_to_dump_ptr_raw (ctx, out_field_offset);
+ else
+ dump_reloc_dump_to_dump_lv (ctx, out_field_offset, XTYPE (value));
+ }
+ else
+ {
+ /* We don't know about the target object yet, so add a fixup.
+ When we process the fixup, we'll have dumped the target
+ object. */
+ out_value = (intptr_t) 0xDEADF00D;
+ dump_remember_fixup_lv (ctx,
+ out_field_offset,
+ value,
+ ( is_ptr_raw
+ ? LV_FIXUP_RAW_POINTER
+ : LV_FIXUP_LISP_OBJECT ));
+ dump_enqueue_object (ctx, value, weight);
+ }
+
+ memcpy (out_field, &out_value, sizeof (out_value));
+}
+
+/* Set a pointer field on an output object during dump.
+
+ CTX is the dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to the field in that object. TYPE is the type of pointer
+ to which IN_FIELD points.
+ */
+static void
+dump_field_lv_rawptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ enum Lisp_Type type,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, &type, weight);
+}
+
+/* Set a Lisp_Object field on an output object during dump.
+
+ CTX is a dump context. OFFSET is the offset at which the current
+ object starts. OUT is a pointer to the dump output object.
+ IN_START is the start of the current Emacs object. IN_FIELD is a
+ pointer to a Lisp_Object field in that object.
+
+ Arrange for the dump to contain fixups and relocations such that,
+ at load time, the given field of the output object contains a valid
+ Lisp_Object pointing to the same notional object that *IN_FIELD
+ contains now.
+
+ See idomatic usage below. */
+static void
+dump_field_lv (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const Lisp_Object *in_field,
+ struct link_weight weight)
+{
+ dump_field_lv_or_rawptr (ctx, out, in_start, in_field, NULL, weight);
+}
+
+/* Note that we're going to add a manual fixup for the given field
+ later. */
+static void
+dump_field_fixup_later (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ // TODO: more error checking
+ (void) field_relpos (in_start, in_field);
+}
+
+/* Mark an output object field, which is as wide as a poiner, as being
+ fixed up to point to a specific offset in the dump. */
+static void
+dump_field_ptr_to_dump_offset (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field,
+ dump_off target_dump_offset)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_off relpos = field_relpos (in_start, in_field);
+ dump_reloc_dump_to_dump_ptr_raw (ctx, ctx->obj_offset + relpos);
+ intptr_t outval = target_dump_offset;
+ memcpy ((char*) out + relpos, &outval, sizeof (outval));
+}
+
+/* Mark a field as pointing to a place inside Emacs.
+
+ CTX is the dump context. OUT points to the out-object for the
+ current dump function. IN_START points to the start of the object
+ being dumped. IN_FIELD points to the field inside the object being
+ dumped that we're dumping. The contents of this field (which
+ should be as wide as a pointer) are the Emacs pointer to dump.
+
+ */
+static void
+dump_field_emacs_ptr (struct dump_context *ctx,
+ void *out,
+ const void *in_start,
+ const void *in_field)
+{
+ eassert (ctx->obj_offset > 0);
+ if (!ctx->flags.dump_object_contents)
+ return;
+
+ dump_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);
+}
+
+static void
+_dump_object_start_pseudovector (
+ struct dump_context *ctx,
+ union vectorlike_header *out_hdr,
+ const union vectorlike_header *in_hdr)
+{
+ eassert (in_hdr->size & PSEUDOVECTOR_FLAG);
+ ptrdiff_t vec_size = vectorlike_nbytes (in_hdr);
+ dump_object_start (ctx, out_hdr, (dump_off) vec_size);
+ *out_hdr = *in_hdr;
+}
+
+/* Need a macro for alloca. */
+#define START_DUMP_PVEC(ctx, hdr, type, out) \
+ const union vectorlike_header *_in_hdr = (hdr); \
+ type *out = alloca (vectorlike_nbytes (_in_hdr)); \
+ _dump_object_start_pseudovector (ctx, &out->header, _in_hdr)
+
+static dump_off
+finish_dump_pvec (struct dump_context *ctx,
+ union vectorlike_header *out_hdr)
+{
+ ALLOW_IMPLICIT_CONVERSION;
+ return dump_object_finish (ctx, out_hdr, vectorlike_nbytes (out_hdr));
+ DISALLOW_IMPLICIT_CONVERSION;
+}
+
+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_00EEE63F67)
+# error "Lisp_Cons changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Cons out;
+ dump_object_start (ctx, &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, &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_60EA1E748E)
+# 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, &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_642DBAF866)
+# error "Lisp_Marker changed. See CHECK_STRUCTS comment."
+#endif
+
+ START_DUMP_PVEC (ctx, &marker->header, struct Lisp_Marker, out);
+ 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_Vectorlike,
+ WEIGHT_STRONG);
+ DUMP_FIELD_COPY (out, marker, charpos);
+ DUMP_FIELD_COPY (out, marker, bytepos);
+ }
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static dump_off
+dump_overlay (struct dump_context *ctx, const struct Lisp_Overlay *overlay)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Overlay_72EADA9882)
+# error "Lisp_Overlay changed. See CHECK_STRUCTS comment."
+#endif
+ START_DUMP_PVEC (ctx, &overlay->header, struct Lisp_Overlay, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &overlay->header);
+ dump_field_lv_rawptr (ctx, out, overlay, &overlay->next,
+ Lisp_Vectorlike, WEIGHT_STRONG);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+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_Vectorlike,
+ WEIGHT_NORMAL);
+}
+
+static dump_off
+dump_finalizer (struct dump_context *ctx,
+ const struct Lisp_Finalizer *finalizer)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Finalizer_D58E647CB8)
+# error "Lisp_Finalizer changed. See CHECK_STRUCTS comment."
+#endif
+ START_DUMP_PVEC (ctx, &finalizer->header, struct Lisp_Finalizer, out);
+ /* Do _not_ call dump_pseudovector_lisp_fields 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);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+struct bignum_reload_info
+{
+ dump_off data_location;
+ dump_off nlimbs;
+};
+
+static dump_off
+dump_bignum (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Bignum_661945DE2B)
+# error "Lisp_Bignum changed. See CHECK_STRUCTS comment."
+#endif
+ const struct Lisp_Bignum *bignum = XBIGNUM (object);
+ START_DUMP_PVEC (ctx, &bignum->header, struct Lisp_Bignum, out);
+ verify (sizeof (out->value) >= sizeof (struct bignum_reload_info));
+ dump_field_fixup_later (ctx, out, bignum, &bignum->value);
+ dump_off bignum_offset = finish_dump_pvec (ctx, &out->header);
+ if (ctx->flags.dump_object_contents)
+ {
+ /* Export the bignum into a blob in the cold section. */
+ dump_remember_cold_op (ctx, COLD_OP_BIGNUM, object);
+
+ /* Write the offset of that exported blob here. */
+ dump_off value_offset =
+ bignum_offset +
+ (dump_off) offsetof (struct Lisp_Bignum, value);
+ dump_push (&ctx->fixups,
+ list3 (
+ make_fixnum (DUMP_FIXUP_BIGNUM_DATA),
+ dump_off_to_lisp (value_offset),
+ object));
+
+ /* When we load the dump, slurp the data blob and turn it into a
+ real bignum. Attach the relocation to the start of the
+ Lisp_Bignum instead of the actual mpz field so that the
+ relocation offset is aligned. The relocation-application
+ code knows to actually advance past the header. */
+ dump_push (&ctx->dump_relocs,
+ list2 (make_fixnum (RELOC_BIGNUM),
+ dump_off_to_lisp (bignum_offset)));
+ }
+
+ return bignum_offset;
+}
+
+static dump_off
+dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_50A7B216D9)
+# error "Lisp_Float changed. See CHECK_STRUCTS comment."
+#endif
+ eassert (ctx->header.cold_start);
+ struct Lisp_Float out;
+ dump_object_start (ctx, &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, &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, &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
+ 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, &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_13CA6B04FC)
+# error "Lisp_Buffer_Objfwd changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Objfwd out;
+ dump_object_start (ctx, &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, &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_066F33A92E)
+# error "Lisp_Buffer_Local_Value changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Buffer_Local_Value out;
+ dump_object_start (ctx, &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_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,
+ Lisp_Object object,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Symbol_60EA1E748E)
+# 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)
+ {
+ 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, &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);
+
+ 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_00A5A4BFB2)
+# 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, DUMP_ALIGNMENT);
+ 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, which is
+ why we handle it here) 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;
+ /* Don't use sizeof(out), since that incorporates unwanted
+ padding. Instead, use the size through the last non-Lisp
+ field. */
+ size_t sz = (char*)&out.min_char + sizeof (out.min_char) - (char*)&out;
+ eassert (sz < DUMP_OFF_MAX);
+ dump_object_start (ctx, &out, (dump_off) sz);
+ 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, (dump_off) sz);
+ skip = SUB_CHAR_TABLE_OFFSET;
+ }
+ else
+ {
+ union vectorlike_header out;
+ dump_object_start (ctx, &out, sizeof (out));
+ DUMP_FIELD_COPY (&out, header, size);
+ offset = dump_object_finish (ctx, &out, sizeof (out));
+ skip = 0;
+ }
+
+ /* We may have written a non-Lisp vector prefix above. If we have,
+ pad to the lisp content start with zero, and make sure we didn't
+ scribble beyond that start. */
+ 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);
+
+ /* 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. */
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ for (dump_off i = skip; i < size; ++i)
+ {
+ Lisp_Object out;
+ const Lisp_Object *vslot = &v->contents[i];
+ /* In the wide case, we're always misaligned. */
+#ifndef WIDE_EMACS_INT
+ eassert (ctx->offset % sizeof (out) == 0);
+#endif
+ dump_object_start (ctx, &out, sizeof (out));
+ dump_field_lv (ctx, &out, vslot, vslot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof (out));
+ }
+ ctx->flags = old_flags;
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ return offset;
+}
+
+/* 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) ||
+ FIXNUMP (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_fixnum (0)));
+}
+
+static dump_off
+dump_hash_table (struct dump_context *ctx,
+ Lisp_Object object,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Hash_Table_73C9BFB7D1)
+# 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)
+ {
+ 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;
+
+ START_DUMP_PVEC (ctx, &hash->header, struct Lisp_Hash_Table, out);
+ 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 finish_dump_pvec (ctx, &out->header);
+}
+
+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_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));
+
+ START_DUMP_PVEC (ctx, &buffer->header, struct buffer, out);
+ 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_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_Vectorlike, WEIGHT_NORMAL);
+
+ dump_field_lv_rawptr (ctx, out, buffer, &buffer->overlays_after,
+ 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 = finish_dump_pvec (ctx, &out->header);
+ 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_3091289B35)
+# error "Lisp_Vector changed. See CHECK_STRUCTS comment."
+#endif
+ /* No relocation needed, so we don't need dump_object_start. */
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ 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_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_594AB72B54)
+# error "Lisp_Subr changed. See CHECK_STRUCTS comment."
+#endif
+ struct Lisp_Subr out;
+ dump_object_start (ctx, &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)
+{
+ START_DUMP_PVEC (ctx, in, struct Lisp_Vector, out);
+ fill_pseudovec (&out->header, Qnil);
+ return finish_dump_pvec (ctx, &out->header);
+}
+
+static dump_off
+dump_vectorlike (struct dump_context *ctx,
+ Lisp_Object lv,
+ dump_off offset)
+{
+#if CHECK_STRUCTS && !defined (HASH_pvec_type_549C833A54)
+# error "pvec_type changed. See CHECK_STRUCTS comment."
+#endif
+ 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, lv, offset);
+ break;
+ case PVEC_BUFFER:
+ offset = dump_buffer (ctx, XBUFFER (lv));
+ break;
+ case PVEC_SUBR:
+ 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_BIGNUM:
+ offset = dump_bignum (ctx, 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_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, "condvar");
+ case PVEC_MODULE_FUNCTION:
+ error_unsupported_dump_object (ctx, lv, "module function");
+ default:
+ error_unsupported_dump_object(ctx, lv, "weird pseudovector");
+ }
+
+ 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 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.
+
+ 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 (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_E2AD97D3F7)
+# 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)
+ return offset; /* Object already dumped. */
+
+ bool cold = BOOL_VECTOR_P (object) || FLOATP (object);
+ if (cold && ctx->flags.defer_cold_objects)
+ {
+ if (offset != DUMP_OBJECT_ON_COLD_QUEUE)
+ {
+ eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE ||
+ offset == DUMP_OBJECT_NOT_SEEN);
+ offset = DUMP_OBJECT_ON_COLD_QUEUE;
+ dump_remember_object (ctx, object, offset);
+ dump_remember_cold_op (ctx, COLD_OP_OBJECT, object);
+ }
+ return offset;
+ }
+
+ void* obj_in_emacs = dump_object_emacs_ptr (object);
+ if (obj_in_emacs && ctx->flags.defer_copied_objects)
+ {
+ if (offset != DUMP_OBJECT_ON_COPIED_QUEUE)
+ {
+ 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;
+ 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;
+ }
+
+ /* 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 > DUMP_OBJECT_NOT_SEEN)
+ {
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ dump_remember_object (ctx, object, offset);
+ if (ctx->flags.record_object_starts)
+ {
+ eassert (!ctx->flags.pack_objects);
+ 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
+ dump_align_output (ctx, alignof (int));
+ const struct charset *cs = charset_table + cs_i;
+ struct charset out;
+ dump_object_start (ctx, &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)
+{
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ 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);
+ ctx->flags = old_flags;
+ 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_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),
+ 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_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 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);
+ /* 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_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 = 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_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_bignum (struct dump_context *ctx, Lisp_Object object)
+{
+ const struct Lisp_Bignum *bignum = XBIGNUM (object);
+ size_t sz_nlimbs = mpz_size (bignum->value);
+ eassert (sz_nlimbs < DUMP_OFF_MAX);
+ dump_align_output (ctx, alignof (mp_limb_t));
+ dump_off nlimbs = (dump_off) sz_nlimbs;
+ Lisp_Object descriptor = list2 (
+ dump_off_to_lisp (ctx->offset),
+ dump_off_to_lisp ((mpz_sgn (bignum->value) < 0
+ ? -nlimbs : nlimbs)));
+ Fputhash (object, descriptor, ctx->bignum_data);
+ for (size_t i = 0; i < nlimbs; ++i)
+ {
+ mp_limb_t limb = mpz_getlimbn (bignum->value, i);
+ dump_write (ctx, &limb, sizeof (limb));
+ }
+}
+
+static void
+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. */
+ 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) 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;
+ case COLD_OP_BIGNUM:
+ dump_cold_bignum (ctx, data);
+ 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_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_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_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 emit a copy relocation. */
+ if (sz <= sizeof (intmax_t))
+ dump_emacs_reloc_immediate (ctx, mem, mem, sz);
+ else
+ {
+ dump_emacs_reloc_copy_from_dump (ctx, ctx->offset, mem, sz);
+ dump_write (ctx, mem, sz);
+ }
+ }
+ else
+ {
+ /* *mem is a raw pointer to a Lisp object of some sort.
+ The object to which it points should have already been
+ dumped by dump_drain_user_remembered_data_hot. */
+ void *value;
+ Lisp_Object lv;
+ enum Lisp_Type type = -sz;
+ read_ptr_raw_and_lv (mem, type, &value, &lv);
+ if (value == NULL)
+ /* We can't just ignore NULL: the variable might have
+ transitioned from non-NULL to NULL, and we want to
+ record this fact. */
+ dump_emacs_reloc_immediate_ptrdiff_t (ctx, mem, 0);
+ else
+ {
+ if (dump_object_emacs_ptr (lv) != NULL)
+ {
+ /* We have situation like this:
+
+ static Lisp_Symbol *foo;
+ ...
+ foo = XSYMBOL(Qt);
+ ...
+ pdumper_remember_lv_ptr_raw (&foo, Lisp_Symbol);
+
+ Built-in symbols like Qt aren't in the dump!
+ They're actually in Emacs proper. We need a
+ special case to point this value back at Emacs
+ instead of to something in the dump that
+ isn't there.
+
+ An analogous situation applies to subrs, since
+ Lisp_Subr structures always live in Emacs, not
+ the dump.
+ */
+ 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;
+}
+
+/* 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 struct dump_reloc
+dump_decode_dump_reloc (Lisp_Object lreloc)
+{
+ struct dump_reloc reloc;
+ dump_reloc_set_type (
+ &reloc,
+ (enum dump_reloc_type) XFIXNUM (dump_pop (&lreloc)));
+ eassert (reloc.type <= RELOC_DUMP_TO_EMACS_LV + Lisp_Float);
+ dump_reloc_set_offset (&reloc, dump_off_from_lisp (dump_pop (&lreloc)));
+ eassert (NILP (lreloc));
+ return reloc;
+}
+
+static void
+dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc)
+{
+ eassert (ctx->flags.pack_objects);
+ struct dump_reloc reloc;
+ dump_object_start (ctx, &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;
+}
+
+#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 = 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;
+ 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)
+{
+ eassert (ctx->flags.pack_objects);
+ struct emacs_reloc reloc;
+ dump_object_start (ctx, &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. */
+
+#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_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,
+ drain_reloc_handler handler,
+ drain_reloc_merger merger,
+ Lisp_Object *reloc_list,
+ struct dump_table_locator *out_locator)
+{
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+ 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;
+ ctx->flags = old_flags;
+}
+
+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 (dump_pop (&fixup));
+ dump_off dump_fixup_offset = dump_off_from_lisp (dump_pop (&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
+ Lisp_Object arg = dump_pop (&fixup);
+ eassert (NILP (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;
+ case DUMP_FIXUP_BIGNUM_DATA:
+ {
+ eassert (BIGNUMP (arg));
+ arg = Fgethash (arg, ctx->bignum_data, Qnil);
+ if (NILP (arg))
+ error ("bignum not dumped");
+ struct bignum_reload_info reload_info = { 0 };
+ reload_info.data_location = dump_off_from_lisp (dump_pop (&arg));
+ reload_info.nlimbs = dump_off_from_lisp (dump_pop (&arg));
+ eassert (NILP (arg));
+ dump_write (ctx, &reload_info, sizeof (reload_info));
+ do_write = false;
+ 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))
+ {
+ 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.");
+
+ if (!main_thread_p (current_thread))
+ error ("Function can be called only on main thread");
+
+ if (!NILP (XCDR (Fall_threads ())))
+ error ("No other threads can be running");
+
+ /* 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;
+ ctx->bignum_data = make_eq_hash_table ();
+
+ /* 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.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; 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_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.
+ 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);
+
+ /* 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.
+
+ 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_drain_copied_objects (ctx);
+ eassert (dump_queue_empty_p (&ctx->dump_queue));
+
+ dump_off discardable_end = ctx->offset;
+ dump_align_output (ctx, dump_get_page_size ());
+ ctx->header.cold_start = ctx->offset;
+
+ /* 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_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_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,
+ 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,
+ emacs_reloc_merger,
+ &ctx->object_starts,
+ &ctx->header.object_starts);
+ drain_reloc_list (
+ 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 (uintptr_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_base + 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 (uintptr_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 (uintptr_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 (uintptr_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 (
+ (uintptr_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 (
+ (uintptr_t) obj - dump_public.start);
+ if (offset % DUMP_ALIGNMENT != 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 = (uintptr_t) obj - dump_public.start;
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / DUMP_ALIGNMENT;
+ 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 = (uintptr_t) obj - dump_public.start;
+ eassert (offset % DUMP_ALIGNMENT == 0);
+ eassert (offset < dump_private.header.cold_start);
+ eassert (offset < dump_private.header.discardable_start);
+ ptrdiff_t bitno = offset / DUMP_ALIGNMENT;
+ 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;
+}
+
+/* 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 uintptr_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 uintptr_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;
+ }
+ case RELOC_BIGNUM:
+ {
+ struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset);
+ struct bignum_reload_info reload_info;
+ verify (sizeof (reload_info) <= sizeof (bignum->value));
+ memcpy (&reload_info, &bignum->value, sizeof (reload_info));
+ memset (&bignum->value, 0, sizeof (bignum->value));
+ mpz_init (bignum->value);
+ const mp_limb_t *limbs =
+ dump_ptr (dump_base, reload_info.data_location);
+ mpz_roinit_n (bignum->value, limbs, reload_info.nlimbs);
+ 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 uintptr_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 uintptr_t dump_base,
+ const struct emacs_reloc reloc)
+{
+ ptrdiff_t pval;
+ Lisp_Object lv;
+
+ switch (reloc.type)
+ {
+ case RELOC_EMACS_COPY_FROM_DUMP:
+ eassume (reloc.length > 0);
+ memcpy (emacs_ptr (reloc.emacs_offset),
+ dump_ptr (dump_base, reloc.u.dump_offset),
+ reloc.length);
+ break;
+ case RELOC_EMACS_IMMEDIATE:
+ eassume (reloc.length > 0);
+ eassume (reloc.length <= sizeof (reloc.u.immediate));
+ memcpy (emacs_ptr (reloc.emacs_offset),
+ &reloc.u.immediate,
+ reloc.length);
+ break;
+ case RELOC_EMACS_DUMP_PTR_RAW:
+ pval = reloc.u.dump_offset + dump_base;
+ memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_EMACS_PTR_RAW:
+ pval = reloc.u.emacs_offset2 + emacs_basis ();
+ memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval));
+ break;
+ case RELOC_EMACS_DUMP_LV:
+ case RELOC_EMACS_EMACS_LV:
+ {
+ /* Lisp_Float is the maximum lisp type. */
+ eassume (reloc.length <= Lisp_Float);
+ void *obj_ptr = reloc.type == RELOC_EMACS_DUMP_LV
+ ? dump_ptr (dump_base, reloc.u.dump_offset)
+ : emacs_ptr (reloc.u.emacs_offset2);
+ if (reloc.length == Lisp_Symbol)
+ lv = make_lisp_symbol (obj_ptr);
+ else
+ lv = make_lisp_ptr (obj_ptr, reloc.length);
+ memcpy (emacs_ptr (reloc.emacs_offset), &lv, sizeof (lv));
+ break;
+ }
+ default:
+ fatal ("unrecognied relocation type %d", (int) reloc.type);
+ }
+}
+
+static void
+dump_do_all_emacs_relocations (
+ const struct dump_header *const header,
+ const uintptr_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;
+ uintptr_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, DUMP_ALIGNMENT);
+ 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 = (uintptr_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 --git a/src/pdumper.h b/src/pdumper.h
new file mode 100644
index 0000000..8ed4fc1
--- /dev/null
+++ b/src/pdumper.h
@@ -0,0 +1,267 @@
+/* Header file for the portable dumper.
+
+Copyright (C) 2016 Free Software Foundation,
+Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef EMACS_PDUMPER_H
+#define EMACS_PDUMPER_H
+
+#include "lisp.h"
+
+INLINE_HEADER_BEGIN
+
+#define PDUMPER_NO_OBJECT ((enum Lisp_Type) -1)
+
+/* Indicate in source code that we're deliberately relying on pdumper
+ not preserving the given value. Compiles to nothing --- for humans
+ only. */
+#define PDUMPER_IGNORE(thing) ((void) &(thing))
+
+/* The portable dumper automatically preserves the Lisp heap and any C
+ variables to which the Lisp heap points. It doesn't know anything
+ about other C variables. The functions below allow code from other
+ parts of Emacs to tell the portable dumper about other bits of
+ information to preserve in dumped images.
+
+ These memory-records are themselves preserved in the dump, so call
+ the functions below only on the !initialized init path, just
+ like staticpro.
+
+ There are no special functions to preserve a global Lisp_Object.
+ You should just staticpro these. */
+
+/* Remember the value of THING in dumped images. THING must not
+ contain any pointers or Lisp_Object variables: these values are not
+ valid across dump and load. */
+#define PDUMPER_REMEMBER_SCALAR(thing) \
+ pdumper_remember_scalar (&(thing), sizeof (thing))
+
+extern void pdumper_remember_scalar_impl (void *data, ptrdiff_t nbytes);
+
+INLINE
+void
+pdumper_remember_scalar (void *data, ptrdiff_t nbytes)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_remember_scalar_impl (data, nbytes);
+#else
+ (void) data;
+ (void) nbytes;
+#endif
+}
+
+extern void pdumper_remember_lv_ptr_raw_impl (
+ void *ptr, enum Lisp_Type type);
+
+/* Remember the pointer at *PTR. *PTR must be null or point to a Lisp
+ object. TYPE is the rough type of Lisp object to which *PTR
+ points. */
+INLINE
+void
+pdumper_remember_lv_ptr_raw (void* ptr, enum Lisp_Type type)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_remember_lv_ptr_raw_impl (ptr, type);
+#else
+ (void) ptr;
+ (void) type;
+#endif
+}
+
+typedef void (*pdumper_hook)(void);
+extern void pdumper_do_now_and_after_load_impl (pdumper_hook hook);
+
+INLINE void
+pdumper_do_now_and_after_load (pdumper_hook hook)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_do_now_and_after_load_impl (hook);
+#else
+ hook ();
+#endif
+}
+
+/* Macros useful in pdumper callback functions. Assign a value if
+ we're loading a dump and the value needs to be reset to its
+ original value, and if we're initializing for the first time,
+ assert that the value has the expected original value. */
+
+#define PDUMPER_RESET(variable, value) \
+ do { \
+ if (dumped_with_pdumper_p ()) \
+ (variable) = (value); \
+ else \
+ eassert ((variable) == (value)); \
+ } while (0)
+
+#define PDUMPER_RESET_LV(variable, value) \
+ do { \
+ if (dumped_with_pdumper_p ()) \
+ (variable) = (value); \
+ else \
+ eassert (EQ ((variable), (value))); \
+ } while (0)
+
+/* Actually load a dump. */
+
+enum pdumper_load_result
+ {
+ PDUMPER_LOAD_SUCCESS,
+ PDUMPER_NOT_LOADED /* Not returned: useful for callers */,
+ PDUMPER_LOAD_FILE_NOT_FOUND,
+ PDUMPER_LOAD_BAD_FILE_TYPE,
+ PDUMPER_LOAD_FAILED_DUMP,
+ PDUMPER_LOAD_OOM,
+ PDUMPER_LOAD_VERSION_MISMATCH,
+ PDUMPER_LOAD_ERROR,
+ };
+
+enum pdumper_load_result pdumper_load (const char *dump_filename);
+
+struct pdumper_loaded_dump {
+ uintptr_t start;
+ uintptr_t end;
+};
+
+#ifdef HAVE_PDUMPER
+extern struct pdumper_loaded_dump dump_public;
+#endif
+
+/* Return whether the OBJ points somewhere into the loaded dump image.
+ Works even when we have no dump loaded --- in this case, it just
+ returns false. */
+INLINE _GL_ATTRIBUTE_CONST
+bool
+pdumper_object_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ uintptr_t obj_addr = (uintptr_t) obj;
+ return dump_public.start <= obj_addr && obj_addr < dump_public.end;
+#else
+ (void) obj;
+ return false;
+#endif
+}
+
+extern bool pdumper_cold_object_p_impl (const void *obj);
+
+/* Return whether the OBJ is in the cold section of the dump.
+ Only bool-vectors and floats should end up there.
+ pdumper_object_p() and pdumper_object_p_precise() must have
+ returned true for OBJ before calling this function. */
+INLINE _GL_ATTRIBUTE_CONST
+bool
+pdumper_cold_object_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_cold_object_p_impl (obj);
+#else
+ (void) obj;
+ return false;
+#endif
+}
+
+
+extern enum Lisp_Type pdumper_find_object_type_impl (const void *obj);
+
+/* Return the type of the dumped object that starts at OBJ. It is a
+ programming error to call this routine for an OBJ for which
+ pdumper_object_p would return false. */
+INLINE _GL_ATTRIBUTE_CONST
+enum Lisp_Type
+pdumper_find_object_type (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_find_object_type_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+/* Return whether OBJ points exactly to the start of some object in
+ the loaded dump image. It is a programming error to call this
+ routine for an OBJ for which pdumper_object_p would return
+ false. */
+INLINE _GL_ATTRIBUTE_CONST
+bool
+pdumper_object_p_precise (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_find_object_type (obj) != PDUMPER_NO_OBJECT;
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern bool pdumper_marked_p_impl (const void *obj);
+
+/* Return whether OBJ is marked according to the portable dumper.
+ It is an error to call this routine for an OBJ for which
+ pdumper_object_p_precise would return false. */
+INLINE
+bool
+pdumper_marked_p (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ return pdumper_marked_p_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern void pdumper_set_marked_impl (const void *obj);
+
+/* Set the pdumper mark bit for OBJ. It is a programming error to
+ call this function with an OBJ for which pdumper_object_p_precise
+ would return false. */
+INLINE
+void
+pdumper_set_marked (const void *obj)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_set_marked_impl (obj);
+#else
+ (void) obj;
+ emacs_abort ();
+#endif
+}
+
+extern void pdumper_clear_marks_impl (void);
+
+/* Clear all the mark bits for pdumper objects. */
+INLINE
+void
+pdumper_clear_marks (void)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_clear_marks_impl ();
+#endif
+}
+
+/* Handle a page fault that occurs when we access the portable dumper
+ mapping. Return true iff the fault should be considered handled
+ and execution should resume. */
+bool pdumper_handle_page_fault (void *fault_addr_ptr);
+
+void syms_of_pdumper (void);
+
+INLINE_HEADER_END
+#endif
diff --git a/src/process.c b/src/process.c
index edf633e..06555ba 100644
--- a/src/process.c
+++ b/src/process.c
@@ -8028,9 +8028,7 @@ init_process_emacs (int sockfd)
inhibit_sentinels = 0;
-#ifndef CANNOT_DUMP
- if (! noninteractive || initialized)
-#endif
+ if (!will_dump_with_unexec_p ())
{
#if defined HAVE_GLIB && !defined WINDOWSNT
/* Tickle glib's child-handling code. Ask glib to wait for Emacs itself;
diff --git a/src/profiler.c b/src/profiler.c
index ff41433..7624575 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -21,6 +21,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "syssignal.h"
#include "systime.h"
+#include "pdumper.h"
/* Return A + B, but return the maximum fixnum if the result would overflow.
Assume A and B are nonnegative and in fixnum range. */
@@ -570,6 +571,8 @@ hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt)
return XHASH (bt);
}
+static void syms_of_profiler_for_pdumper (void);
+
void
syms_of_profiler (void)
{
@@ -608,4 +611,22 @@ to make room for new entries. */);
defsubr (&Sprofiler_memory_stop);
defsubr (&Sprofiler_memory_running_p);
defsubr (&Sprofiler_memory_log);
+
+ pdumper_do_now_and_after_load (syms_of_profiler_for_pdumper);
+}
+
+static void
+syms_of_profiler_for_pdumper (void)
+{
+ if (dumped_with_pdumper_p ())
+ {
+ cpu_log = Qnil;
+ memory_log = Qnil;
+ }
+ else
+ {
+ eassert (NILP (cpu_log));
+ eassert (NILP (memory_log));
+ }
+
}
diff --git a/src/search.c b/src/search.c
index f97dbe7..059f8fc 100644
--- a/src/search.c
+++ b/src/search.c
@@ -29,6 +29,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "region-cache.h"
#include "blockinput.h"
#include "intervals.h"
+#include "pdumper.h"
#include "regex-emacs.h"
@@ -3386,26 +3387,17 @@ the buffer. If the buffer doesn't have a cache, the
value is nil. */)
}
+static void syms_of_search_for_pdumper (void);
+
void
syms_of_search (void)
{
- register int i;
-
- for (i = 0; i < REGEXP_CACHE_SIZE; ++i)
+ for (int i = 0; i < REGEXP_CACHE_SIZE; ++i)
{
- searchbufs[i].buf.allocated = 100;
- searchbufs[i].buf.buffer = xmalloc (100);
- searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
- searchbufs[i].regexp = Qnil;
- searchbufs[i].f_whitespace_regexp = Qnil;
- searchbufs[i].busy = false;
- searchbufs[i].syntax_table = Qnil;
staticpro (&searchbufs[i].regexp);
staticpro (&searchbufs[i].f_whitespace_regexp);
staticpro (&searchbufs[i].syntax_table);
- searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
}
- searchbuf_head = &searchbufs[0];
/* Error condition used for failing searches. */
DEFSYM (Qsearch_failed, "search-failed");
@@ -3476,4 +3468,23 @@ is to bind it with `let' around a small expression. */);
defsubr (&Sset_match_data);
defsubr (&Sregexp_quote);
defsubr (&Snewline_cache_check);
+
+ pdumper_do_now_and_after_load (syms_of_search_for_pdumper);
+}
+
+static void
+syms_of_search_for_pdumper (void)
+{
+ for (int i = 0; i < REGEXP_CACHE_SIZE; ++i)
+ {
+ searchbufs[i].buf.allocated = 100;
+ searchbufs[i].buf.buffer = xmalloc (100);
+ searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
+ searchbufs[i].regexp = Qnil;
+ searchbufs[i].f_whitespace_regexp = Qnil;
+ searchbufs[i].busy = false;
+ searchbufs[i].syntax_table = Qnil;
+ searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
+ }
+ searchbuf_head = &searchbufs[0];
}
diff --git a/src/sheap.c b/src/sheap.c
index f019c7e..015ee57 100644
--- a/src/sheap.c
+++ b/src/sheap.c
@@ -31,7 +31,6 @@ static int debug_sheap;
char bss_sbrk_buffer[STATIC_HEAP_SIZE];
char *max_bss_sbrk_ptr;
-bool bss_sbrk_did_unexec;
void *
bss_sbrk (ptrdiff_t request_size)
diff --git a/src/sheap.h b/src/sheap.h
index 2730081..a565328 100644
--- a/src/sheap.h
+++ b/src/sheap.h
@@ -27,5 +27,4 @@ enum { STATIC_HEAP_SIZE = sizeof (Lisp_Object) << 22 };
extern char bss_sbrk_buffer[STATIC_HEAP_SIZE];
extern char *max_bss_sbrk_ptr;
-extern bool bss_sbrk_did_unexec;
extern void *bss_sbrk (ptrdiff_t);
diff --git a/src/syntax.c b/src/syntax.c
index ba8f5fc..4616ae2 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -3730,9 +3730,6 @@ syms_of_syntax (void)
staticpro (&gl_state.current_syntax_table);
staticpro (&gl_state.old_prop);
- /* Defined in regex-emacs.c. */
- staticpro (&re_match_object);
-
DEFSYM (Qscan_error, "scan-error");
Fput (Qscan_error, Qerror_conditions,
listn (CONSTYPE_PURE, 2, Qscan_error, Qerror));
diff --git a/src/sysdep.c b/src/sysdep.c
index a477ec8..f8594d6 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -270,7 +270,7 @@ get_current_dir_name_or_unreachable (void)
# if HAVE_GET_CURRENT_DIR_NAME && !BROKEN_GET_CURRENT_DIR_NAME
# ifdef HYBRID_MALLOC
- bool use_libc = bss_sbrk_did_unexec;
+ bool use_libc = will_dump_with_unexec_p ();
# else
bool use_libc = true;
# endif
@@ -1893,7 +1893,7 @@ handle_sigsegv (int sig, siginfo_t *siginfo, void *arg)
/* Return true if we have successfully set up SIGSEGV handler on alternate
stack. Otherwise we just treat SIGSEGV among the rest of fatal signals. */
-static bool
+bool
init_sigsegv (void)
{
struct sigaction sa;
@@ -1908,12 +1908,15 @@ init_sigsegv (void)
sigfillset (&sa.sa_mask);
sa.sa_sigaction = handle_sigsegv;
sa.sa_flags = SA_SIGINFO | SA_ONSTACK | emacs_sigaction_flags ();
- return sigaction (SIGSEGV, &sa, NULL) < 0 ? 0 : 1;
+ if (sigaction (SIGSEGV, &sa, NULL) < 0)
+ return 0;
+
+ return 1;
}
#else /* not HAVE_STACK_OVERFLOW_HANDLING or WINDOWSNT */
-static bool
+bool
init_sigsegv (void)
{
return 0;
@@ -1963,7 +1966,7 @@ maybe_fatal_sig (int sig)
}
void
-init_signals (bool dumping)
+init_signals (void)
{
struct sigaction thread_fatal_action;
struct sigaction action;
@@ -2114,7 +2117,7 @@ init_signals (bool dumping)
/* Don't alter signal handlers if dumping. On some machines,
changing signal handlers sets static data that would make signals
fail to work right when the dumped Emacs is run. */
- if (dumping)
+ if (will_dump_p ())
return;
sigfillset (&process_fatal_action.sa_mask);
diff --git a/src/syssignal.h b/src/syssignal.h
index 01fb41f..ecd6c9c 100644
--- a/src/syssignal.h
+++ b/src/syssignal.h
@@ -22,7 +22,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <signal.h>
-extern void init_signals (bool);
+extern void init_signals (void);
+extern bool init_sigsegv (void);
extern void block_child_signal (sigset_t *);
extern void unblock_child_signal (sigset_t const *);
extern void block_interrupt_signal (sigset_t *);
diff --git a/src/systime.h b/src/systime.h
index 1812f07..9080cd2 100644
--- a/src/systime.h
+++ b/src/systime.h
@@ -93,7 +93,7 @@ extern bool list4_to_timespec (Lisp_Object, Lisp_Object,
Lisp_Object,
Lisp_Object, struct timespec *);
extern struct timespec lisp_time_argument (Lisp_Object);
extern _Noreturn void time_overflow (void);
-extern void init_timefns (bool);
+extern void init_timefns (void);
extern void syms_of_timefns (void);
INLINE_HEADER_END
diff --git a/src/textprop.c b/src/textprop.c
index ddcdf26..7e29ed6 100644
--- a/src/textprop.c
+++ b/src/textprop.c
@@ -2319,11 +2319,10 @@ inherits it if NONSTICKINESS is nil. The
`front-sticky' and
Vtext_property_default_nonsticky
= list2 (Fcons (Qsyntax_table, Qt), Fcons (Qdisplay, Qt));
- staticpro (&interval_insert_behind_hooks);
- staticpro (&interval_insert_in_front_hooks);
interval_insert_behind_hooks = Qnil;
interval_insert_in_front_hooks = Qnil;
-
+ staticpro (&interval_insert_behind_hooks);
+ staticpro (&interval_insert_in_front_hooks);
/* Common attributes one might give text. */
diff --git a/src/thread.c b/src/thread.c
index ec06493..33d1132 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "process.h"
#include "coding.h"
#include "syssignal.h"
+#include "pdumper.h"
#include "keyboard.h"
union aligned_thread_state
@@ -1064,7 +1065,7 @@ init_main_thread (void)
}
bool
-main_thread_p (void *ptr)
+main_thread_p (const void *ptr)
{
return ptr == &main_thread.s;
}
diff --git a/src/thread.h b/src/thread.h
index 288b671..5e00376 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -295,7 +295,7 @@ extern void maybe_reacquire_global_lock (void);
extern void init_threads_once (void);
extern void init_threads (void);
extern void syms_of_threads (void);
-extern bool main_thread_p (void *);
+extern bool main_thread_p (const void *);
extern bool in_current_thread (void);
typedef int select_func (int, fd_set *, fd_set *, fd_set *,
diff --git a/src/timefns.c b/src/timefns.c
index 4c99fe5..ce1f4d3 100644
--- a/src/timefns.c
+++ b/src/timefns.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "bignum.h"
#include "coding.h"
#include "lisp.h"
+#include "pdumper.h"
#include <strftime.h>
@@ -291,7 +292,7 @@ tzlookup (Lisp_Object zone, bool settz)
}
void
-init_timefns (bool dumping)
+init_timefns (void)
{
#ifndef CANNOT_DUMP
/* A valid but unlikely setting for the TZ environment variable.
@@ -300,7 +301,7 @@ init_timefns (bool dumping)
/* 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 ();
@@ -1729,6 +1730,19 @@ emacs_setenv_TZ (const char *tzstring)
return 0;
}
+#if (ULONG_MAX < TRILLION || !FASTER_TIMEFNS) && !defined ztrillion
+# define NEED_ZTRILLION_INIT 1
+#endif
+
+#ifdef NEED_ZTRILLION_INIT
+static void
+syms_of_timefns_for_pdumper (void)
+{
+ mpz_init_set_ui (ztrillion, 1000000);
+ mpz_mul_ui (ztrillion, ztrillion, 1000000);
+}
+#endif
+
void
syms_of_timefns (void)
{
@@ -1740,10 +1754,6 @@ syms_of_timefns (void)
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");
@@ -1759,4 +1769,7 @@ syms_of_timefns (void)
defsubr (&Scurrent_time_string);
defsubr (&Scurrent_time_zone);
defsubr (&Sset_time_zone_rule);
+#ifdef NEED_ZTRILLION_INIT
+ pdumper_do_now_and_after_load (syms_of_timefns_for_pdumper);
+#endif
}
diff --git a/src/unexw32.c b/src/unexw32.c
index f894134..6fa0fa0 100644
--- a/src/unexw32.c
+++ b/src/unexw32.c
@@ -39,8 +39,6 @@ PIMAGE_NT_HEADERS (__stdcall * pfnCheckSumMappedFile) (LPVOID
BaseAddress,
LPDWORD HeaderSum,
LPDWORD CheckSum);
-extern BOOL ctrl_c_handler (unsigned long type);
-
extern char my_begdata[];
extern char my_begbss[];
extern char *my_begbss_static;
@@ -70,84 +68,10 @@ PCHAR bss_start_static = 0;
DWORD_PTR bss_size_static = 0;
DWORD_PTR extra_bss_size_static = 0;
-/* MinGW64 doesn't add a leading underscore to external symbols,
- whereas configure.ac sets up LD_SWITCH_SYSTEM_TEMACS to force the
- entry point at __start, with two underscores. */
-#ifdef __MINGW64__
-#define _start __start
-#endif
-
-extern void mainCRTStartup (void);
-
-/* Startup code for running on NT. When we are running as the dumped
- version, we need to bootstrap our heap and .bss section into our
- address space before we can actually hand off control to the startup
- code supplied by NT (primarily because that code relies upon malloc ()). */
-void _start (void);
-
-void
-_start (void)
-{
-
-#if 1
- /* Give us a way to debug problems with crashes on startup when
- running under the MSVC profiler. */
- if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0)
- DebugBreak ();
-#endif
-
- /* Cache system info, e.g., the NT page size. */
- cache_system_info ();
-
- /* Grab our malloc arena space now, before CRT starts up. */
- init_heap ();
-
- /* This prevents ctrl-c's in shells running while we're suspended from
- having us exit. */
- SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE);
-
- /* Prevent Emacs from being locked up (eg. in batch mode) when
- accessing devices that aren't mounted (eg. removable media drives). */
- SetErrorMode (SEM_FAILCRITICALERRORS);
- mainCRTStartup ();
-}
-
-
/* File handling. */
/* Implementation note: this and the next functions work with ANSI
codepage encoded file names! */
-int
-open_input_file (file_data *p_file, char *filename)
-{
- HANDLE file;
- HANDLE file_mapping;
- void *file_base;
- unsigned long size, upper_size;
-
- file = CreateFileA (filename, GENERIC_READ, FILE_SHARE_READ, NULL,
- OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
- if (file == INVALID_HANDLE_VALUE)
- return FALSE;
-
- size = GetFileSize (file, &upper_size);
- file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY,
- 0, size, NULL);
- if (!file_mapping)
- return FALSE;
-
- file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size);
- if (file_base == 0)
- return FALSE;
-
- p_file->name = filename;
- p_file->size = size;
- p_file->file = file;
- p_file->file_mapping = file_mapping;
- p_file->file_base = file_base;
-
- return TRUE;
-}
int
open_output_file (file_data *p_file, char *filename, unsigned long size)
@@ -187,18 +111,6 @@ open_output_file (file_data *p_file, char *filename,
unsigned long size)
return TRUE;
}
-/* Close the system structures associated with the given file. */
-void
-close_file_data (file_data *p_file)
-{
- UnmapViewOfFile (p_file->file_base);
- CloseHandle (p_file->file_mapping);
- /* For the case of output files, set final size. */
- SetFilePointer (p_file->file, p_file->size, NULL, FILE_BEGIN);
- SetEndOfFile (p_file->file);
- CloseHandle (p_file->file);
-}
-
/* Routines to manipulate NT executable file sections. */
@@ -220,34 +132,6 @@ find_section (const char * name, IMAGE_NT_HEADERS *
nt_header)
return NULL;
}
-/* Return pointer to section header for section containing the given
- relative virtual address. */
-IMAGE_SECTION_HEADER *
-rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header)
-{
- PIMAGE_SECTION_HEADER section;
- int i;
-
- section = IMAGE_FIRST_SECTION (nt_header);
-
- for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++)
- {
- /* Some linkers (eg. the NT SDK linker I believe) swapped the
- meaning of these two values - or rather, they ignored
- VirtualSize entirely and always set it to zero. This affects
- some very old exes (eg. gzip dated Dec 1993). Since
- w32_executable_type relies on this function to work reliably,
- we need to cope with this. */
- DWORD_PTR real_size = max (section->SizeOfRawData,
- section->Misc.VirtualSize);
- if (rva >= section->VirtualAddress
- && rva < section->VirtualAddress + real_size)
- return section;
- section++;
- }
- return NULL;
-}
-
#if 0 /* unused */
/* Return pointer to section header for section containing the given
offset in its raw data area. */
diff --git a/src/w32.c b/src/w32.c
index d141dbd..c75a4f9 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -9926,6 +9926,40 @@ maybe_load_unicows_dll (void)
}
}
+/* Relocate a directory specified by epaths.h, using the location of
+ our binary as an anchor. Note: this runs early during startup, so
+ we cannot rely on the usual file-related facilities, and in
+ particular the argument is assumed to be a unibyte string in system
+ codepage encoding. */
+const char *
+w32_relocate (const char *epath_dir)
+{
+ if (strncmp (epath_dir, "%emacs_dir%/", 12) == 0)
+ {
+ static char relocated_dir[MAX_PATH];
+
+ /* Replace "%emacs_dir%" with the parent of the directory where
+ our binary lives. Note that init_environment was not yet
+ called, so we cannot rely on emacs_dir being set in the
+ environment. */
+ if (GetModuleFileNameA (NULL, relocated_dir, MAX_PATH))
+ {
+ char *p = _mbsrchr (relocated_dir, '\\');
+
+ if (p)
+ {
+ *p = '\0';
+ if ((p = _mbsrchr (relocated_dir, '\\')) != NULL)
+ {
+ strcpy (p, epath_dir + 11);
+ epath_dir = relocated_dir;
+ }
+ }
+ }
+ }
+ return epath_dir;
+}
+
/*
globals_of_w32 is used to initialize those global variables that
must always be initialized on startup even when the global variable
diff --git a/src/w32.h b/src/w32.h
index 6faa90d..3790583 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -185,6 +185,8 @@ extern MultiByteToWideChar_Proc pMultiByteToWideChar;
extern WideCharToMultiByte_Proc pWideCharToMultiByte;
extern DWORD multiByteToWideCharFlags;
+extern const char *w32_relocate (const char *);
+
extern void init_environment (char **);
extern void check_windows_init_file (void);
extern void syms_of_ntproc (void);
diff --git a/src/w32fns.c b/src/w32fns.c
index 2c239dc..29d85c4 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -56,6 +56,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "w32.h"
#endif
+#include "pdumper.h"
+
#include <basetyps.h>
#include <unknwn.h>
#include <commctrl.h>
@@ -10209,6 +10211,7 @@ syms_of_w32fns (void)
track_mouse_window = NULL;
w32_visible_system_caret_hwnd = NULL;
+ PDUMPER_IGNORE (w32_visible_system_caret_hwnd);
DEFSYM (Qundefined_color, "undefined-color");
DEFSYM (Qcancel_timer, "cancel-timer");
diff --git a/src/w32font.c b/src/w32font.c
index 84d5a87..33c8982 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -33,6 +33,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "w32.h"
#endif
+#include "pdumper.h"
+
/* Cleartype available on Windows XP, cleartype_natural from XP SP1.
The latter does not try to fit cleartype smoothed fonts into the
same bounding box as the non-antialiased version of the font.
@@ -2624,6 +2626,9 @@ struct font_driver w32font_driver =
/* Initialize state that does not change between invocations. This is only
called when Emacs is dumped. */
+
+static void syms_of_w32font_for_pdumper (void);
+
void
syms_of_w32font (void)
{
@@ -2803,6 +2808,12 @@ versions of Windows) characters. */);
defsubr (&Sx_select_font);
+ pdumper_do_now_and_after_load (syms_of_w32font_for_pdumper);
+}
+
+static void
+syms_of_w32font_for_pdumper (void)
+{
register_font_driver (&w32font_driver, NULL);
}
diff --git a/src/w32heap.c b/src/w32heap.c
index d96e4e2..3de8f24 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -223,9 +223,16 @@ typedef enum _HEAP_INFORMATION_CLASS {
typedef WINBASEAPI BOOL (WINAPI *
HeapSetInformation_Proc)(HANDLE,HEAP_INFORMATION_CLASS,PVOID,SIZE_T);
#endif
+#ifdef HAVE_PDUMPER
+BOOL using_dynamic_heap = FALSE;
+#endif
+
void
init_heap (void)
{
+#ifdef HAVE_PDUMPER
+ using_dynamic_heap = TRUE;
+#endif
if (using_dynamic_heap)
{
#ifndef MINGW_W64
diff --git a/src/w32menu.c b/src/w32menu.c
index 7d91005..38e1b50 100644
--- a/src/w32menu.c
+++ b/src/w32menu.c
@@ -30,6 +30,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h" /* for ENCODE_SYSTEM */
#include "menu.h"
+#include "pdumper.h"
/* This may include sys/types.h, and that somehow loses
if this is not done before the other system files. */
@@ -1586,6 +1587,7 @@ syms_of_w32menu (void)
globals_of_w32menu ();
current_popup_menu = NULL;
+ PDUMPER_IGNORE (current_popup_menu);
DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
DEFSYM (Qunsupported__w32_dialog, "unsupported--w32-dialog");
diff --git a/src/w32proc.c b/src/w32proc.c
index ec60a9c..a5d08f6 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -81,6 +81,51 @@ static sigset_t sig_mask;
static CRITICAL_SECTION crit_sig;
+
+extern BOOL ctrl_c_handler (unsigned long type);
+
+/* MinGW64 doesn't add a leading underscore to external symbols,
+ whereas configure.ac sets up LD_SWITCH_SYSTEM_TEMACS to force the
+ entry point at __start, with two underscores. */
+#ifdef __MINGW64__
+#define _start __start
+#endif
+
+extern void mainCRTStartup (void);
+
+/* Startup code for running on NT. When we are running as the dumped
+ version, we need to bootstrap our heap and .bss section into our
+ address space before we can actually hand off control to the startup
+ code supplied by NT (primarily because that code relies upon malloc ()). */
+void _start (void);
+
+void
+_start (void)
+{
+
+#if 1
+ /* Give us a way to debug problems with crashes on startup when
+ running under the MSVC profiler. */
+ if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0)
+ DebugBreak ();
+#endif
+
+ /* Cache system info, e.g., the NT page size. */
+ cache_system_info ();
+
+ /* Grab our malloc arena space now, before CRT starts up. */
+ init_heap ();
+
+ /* This prevents ctrl-c's in shells running while we're suspended from
+ having us exit. */
+ SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE);
+
+ /* Prevent Emacs from being locked up (eg. in batch mode) when
+ accessing devices that aren't mounted (eg. removable media drives). */
+ SetErrorMode (SEM_FAILCRITICALERRORS);
+ mainCRTStartup ();
+}
+
/* Improve on the CRT 'signal' implementation so that we could record
the SIGCHLD handler and fake interval timers. */
signal_handler
@@ -1528,6 +1573,78 @@ waitpid (pid_t pid, int *status, int options)
return pid;
}
+int
+open_input_file (file_data *p_file, char *filename)
+{
+ HANDLE file;
+ HANDLE file_mapping;
+ void *file_base;
+ unsigned long size, upper_size;
+
+ file = CreateFileA (filename, GENERIC_READ, FILE_SHARE_READ, NULL,
+ OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
+ if (file == INVALID_HANDLE_VALUE)
+ return FALSE;
+
+ size = GetFileSize (file, &upper_size);
+ file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY,
+ 0, size, NULL);
+ if (!file_mapping)
+ return FALSE;
+
+ file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size);
+ if (file_base == 0)
+ return FALSE;
+
+ p_file->name = filename;
+ p_file->size = size;
+ p_file->file = file;
+ p_file->file_mapping = file_mapping;
+ p_file->file_base = file_base;
+
+ return TRUE;
+}
+
+/* Return pointer to section header for section containing the given
+ relative virtual address. */
+IMAGE_SECTION_HEADER *
+rva_to_section (DWORD_PTR rva, IMAGE_NT_HEADERS * nt_header)
+{
+ PIMAGE_SECTION_HEADER section;
+ int i;
+
+ section = IMAGE_FIRST_SECTION (nt_header);
+
+ for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++)
+ {
+ /* Some linkers (eg. the NT SDK linker I believe) swapped the
+ meaning of these two values - or rather, they ignored
+ VirtualSize entirely and always set it to zero. This affects
+ some very old exes (eg. gzip dated Dec 1993). Since
+ w32_executable_type relies on this function to work reliably,
+ we need to cope with this. */
+ DWORD_PTR real_size = max (section->SizeOfRawData,
+ section->Misc.VirtualSize);
+ if (rva >= section->VirtualAddress
+ && rva < section->VirtualAddress + real_size)
+ return section;
+ section++;
+ }
+ return NULL;
+}
+
+/* Close the system structures associated with the given file. */
+void
+close_file_data (file_data *p_file)
+{
+ UnmapViewOfFile (p_file->file_base);
+ CloseHandle (p_file->file_mapping);
+ /* For the case of output files, set final size. */
+ SetFilePointer (p_file->file, p_file->size, NULL, FILE_BEGIN);
+ SetEndOfFile (p_file->file);
+ CloseHandle (p_file->file);
+}
+
/* Old versions of w32api headers don't have separate 32-bit and
64-bit defines, but the one they have matches the 32-bit variety. */
#ifndef IMAGE_NT_OPTIONAL_HDR32_MAGIC
diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c
index bec9880..c214784 100644
--- a/src/w32uniscribe.c
+++ b/src/w32uniscribe.c
@@ -36,6 +36,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "w32font.h"
+#include "pdumper.h"
#include "w32common.h"
struct uniscribe_font_info
@@ -1176,9 +1177,17 @@ struct font_driver uniscribe_font_driver =
as it needs to test for the existence of the Uniscribe library. */
void syms_of_w32uniscribe (void);
+static void syms_of_w32uniscribe_for_pdumper (void);
+
void
syms_of_w32uniscribe (void)
{
+ pdumper_do_now_and_after_load (syms_of_w32uniscribe_for_pdumper);
+}
+
+static void
+syms_of_w32uniscribe_for_pdumper (void)
+{
HMODULE uniscribe;
/* Don't init uniscribe when dumping */
diff --git a/src/window.c b/src/window.c
index 0fc4f62..7eb532f 100644
--- a/src/window.c
+++ b/src/window.c
@@ -42,6 +42,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#ifdef MSDOS
#include "msdos.h"
#endif
+#include "pdumper.h"
static ptrdiff_t count_windows (struct window *);
static ptrdiff_t get_leaf_windows (struct window *, struct window **,
@@ -7876,10 +7877,59 @@ and scrolling positions. */)
return Qnil;
}
+
+static void init_window_once_for_pdumper (void);
+
void
init_window_once (void)
{
+ minibuf_window = Qnil;
+ staticpro (&minibuf_window);
+
+ selected_window = Qnil;
+ staticpro (&selected_window);
+
+ Vwindow_list = Qnil;
+ staticpro (&Vwindow_list);
+
+ minibuf_selected_window = Qnil;
+ staticpro (&minibuf_selected_window);
+
+ pdumper_do_now_and_after_load (init_window_once_for_pdumper);
+}
+
+static void init_window_once_for_pdumper (void)
+{
+ window_scroll_pixel_based_preserve_x = -1;
+ window_scroll_pixel_based_preserve_y = -1;
+ window_scroll_preserve_hpos = -1;
+ window_scroll_preserve_vpos = -1;
+ PDUMPER_IGNORE (sequence_number);
+
+ PDUMPER_RESET_LV (minibuf_window, Qnil);
+ PDUMPER_RESET_LV (selected_window, Qnil);
+ PDUMPER_RESET_LV (Vwindow_list, Qnil);
+ PDUMPER_RESET_LV (minibuf_selected_window, Qnil);
+
+ /* Hack: if mode_line_in_non_selected_windows is true (which it may
+ be, if we're restoring from a dump) the guts of
+ make_initial_frame will try to access selected_window, which is
+ invalid at this point, and lose. For the purposes of creating
+ the initial frame and window, this variable must be false. */
+ bool old_mode_line_in_non_selected_windows;
+
+ /* Snapshot dumped_with_pdumper to suppress compiler warning. */
+ bool saved_dumped_with_pdumper = dumped_with_pdumper_p ();
+ if (saved_dumped_with_pdumper)
+ {
+ old_mode_line_in_non_selected_windows
+ = mode_line_in_non_selected_windows;
+ mode_line_in_non_selected_windows = false;
+ }
struct frame *f = make_initial_frame ();
+ if (saved_dumped_with_pdumper)
+ mode_line_in_non_selected_windows =
+ old_mode_line_in_non_selected_windows;
XSETFRAME (selected_frame, f);
old_selected_frame = Vterminal_frame = selected_frame;
minibuf_window = f->minibuffer_window;
@@ -7932,16 +7982,6 @@ syms_of_window (void)
DEFSYM (Qmode_line_format, "mode-line-format");
DEFSYM (Qheader_line_format, "header-line-format");
- staticpro (&Vwindow_list);
-
- minibuf_selected_window = Qnil;
- staticpro (&minibuf_selected_window);
-
- window_scroll_pixel_based_preserve_x = -1;
- window_scroll_pixel_based_preserve_y = -1;
- window_scroll_preserve_hpos = -1;
- window_scroll_preserve_vpos = -1;
-
DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function,
doc: /* Non-nil means call as function to display a help buffer.
The function is called with one argument, the buffer to be displayed.
diff --git a/src/xfont.c b/src/xfont.c
index b057aa0..e40a310 100644
--- a/src/xfont.c
+++ b/src/xfont.c
@@ -31,6 +31,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "character.h"
#include "charset.h"
#include "font.h"
+#include "pdumper.h"
/* X core font driver. */
@@ -1077,6 +1078,7 @@ xfont_check (struct frame *f, struct font *font)
}
+static void syms_of_xfont_for_pdumper (void);
struct font_driver const xfont_driver =
{
@@ -1102,5 +1104,11 @@ syms_of_xfont (void)
xfont_scripts_cache = CALLN (Fmake_hash_table, QCtest, Qequal);
staticpro (&xfont_scratch_props);
xfont_scratch_props = make_nil_vector (8);
+ pdumper_do_now_and_after_load (syms_of_xfont_for_pdumper);
+}
+
+static void
+syms_of_xfont_for_pdumper (void)
+{
register_font_driver (&xfont_driver, NULL);
}
diff --git a/src/xftfont.c b/src/xftfont.c
index b4f50a2..ea8572f 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -32,6 +32,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "ftfont.h"
+#include "pdumper.h"
/* Xft font driver. */
@@ -751,6 +752,8 @@ xftfont_cached_font_ok (struct frame *f, Lisp_Object
font_object,
return ok;
}
+static void syms_of_xftfont_for_pdumper (void);
+
struct font_driver const xftfont_driver =
{
/* We can't draw a text without device dependent functions. */
@@ -802,7 +805,11 @@ syms_of_xftfont (void)
This is needed with some fonts to correct vertical overlap of glyphs. */);
xft_font_ascent_descent_override = 0;
- ascii_printable[0] = 0;
+ pdumper_do_now_and_after_load (syms_of_xftfont_for_pdumper);
+}
+static void
+syms_of_xftfont_for_pdumper (void)
+{
register_font_driver (&xftfont_driver, NULL);
}
diff --git a/src/xmenu.c b/src/xmenu.c
index 96c278d..fd7dea4 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -45,6 +45,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h"
#include "sysselect.h"
+#include "pdumper.h"
#ifdef MSDOS
#include "msdos.h"
@@ -2401,15 +2402,12 @@ DEFUN ("menu-or-popup-active-p",
Fmenu_or_popup_active_p, Smenu_or_popup_active_
return (popup_activated ()) ? Qt : Qnil;
}
+
+static void syms_of_xmenu_for_pdumper (void);
+
void
syms_of_xmenu (void)
{
-#ifdef USE_X_TOOLKIT
- enum { WIDGET_ID_TICK_START = 1 << 16 };
- widget_id_tick = WIDGET_ID_TICK_START;
- next_menubar_widget_id = 1;
-#endif
-
DEFSYM (Qdebug_on_next_call, "debug-on-next-call");
defsubr (&Smenu_or_popup_active_p);
@@ -2422,4 +2420,16 @@ syms_of_xmenu (void)
Ffset (intern_c_string ("accelerate-menu"),
intern_c_string (Sx_menu_bar_open_internal.s.symbol_name));
#endif
+
+ pdumper_do_now_and_after_load (syms_of_xmenu_for_pdumper);
+}
+
+static void
+syms_of_xmenu_for_pdumper (void)
+{
+#ifdef USE_X_TOOLKIT
+ enum { WIDGET_ID_TICK_START = 1 << 16 };
+ widget_id_tick = WIDGET_ID_TICK_START;
+ next_menubar_widget_id = 1;
+#endif
}
diff --git a/src/xselect.c b/src/xselect.c
index 4621263..37efd43 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -35,6 +35,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "blockinput.h"
#include "termhooks.h"
#include "keyboard.h"
+#include "pdumper.h"
#include <X11/Xproto.h>
@@ -2613,6 +2614,9 @@ x_send_client_event (Lisp_Object display, Lisp_Object
dest, Lisp_Object from,
}
+
+static void syms_of_xselect_for_pdumper (void);
+
void
syms_of_xselect (void)
{
@@ -2628,17 +2632,9 @@ syms_of_xselect (void)
reading_selection_reply = Fcons (Qnil, Qnil);
staticpro (&reading_selection_reply);
- reading_selection_window = 0;
- reading_which_selection = 0;
- property_change_wait_list = 0;
- prop_location_identifier = 0;
- property_change_reply = Fcons (Qnil, Qnil);
staticpro (&property_change_reply);
- converted_selections = NULL;
- conversion_fail_tag = None;
-
/* FIXME: Duplicate definition in nsselect.c. */
DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
doc: /* An alist associating X Windows selection-types with
functions.
@@ -2717,4 +2713,18 @@ A value of 0 means wait as long as necessary. This is
initialized from the
DEFSYM (Qforeign_selection, "foreign-selection");
DEFSYM (Qx_lost_selection_functions, "x-lost-selection-functions");
DEFSYM (Qx_sent_selection_functions, "x-sent-selection-functions");
+
+ pdumper_do_now_and_after_load (syms_of_xselect_for_pdumper);
+}
+
+static void
+syms_of_xselect_for_pdumper (void)
+{
+ reading_selection_window = 0;
+ reading_which_selection = 0;
+ property_change_wait_list = 0;
+ prop_location_identifier = 0;
+ property_change_reply = Fcons (Qnil, Qnil);
+ converted_selections = NULL;
+ conversion_fail_tag = None;
}
diff --git a/src/xsettings.c b/src/xsettings.c
index 60b86f4..0c5e36d 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -32,6 +32,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "keyboard.h"
#include "blockinput.h"
#include "termhooks.h"
+#include "pdumper.h"
#include <X11/Xproto.h>
@@ -1023,13 +1024,18 @@ void
syms_of_xsettings (void)
{
current_mono_font = NULL;
+ PDUMPER_IGNORE (current_mono_font);
current_font = NULL;
+ PDUMPER_IGNORE (current_font);
first_dpyinfo = NULL;
+ PDUMPER_IGNORE (first_dpyinfo);
#ifdef HAVE_GSETTINGS
gsettings_client = NULL;
+ PDUMPER_IGNORE (gsettings_client);
#endif
#ifdef HAVE_GCONF
gconf_client = NULL;
+ PDUMPER_IGNORE (gconf_client);
#endif
DEFSYM (Qmonospace_font_name, "monospace-font-name");
diff --git a/src/xterm.c b/src/xterm.c
index 6327038..d8eb45a 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -74,6 +74,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "xsettings.h"
#include "sysselect.h"
#include "menu.h"
+#include "pdumper.h"
#ifdef USE_X_TOOLKIT
#include <X11/Shell.h>
@@ -13298,6 +13299,7 @@ void
syms_of_xterm (void)
{
x_error_message = NULL;
+ PDUMPER_IGNORE (x_error_message);
DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms");
DEFSYM (Qlatin_1, "latin-1");