diff options
92 files changed, 8308 insertions, 961 deletions
diff --git a/.gitignore b/.gitignore index d295797347e..53f41f0f3eb 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 cd3a0a9293b..b6cd04d1f3d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -66,6 +66,8 @@ SHELL = @SHELL@ +DUMPING=@DUMPING@ + # 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 16a2ce059df..75297194299 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 9c74d8eee44..387a6e33249 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 00000000000..69558a818e2 --- /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 90ea7edff8d..44ce2929d66 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 b12735676c8..40e9ba1c14a 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 6ccb001e35f..9948bd4a034 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 cdd8ba7c403..b07f984b58d 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 1c7f6fa83a9..023fcbc5d13 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 f419f0bd4ae..0f0ca15cebc 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 1011d5f9537..f2410f6f2c3 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 a1966f02885..ea64af60ca5 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 f409ed4db28..980bd6d10e8 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@ -CANNOT_DUMP=@CANNOT_DUMP@ +DUMPING=@DUMPING@ # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ @@ -357,6 +355,15 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) 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 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ 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 31e8da70161..8054aa5ae59 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 4d97470a28f..d36c4f1f5a3 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 cc0899676de..a12c80ec0b0 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 bb7d796bac5..40977799bfc 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 0911c49ae59..ba6e3350a50 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 19882e60fa3..d4558387cfc 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 c504d2d9921..132fae9d404 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 724b35536ed..28f6203a66d 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 0822f2d12fe..f4bed558cf2 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 1c1462198ca..665aefa34c8 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 cd8364a2936..c426cbb1246 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 002ef6c65bc..125dbf01528 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 a9908a34f4f..92a1062280e 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 e1c4eda76e9..0afae6b05ad 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 55cdaf5de8a..88783cd5da7 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 00000000000..d222d117e62 --- /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 04370f7cc62..3e43d6db069 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 55127011d82..01376b06373 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 e695a3d2e64..cbab0234201 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 221b074afc9..9c88b6e3f17 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 28478956e35..b094fc2e663 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 81d98f36fa4..64310f5c538 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 00000000000..295654a40db --- /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 00000000000..b48d40f89ca --- /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 6fcb38e4b04..1ac60321c58 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 3fc77a1d76a..4ca44942fde 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 55a3f78e865..2729fae6ee9 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 6d93abd09bf..aa1a15ff006 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 74f41f00873..335a6eb0468 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 314fa5b400d..7c18e04b743 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 f5a225be056..bcc3460cb74 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 726e0a845b1..f9a69c35151 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 c19885d9f80..b6a96d55727 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 1fe20d7ce2d..d0cb28dc536 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 2fae105815d..2f0b63ca899 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 08f04d3ddca..a6f006a521d 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 3cee7889414..9c5adf33a14 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 9e38bb21f6e..2d6fa91a16c 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 faf5a4ad407..5c48905232f 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 5a595f2119b..dde9ccef549 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 09c4ff31c88..59627823fae 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 c0e5bd9caf6..ea387dacbda 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 c1fbfb40857..321fda1ba88 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 887d6b10aa5..60d62310bb0 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -49,7 +49,6 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #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 b59f87f4682..9721e489357 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -36,6 +36,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #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 de5db868223..34ec980856a 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 6383e4b7ab5..29aa6214527 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -60,6 +60,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #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 00000000000..cf2aaf474bb --- /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 00000000000..8ed4fc1cb3b --- /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 edf633e512e..06555bac4c0 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 ff4143383ce..76245750ada 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 f97dbe73341..059f8fc4d2e 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 f019c7ee3c4..015ee5786ff 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 27300814b07..a5653288f5b 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 ba8f5fcfa9e..4616ae296f8 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 a477ec892ec..f8594d6a915 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 01fb41feded..ecd6c9cc8c2 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 1812f073f35..9080cd2bba1 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 ddcdf26884f..7e29ed6e8b8 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 ec06493b9e4..33d113295ba 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 288b671257d..5e003761e85 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 4c99fe58061..ce1f4d3f5a9 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 f8941344fcc..6fa0fa055a6 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 d141dbd20bb..c75a4f918d3 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 6faa90d3177..3790583bfc8 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 2c239dc7b49..29d85c4826c 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 84d5a876774..33c89825e94 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 d96e4e2823a..3de8f245ccc 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 7d91005f22d..38e1b506e09 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 ec60a9cabcc..a5d08f60117 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 bec988041ad..c214784fc83 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 0fc4f622995..7eb532f78cf 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 b057aa0a277..e40a31004f6 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 b4f50a2cf8d..ea8572f4242 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 96c278d42d0..fd7dea4cf8a 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 4621263c62e..37efd43b955 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 60b86f43a87..0c5e36d9d69 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 632703849f8..d8eb45a00c0 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"); |