From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Daniel Colascione Newsgroups: gmane.emacs.devel Subject: Preview: portable dumper Date: Mon, 28 Nov 2016 11:50:31 -0800 Message-ID: <047a67ec-9e29-7e4e-0fb0-24c3e59b5886@dancol.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------6DD91D7A55B57EBB568F2D24" X-Trace: blaine.gmane.org 1480362749 8306 195.159.176.226 (28 Nov 2016 19:52:29 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 28 Nov 2016 19:52:29 +0000 (UTC) User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.4.0 To: Emacs developers Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Mon Nov 28 20:52:13 2016 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cBRyF-00081o-5q for ged-emacs-devel@m.gmane.org; Mon, 28 Nov 2016 20:52:13 +0100 Original-Received: from localhost ([::1]:60921 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cBRyI-0003Qx-P4 for ged-emacs-devel@m.gmane.org; Mon, 28 Nov 2016 14:52:14 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:58588) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cBRx7-0002mx-0i for emacs-devel@gnu.org; Mon, 28 Nov 2016 14:51:25 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cBRwl-00082o-8b for emacs-devel@gnu.org; Mon, 28 Nov 2016 14:51:01 -0500 Original-Received: from dancol.org ([2600:3c01::f03c:91ff:fedf:adf3]:37364) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cBRwj-000826-UE for emacs-devel@gnu.org; Mon, 28 Nov 2016 14:50:39 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=dancol.org; s=x; h=Content-Type:MIME-Version:Date:Message-ID:Subject:From:To; bh=s9vF/RdZma/9lSa7Reg7R0tK5h1GhFBM/oMdwNKxSc4=; b=nDmqFd8+usoPpEoX3aGtCfSpm4DDnjdFhXCHnH5KnppnCfxE4R+7OhK1AtIYsD2a5JtHgFGCVFt8eMFRiNJWHTN6W36KG6vM/PFYYM09HelVms+AiGbfIT8F3d4uxKgM2ImeWdPGL6ZMJrUtBOLdtOQsCOvyvrgVylMDuaXZZjUuP8P/sNLaoENMOvbz5GFxUgyCKGSxh1PjM5KHEH0oO5UxuhkxRA95wFDMPBq38MQhgI7NEmrZdrXVcnjh5pNQ4eOUVyUPQPwJqHNKJpj3q61k/Asi/9Ze74GAGRVaGFUDiKk0BeNC1YYr8m+HatCgBSn5yBvP8hBrskVRvlcZWw==; Original-Received: from c-73-140-245-253.hsd1.wa.comcast.net ([73.140.245.253] helo=[192.168.1.173]) by dancol.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.84_2) (envelope-from ) id 1cBRwh-0007wP-8T for emacs-devel@gnu.org; Mon, 28 Nov 2016 11:50:35 -0800 X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 2600:3c01::f03c:91ff:fedf:adf3 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:209679 Archived-At: This is a multi-part message in MIME format. --------------6DD91D7A55B57EBB568F2D24 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit I've been working on a portable dumper for GNU Emacs. The attached patch is an early version of this work. I'll write up all the usual NEWS entries, changelogs, and (in this case necessary) dedicated documentation before I land it. I want to start getting review comments now that the code has roughly its final shape. The point of this gargantuan patch is that we can rip out our unexec implementations and replace them with loading a data file that contains an Emacs heap image. There are no dependencies on executable rewriting, disabling ASLR, or saving and restoring internal malloc state. This system works with fully position-independent executables and with any malloc implementation. Basically, there's a new dump-emacs-portable function that walks the Emacs heap and writes the data, along with necessary relocation, to a file called emacs.pdmp. On startup, early in main, we find emacs.pdmp and load it. Once we've loaded the file, we walk the list of relocations contained in the dump and adjust it to account for the runtime locations of Emacs and the dump data (neither of which we know in advance in a PIE world.) There are a few subtleties: I've carefully designed the file format to be mmap-able and to minimize the number of on-demand copies the system makes while accessing this file. For example, we stick bool-vectors and string data at the end of the dump in a contiguous block. We follow this block with the relocations, which we can throw away as soon as we've used them. An additional optimization follows, although this part isn't implemented yet: we can define a "preferred load address" for the dump and write relocation information such that if the dump and Emacs end up being where we expect them to be, we don't have to perform any relocations at all. The system gracefully degrades though. If we can't use mmap or whatever on a given platform, it's possible to just slurp the whole file into a malloced region of memory and access it from there. This approach would benefit from compression, which will reduce IO loads: LZ4 reduces the dump size for me from ~12MB to ~4MB. As in the mmap case, we can throw away The code isn't even close to optimized yet --- I've only tested it at -O0, defined GC_CHECK_MARKED_OBJECTS, and not yet inlined frequently-called functions pdumper.h --- but even so, it's within 100ms or so of an unexeced Emacs. It's also possible to dump an already-dumped Emacs, so it should be possible for users to have their own dump files. If we want to preserve the current model of a single "emacs" executable that contains itself, we can embed emacs.pdmp inside the emacs executable data section pretty easily. There's no behavior change involved. If you want to try this code, build CANNOT_DUMP=1, run ./temacs -l loadup pdump, then ./emacs (or if that doesn't work, ./emacs --dump-file=emacs.pdmp). --------------6DD91D7A55B57EBB568F2D24 Content-Type: text/x-patch; name="pdumper.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="pdumper.diff" diff --git a/.gitignore b/.gitignore index 15f9c56..3b7975f 100644 --- a/.gitignore +++ b/.gitignore @@ -182,6 +182,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 @@ -195,6 +196,9 @@ src/bootstrap-emacs src/emacs src/emacs-[0-9]* src/temacs +src/temacs.in +src/fingerprint.c +src/*.pdmp # Character-set info. admin/charsets/jisx2131-filter diff --git a/configure.ac b/configure.ac index c9759e1..3e44716 100644 --- a/configure.ac +++ b/configure.ac @@ -2167,6 +2167,10 @@ AC_DEFUN hybrid_malloc=yes fi +## XXX +hybrid_malloc=no +system_malloc=yes + GMALLOC_OBJ= HYBRID_MALLOC= if test "${system_malloc}" = "yes"; then diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 44ce719..901a009 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -303,10 +303,7 @@ Library Search initializes @code{load-path} using the @file{lisp} directory in the directory containing the sources from which it was built. -@c Though there should be no *.el files in builddir/lisp, so it's pointless. -If you built Emacs in a separate directory from the -sources, it also adds the lisp directories from the build directory. -(In all cases, elements are represented as absolute file names.) +Elements are represented as absolute file names. @cindex site-lisp directories Unless you start Emacs with the @option{--no-site-lisp} option, @@ -329,9 +326,9 @@ Library Search The first one is for locally installed files for a specific Emacs version; the second is for locally installed files meant for use with all installed Emacs versions. (If Emacs is running uninstalled, -it also adds @file{site-lisp} directories from the source and build -directories, if they exist. Normally these directories do not contain -@file{site-lisp} directories.) +it also adds @file{site-lisp} directories from the source +directory. Normally this directory does not contain a +@file{site-lisp} directory.) @cindex @env{EMACSLOADPATH} environment variable If the environment variable @env{EMACSLOADPATH} is set, it modifies diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in index c3693ab..db768eb 100644 --- a/lib-src/Makefile.in +++ b/lib-src/Makefile.in @@ -158,7 +158,7 @@ INSTALLABLES = UTILITIES = profile${EXEEXT} movemail${EXEEXT} hexl${EXEEXT} \ 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}: make-docfile${EXEEXT}: ${srcdir}/make-docfile.c $(NTLIB) $(config_h) $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@ +make-fingerprint${EXEEXT}: ${srcdir}/make-fingerprint.c $(NTLIB) $(config_h) + $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(NTLIB) $(LOADLIBES) -o $@ + movemail${EXEEXT}: ${srcdir}/movemail.c pop.o $(NTLIB) $(config_h) $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} ${MOVE_FLAGS} $< pop.o \ $(NTLIB) $(LOADLIBES) $(LIBS_MOVE) -o $@ diff --git a/lib-src/make-fingerprint.c b/lib-src/make-fingerprint.c new file mode 100644 index 0000000..dd2f093 --- /dev/null +++ b/lib-src/make-fingerprint.c @@ -0,0 +1,86 @@ +/* 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 . */ + + +/* 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 + +#include +#include +#include +#include +#include +#include +#include + +#ifdef WINDOWSNT +/* Defined to be sys_fopen in ms-w32.h, but only #ifdef emacs, so this + is really just insurance. */ +#undef fopen +#include +#endif /* WINDOWSNT */ + +int +main (int argc, char **argv) +{ + struct sha256_ctx ctx; + sha256_init_ctx (&ctx); + + for (int i = 1; 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); + 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/loadup.el b/lisp/loadup.el index 5c16464..58a1ba9 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. @@ -55,28 +58,52 @@ (setq redisplay--inhibit-bidi t) ;; 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. (equal (nth 4 command-line-args) "unidata-gen.el") - (equal (nth 7 command-line-args) "unidata-gen-files") + (equal (nth 7 command-line-args) "unidata-gen-files") + ;; XXX figure out why we need this here (if (fboundp 'dump-emacs) (string-match "src/bootstrap-emacs" (nth 0 command-line-args)) t)) - (let ((dir (car 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 "language" dir) - (expand-file-name "international" dir) - (expand-file-name "textmodes" dir) - (expand-file-name "vc" dir))))) + ;; 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" + "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)) (if (eq t purify-flag) ;; Hash consing saved around 11% of pure space in my tests. @@ -84,9 +111,7 @@ (message "Using load-path %s" load-path) -;; This is a poor man's `last', since we haven't loaded subr.el yet. -(if (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) @@ -343,8 +368,7 @@ ;; 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")) - (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 last version number to use @@ -443,37 +467,39 @@ ;; Make sure we will attempt bidi reordering henceforth. (setq redisplay--inhibit-bidi nil) -(if (member (car (last command-line-args)) '("dump" "bootstrap")) - (progn - (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") (error "XXX")) + (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) - ;; 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 (concat "emacs-" emacs-version)) - (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))) + (delete-file output) + (file-error nil)) + (if (equal dump-mode "pdump") + (dump-emacs-portable output) + (dump-emacs output "temacs") + (message "%d pure bytes used" pure-bytes-used) + ;; 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 dump-mode "bootstrap"))) + (let ((name (concat "emacs-" emacs-version)) + (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)))) (kill-emacs))) ;; For machines with CANNOT_DUMP defined in config.h, @@ -484,6 +510,7 @@ (equal (nth 2 command-line-args) "loadup")) (setcdr command-line-args (nthcdr 3 command-line-args))) +(unintern 'dump-mode obarray) (eval top-level) diff --git a/src/.gdbinit b/src/.gdbinit index b0c0dfd..d9820e5 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -1215,7 +1215,7 @@ document xwhichsymbols maximum number of symbols referencing it to produce. end -# Show Lisp backtrace after normal backtrace. +# # Show Lisp backtrace after normal backtrace. define hookpost-backtrace set $bt = backtrace_top () if backtrace_p ($bt) diff --git a/src/Makefile.in b/src/Makefile.in index dc0bfff..d1397b78 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -401,7 +401,7 @@ base_obj = buffer.o filelock.o insdel.o marker.o \ minibuf.o fileio.o dired.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \ - 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 \ @@ -602,14 +602,28 @@ LIBEGNU_ARCHIVE = $(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$(EEXIST) > 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) ifneq ($(PAXCTL_notdumped),) @@ -651,6 +665,7 @@ .PHONY: mostlyclean: rm -f temacs$(EXEEXT) core *.core \#* *.o + rm -f temacs.in$(EXEEXT) fingerprint.c rm -f ../etc/DOC rm -f bootstrap-emacs$(EXEEXT) emacs-$(version)$(EXEEXT) rm -f buildobj.h diff --git a/src/alloc.c b/src/alloc.c index 90c6f94..e31f71d 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -42,6 +42,7 @@ along with GNU Emacs. If not, see . */ #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 @@ -77,6 +78,8 @@ static bool valgrind_p; /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */ +#define GC_CHECK_MARKED_OBJECTS 1 // XXX + /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd memory. Can do this only if using gmalloc.c and if not checking marked objects. */ @@ -202,13 +205,13 @@ alloc_unexec_post (void) /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer to a struct Lisp_String. */ -#define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG) -#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG) -#define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0) +#define XMARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG) +#define XUNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG) +#define XSTRING_MARKED_P(S) (((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). */ @@ -357,6 +360,36 @@ 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 struct vectorlike_header *v); +INLINE static void set_vectorlike_marked (struct vectorlike_header *v); + +INLINE static bool cons_marked_p (const struct Lisp_Cons *c); +INLINE static void set_cons_marked (struct Lisp_Cons *c); + +INLINE static bool string_marked_p (const struct Lisp_String *s); +INLINE static void set_string_marked (struct Lisp_String *s); + +INLINE static bool symbol_marked_p (const struct Lisp_Symbol *s); +INLINE static void set_symbol_marked (struct Lisp_Symbol *s); + +INLINE static bool misc_any_marked_p (const struct Lisp_Misc_Any *m); +INLINE static void set_misc_any_marked (struct Lisp_Misc_Any *m); + +INLINE static bool marker_marked_p (const struct Lisp_Marker *m); +INLINE static void set_marker_marked (struct Lisp_Marker *m); + +INLINE static bool overlay_marked_p (const struct Lisp_Overlay *m); +INLINE static void set_overlay_marked (struct Lisp_Overlay *m); + +INLINE static bool interval_marked_p (INTERVAL i); +INLINE static void set_interval_marked (INTERVAL i); + /* When scanning the C stack for live Lisp objects, Emacs keeps track of what memory allocated via lisp_malloc and lisp_align_malloc is intended for what purpose. This enumeration specifies the type of memory. */ @@ -383,7 +416,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 @@ -465,30 +501,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 * @@ -553,18 +580,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 () && !might_dump_with_unexec; } #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; /************************************************************************ @@ -895,6 +922,8 @@ xfree (void *block) { if (!block) return; + if (pdumper_object_p (block)) + return; MALLOC_BLOCK_INPUT; free (block); MALLOC_UNBLOCK_INPUT; @@ -1117,6 +1146,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 @@ -1548,22 +1580,23 @@ make_interval (void) /* Mark Lisp objects in interval I. */ static void -mark_interval (register INTERVAL i, Lisp_Object dummy) +mark_interval_tree_1 (register INTERVAL i, Lisp_Object 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, Qnil); \ - } while (0) +static void +mark_interval_tree (INTERVAL i) +{ + if (i && !interval_marked_p (i)) + traverse_intervals_noorder (i, mark_interval_tree_1, Qnil); +} /*********************************************************************** String Allocation @@ -1798,7 +1831,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); } @@ -2091,10 +2126,10 @@ sweep_strings (void) if (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->intervals = balance_intervals (s->intervals); @@ -2591,7 +2626,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)) @@ -2604,13 +2640,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. */ @@ -2660,7 +2696,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--; @@ -2685,7 +2721,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)) @@ -2698,13 +2735,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. */ @@ -2766,7 +2803,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++; @@ -3089,6 +3126,7 @@ static void init_vectors (void) { zero_vector = make_pure_vector (0); + staticpro (&zero_vector); } /* Allocate vector from a vector block. */ @@ -3159,7 +3197,7 @@ allocate_vector_from_block (size_t nbytes) /* Return the memory footprint of V in bytes. */ -static ptrdiff_t +ptrdiff_t vector_nbytes (struct Lisp_Vector *v) { ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG; @@ -3234,9 +3272,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++; nbytes = vector_nbytes (vector); total_vector_slots += nbytes / word_size; @@ -3256,7 +3294,7 @@ sweep_vectors (void) while (VECTOR_IN_BLOCK (next, block)) { - if (VECTOR_MARKED_P (next)) + if (XVECTOR_MARKED_P (next)) break; cleanup_vector (next); nbytes = vector_nbytes (next); @@ -3296,9 +3334,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) { @@ -3961,7 +3999,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head) finalizer != head; finalizer = finalizer->next) { - finalizer->base.gcmarkbit = true; + set_misc_any_marked (&finalizer->base); mark_object (finalizer->function); } } @@ -3978,7 +4016,8 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest, while (finalizer != src) { struct Lisp_Finalizer *next = finalizer->next; - if (!finalizer->base.gcmarkbit && !NILP (finalizer->function)) + if (!misc_any_marked_p (&finalizer->base) + && !NILP (finalizer->function)) { unchain_finalizer (finalizer); finalizer_insert (dest, finalizer); @@ -4044,6 +4083,169 @@ FUNCTION. FUNCTION will be run once per finalizer object. */) /************************************************************************ + Mark bit access functions + ************************************************************************/ + +/* With the rare excpetion 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 enum pvec_type find_pvec_type (const struct Lisp_Vector *ptr); + +static bool +vector_marked_p (const struct Lisp_Vector *v) +{ + if (pdumper_object_p (v)) + { + /* TODO: look into using a range test against + hot_discardable_start instead of loading the pvec header. + We'll have already loaded the dump header cache line, after + all. */ + enum pvec_type pvectype = find_pvec_type (v); + if (pvectype == 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 (find_pvec_type (v) != PVEC_BOOL_VECTOR); + pdumper_set_marked (v); + } + else + XMARK_VECTOR (v); +} + +static bool +vectorlike_marked_p (const struct vectorlike_header *header) +{ + return vector_marked_p ((const struct Lisp_Vector *) header); +} + +static void +set_vectorlike_marked (struct 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->gcmarkbit; +} + +static void +set_symbol_marked (struct Lisp_Symbol *s) +{ + if (pdumper_object_p (s)) + pdumper_set_marked (s); + else + s->gcmarkbit = true; +} + +static bool +misc_any_marked_p (const struct Lisp_Misc_Any *m) +{ + return pdumper_object_p (m) + ? pdumper_marked_p (m) + : m->gcmarkbit; +} + +static void +set_misc_any_marked (struct Lisp_Misc_Any *m) +{ + if (pdumper_object_p (m)) + pdumper_set_marked (m); + else + m->gcmarkbit = true; +} + +static bool +marker_marked_p (const struct Lisp_Marker *m) +{ + return misc_any_marked_p ((struct Lisp_Misc_Any *) m); +} + +static void +set_marker_marked (struct Lisp_Marker *m) +{ + set_misc_any_marked ((struct Lisp_Misc_Any *) m); +} + +static bool +overlay_marked_p (const struct Lisp_Overlay *m) +{ + return misc_any_marked_p ((struct Lisp_Misc_Any *) m); +} + +static void +set_overlay_marked (struct Lisp_Overlay *m) +{ + set_misc_any_marked ((struct Lisp_Misc_Any *) m); +} + +static bool +interval_marked_p (INTERVAL i) +{ + return pdumper_object_p (i) + ? pdumper_marked_p (i) + : i->gcmarkbit; +} + +static void +set_interval_marked (INTERVAL i) +{ + if (pdumper_object_p (i)) + pdumper_set_marked (i); + else + i->gcmarkbit = true; +} + + +/************************************************************************ Memory Full Handling ************************************************************************/ @@ -4712,6 +4914,19 @@ mark_maybe_object (Lisp_Object 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 pointerp 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)) + { + if (pdumper_object_p_precise (po)) + mark_object (obj); + return; + } + struct mem_node *m = mem_find (po); if (m != MEM_NIL) @@ -4722,11 +4937,11 @@ mark_maybe_object (Lisp_Object obj) { case Lisp_String: mark_p = (live_string_p (m, po) - && !STRING_MARKED_P ((struct Lisp_String *) po)); + && !XSTRING_MARKED_P ((struct Lisp_String *) po)); break; case Lisp_Cons: - mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj))); + mark_p = (live_cons_p (m, po) && !XCONS_MARKED_P (XCONS (obj))); break; case Lisp_Symbol: @@ -4734,7 +4949,7 @@ mark_maybe_object (Lisp_Object obj) break; case Lisp_Float: - mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj))); + mark_p = (live_float_p (m, po) && !XFLOAT_MARKED_P (XFLOAT (obj))); break; case Lisp_Vectorlike: @@ -4742,9 +4957,9 @@ mark_maybe_object (Lisp_Object obj) buffer because checking that dereferences the pointer PO which might point anywhere. */ if (live_vector_p (m, po)) - mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj)); + mark_p = !SUBRP (obj) && !XVECTOR_MARKED_P (XVECTOR (obj)); else if (live_buffer_p (m, po)) - mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj)); + mark_p = BUFFERP (obj) && !XVECTOR_MARKED_P (XBUFFER (obj)); break; case Lisp_Misc: @@ -4799,6 +5014,17 @@ mark_maybe_pointer (void *p) p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 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) { @@ -4812,18 +5038,18 @@ mark_maybe_pointer (void *p) break; case MEM_TYPE_BUFFER: - if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p)) + if (live_buffer_p (m, p) && !XVECTOR_MARKED_P ((struct buffer *)p)) XSETVECTOR (obj, p); break; case MEM_TYPE_CONS: - if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p)) + if (live_cons_p (m, p) && !XCONS_MARKED_P ((struct Lisp_Cons *) p)) XSETCONS (obj, p); break; case MEM_TYPE_STRING: if (live_string_p (m, p) - && !STRING_MARKED_P ((struct Lisp_String *) p)) + && !XSTRING_MARKED_P ((struct Lisp_String *) p)) XSETSTRING (obj, p); break; @@ -4838,7 +5064,7 @@ mark_maybe_pointer (void *p) break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p) && !FLOAT_MARKED_P (p)) + if (live_float_p (m, p) && !XFLOAT_MARKED_P (p)) XSETFLOAT (obj, p); break; @@ -4848,7 +5074,7 @@ mark_maybe_pointer (void *p) { Lisp_Object tem; XSETVECTOR (tem, p); - if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem))) + if (!SUBRP (tem) && !XVECTOR_MARKED_P (XVECTOR (tem))) obj = tem; } break; @@ -5122,6 +5348,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) @@ -5538,7 +5767,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)) @@ -5554,7 +5783,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); @@ -5564,7 +5794,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)) @@ -5633,7 +5863,7 @@ compact_undo_list (Lisp_Object list) { if (CONSP (XCAR (tail)) && MARKERP (XCAR (XCAR (tail))) - && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) + && !marker_marked_p (XMARKER (XCAR (XCAR (tail))))) *prev = XCDR (tail); else prev = xcdr_addr (tail); @@ -5659,6 +5889,69 @@ 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); +} + /* 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 @@ -5671,7 +5964,6 @@ 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; @@ -5752,14 +6044,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_symbols (); mark_specpdl (); @@ -5811,10 +6099,6 @@ garbage_collect_1 (void *end) gc_sweep (); - /* Clear the mark bits that we set in certain root slots. */ - VECTOR_UNMARK (&buffer_defaults); - VECTOR_UNMARK (&buffer_local_symbols); - check_cons_list (); gc_in_progress = 0; @@ -6014,7 +6298,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); } } @@ -6035,13 +6319,18 @@ static int last_marked_index; ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE; static void -mark_vectorlike (struct Lisp_Vector *ptr) +mark_vectorlike (struct 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->header) != PVEC_BOOL_VECTOR); + + set_vector_marked (ptr); /* Else mark it. */ if (size & PSEUDOVECTOR_FLAG) size &= PSEUDOVECTOR_SIZE_MASK; @@ -6064,17 +6353,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 (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)) + if (INTEGERP (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 @@ -6088,7 +6378,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]); @@ -6100,12 +6390,11 @@ mark_compiled (struct Lisp_Vector *ptr) static void mark_overlay (struct Lisp_Overlay *ptr) { - for (; ptr && !ptr->gcmarkbit; ptr = ptr->next) + for (; ptr && !overlay_marked_p (ptr); ptr = ptr->next) { - ptr->gcmarkbit = 1; - /* These two are always markers and can be marked fast. */ - XMARKER (ptr->start)->gcmarkbit = 1; - XMARKER (ptr->end)->gcmarkbit = 1; + set_overlay_marked (ptr); + mark_object (ptr->start); + mark_object (ptr->end); mark_object (ptr->plist); } } @@ -6116,11 +6405,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 @@ -6130,7 +6419,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); } @@ -6149,8 +6439,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]); @@ -6209,7 +6499,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); @@ -6219,7 +6509,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); } @@ -6228,6 +6518,79 @@ 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 + set_vector_marked (XVECTOR (h->key_and_value)); +} + +static enum pvec_type +find_pvec_type (const struct Lisp_Vector *ptr) +{ + enum pvec_type pvectype; + if (ptr->header.size & PSEUDOVECTOR_FLAG) + pvectype = ((ptr->header.size & PVEC_TYPE_MASK) + >> PSEUDOVECTOR_AREA_BITS); + else + pvectype = PVEC_NORMAL_VECTOR; + return pvectype; +} + /* Determine type of generic Lisp_Object and mark it accordingly. This function implements a straightforward depth-first marking @@ -6266,6 +6629,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 (); \ @@ -6275,6 +6644,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) @@ -6309,11 +6680,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->intervals); + set_string_marked (ptr); + mark_interval_tree (ptr->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. */ @@ -6327,21 +6698,19 @@ mark_object (Lisp_Object arg) register struct Lisp_Vector *ptr = XVECTOR (obj); register ptrdiff_t pvectype; - if (VECTOR_MARKED_P (ptr)) + if (vector_marked_p (ptr)) break; #ifdef GC_CHECK_MARKED_OBJECTS - m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj)) - emacs_abort (); + if (!pdumper_object_p(po)) + { + m = mem_find (po); + if (m == MEM_NIL && !SUBRP (obj)) + emacs_abort (); + } #endif /* GC_CHECK_MARKED_OBJECTS */ - if (ptr->header.size & PSEUDOVECTOR_FLAG) - pvectype = ((ptr->header.size & PVEC_TYPE_MASK) - >> PSEUDOVECTOR_AREA_BITS); - else - pvectype = PVEC_NORMAL_VECTOR; - + pvectype = find_pvec_type (ptr); if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER) CHECK_LIVE (live_vector_p); @@ -6359,77 +6728,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: @@ -6438,8 +6758,10 @@ mark_object (Lisp_Object arg) break; case PVEC_BOOL_VECTOR: - /* No Lisp_Objects to mark in a bool vector. */ - VECTOR_MARK (ptr); + /* Do not mark bool vectors in a dump image: these objects + are "cold" and don't have mark bits. */ + if (!pdumper_object_p (ptr)) + set_vector_marked (ptr); break; case PVEC_SUBR: @@ -6449,7 +6771,7 @@ mark_object (Lisp_Object arg) emacs_abort (); default: - mark_vectorlike (ptr); + mark_vectorlike (&ptr->header); } } break; @@ -6458,10 +6780,10 @@ mark_object (Lisp_Object arg) { register struct Lisp_Symbol *ptr = XSYMBOL (obj); nextsym: - if (ptr->gcmarkbit) - break; - CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - ptr->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->function)); mark_object (ptr->function); @@ -6488,8 +6810,8 @@ mark_object (Lisp_Object arg) default: emacs_abort (); } if (!PURE_P (XSTRING (ptr->name))) - MARK_STRING (XSTRING (ptr->name)); - MARK_INTERVAL_TREE (string_intervals (ptr->name)); + set_string_marked (XSTRING (ptr->name)); + mark_interval_tree (string_intervals (ptr->name)); /* Inner loop to mark next symbol in this bucket, if any. */ po = ptr = ptr->next; if (ptr) @@ -6500,8 +6822,8 @@ mark_object (Lisp_Object arg) case Lisp_Misc: CHECK_ALLOCATED_AND_LIVE (live_misc_p); - if (XMISCANY (obj)->gcmarkbit) - break; + if (misc_any_marked_p (XMISCANY (obj))) + break; switch (XMISCTYPE (obj)) { @@ -6509,11 +6831,11 @@ mark_object (Lisp_Object arg) /* DO NOT mark thru the marker's chain. The buffer's markers chain does not preserve markers from gc; instead, markers are removed from the chain when freed by gc. */ - XMISCANY (obj)->gcmarkbit = 1; + set_misc_any_marked (XMISCANY (obj)); break; case Lisp_Misc_Save_Value: - XMISCANY (obj)->gcmarkbit = 1; + set_misc_any_marked (XMISCANY (obj)); mark_save_value (XSAVE_VALUE (obj)); break; @@ -6522,46 +6844,51 @@ mark_object (Lisp_Object arg) break; case Lisp_Misc_Finalizer: - XMISCANY (obj)->gcmarkbit = true; + set_misc_any_marked (XMISCANY (obj)); mark_object (XFINALIZER (obj)->function); break; #ifdef HAVE_MODULES case Lisp_Misc_User_Ptr: - XMISCANY (obj)->gcmarkbit = true; + set_misc_any_marked (XMISCANY (obj)); break; #endif default: emacs_abort (); } + break; case Lisp_Cons: { register struct Lisp_Cons *ptr = XCONS (obj); - if (CONS_MARKED_P (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); - CONS_MARK (ptr); - /* If the cdr is nil, avoid recursion for the car. */ - if (EQ (ptr->u.cdr, Qnil)) - { - obj = ptr->car; - cdr_count = 0; - goto loop; - } - mark_object (ptr->car); - obj = ptr->u.cdr; - cdr_count++; - if (cdr_count == mark_object_loop_halt) - emacs_abort (); - goto loop; + if (cons_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_cons_p); + set_cons_marked (ptr); + /* If the cdr is nil, avoid recursion for the car. */ + if (EQ (ptr->u.cdr, Qnil)) + { + obj = ptr->car; + cdr_count = 0; + goto loop; + } + mark_object (ptr->car); + obj = ptr->u.cdr; + cdr_count++; + if (cdr_count == mark_object_loop_halt) + emacs_abort (); + goto loop; } 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)) && + !XFLOAT_MARKED_P (XFLOAT (obj))) + XFLOAT_MARK (XFLOAT (obj)); break; case_Lisp_Int: @@ -6575,6 +6902,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. */ @@ -6591,13 +6919,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. */ @@ -6613,27 +6939,29 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Symbol: - survives_p = XSYMBOL (obj)->gcmarkbit; + survives_p = symbol_marked_p (XSYMBOL (obj)); break; case Lisp_Misc: - survives_p = XMISCANY (obj)->gcmarkbit; + survives_p = misc_any_marked_p (XMISCANY (obj)); break; case Lisp_String: - survives_p = STRING_MARKED_P (XSTRING (obj)); + survives_p = string_marked_p (XSTRING (obj)); break; case Lisp_Vectorlike: - 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: @@ -6686,7 +7014,7 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - if (!CONS_MARKED_P (&cblk->conses[pos])) + if (!XCONS_MARKED_P (&cblk->conses[pos])) { this_free++; cblk->conses[pos].u.chain = cons_free_list; @@ -6696,7 +7024,7 @@ sweep_conses (void) else { num_used++; - CONS_UNMARK (&cblk->conses[pos]); + XUNMARK_CONS (&cblk->conses[pos]); } } } @@ -6739,7 +7067,7 @@ sweep_floats (void) register int i; int this_free = 0; for (i = 0; i < lim; i++) - if (!FLOAT_MARKED_P (&fblk->floats[i])) + if (!XFLOAT_MARKED_P (&fblk->floats[i])) { this_free++; fblk->floats[i].u.chain = float_free_list; @@ -6748,7 +7076,7 @@ sweep_floats (void) else { num_used++; - FLOAT_UNMARK (&fblk->floats[i]); + XFLOAT_UNMARK (&fblk->floats[i]); } lim = FLOAT_BLOCK_SIZE; /* If this block contains only free floats and we have already @@ -6962,14 +7290,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); total_buffers++; @@ -6983,7 +7312,7 @@ gc_sweep (void) { /* Remove or mark entries in weak hash tables. This must be done before any object is unmarked. */ - sweep_weak_hash_tables (); + mark_and_sweep_weak_hash_tables (); sweep_strings (); check_string_bytes (!noninteractive); @@ -6994,6 +7323,7 @@ gc_sweep (void) sweep_misc (); sweep_buffers (); sweep_vectors (); + pdumper_clear_marks (); check_string_bytes (!noninteractive); } @@ -7267,19 +7597,31 @@ 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; + /* 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); @@ -7288,11 +7630,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 diff --git a/src/atimer.c b/src/atimer.c index 64c9e8a..258c61f 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 aa556b7..58fd64f 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -43,6 +43,7 @@ along with GNU Emacs. If not, see . */ #include "keymap.h" #include "frame.h" #include "xwidget.h" +#include "pdumper.h" #ifdef WINDOWSNT #include "w32heap.h" /* for mmap_* */ @@ -524,6 +525,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 @@ -776,6 +779,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; @@ -4959,24 +4964,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, old_nbytes); + BUF_BEG_ADDR (b) = p; unblock_input (); } @@ -4989,13 +5007,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 (); @@ -5006,12 +5027,23 @@ 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; + 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. */ @@ -5096,13 +5128,20 @@ 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. */ + /* TODO: XXX: we no longer call mark_buffer on buffer_defaults, so + this work should be unnecessary. */ reset_buffer (&buffer_defaults); eassert (NILP (BVAR (&buffer_defaults, name))); reset_buffer_local_variables (&buffer_defaults, 1); @@ -5192,7 +5231,9 @@ init_buffer_once (void) Vbuffer_alist = Qnil; current_buffer = 0; + pdumper_remember_lv_raw_ptr (¤t_buffer, Lisp_Vectorlike); all_buffers = 0; + pdumper_remember_lv_raw_ptr (&all_buffers, Lisp_Vectorlike); QSFundamental = build_pure_c_string ("Fundamental"); @@ -5216,14 +5257,14 @@ init_buffer_once (void) } void -init_buffer (int initialized) +init_buffer (void) { char *pwd; Lisp_Object temp; ptrdiff_t len; #ifdef USE_MMAP_FOR_BUFFERS - if (initialized) + if (dumped_with_unexec) { struct buffer *b; @@ -5264,9 +5305,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/callint.c b/src/callint.c index c0afc7b..6baead9 100644 --- a/src/callint.c +++ b/src/callint.c @@ -883,7 +883,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 dc3ca4a..0db4dc7 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -1577,9 +1577,7 @@ init_callproc (void) } } -#ifndef CANNOT_DUMP - if (initialized) -#endif + if (!will_dump) { tempdir = Fdirectory_file_name (Vexec_directory); if (! file_accessible_directory_p (tempdir)) diff --git a/src/category.c b/src/category.c index 8315797..3522ce4 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. */ @@ -514,6 +505,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 ff937bc..8a339c2 100644 --- a/src/charset.c +++ b/src/charset.c @@ -40,6 +40,7 @@ along with GNU Emacs. If not, see . */ #include "charset.h" #include "coding.h" #include "buffer.h" +#include "pdumper.h" /*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) *** @@ -62,9 +63,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; @@ -843,6 +843,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"), @@ -1134,9 +1136,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 @@ -2303,15 +2305,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); } #ifdef emacs @@ -2400,21 +2413,32 @@ 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); } #endif /* emacs */ diff --git a/src/charset.h b/src/charset.h index 8e77567..00c9b7e 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 feed9c8..4024bee 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; @@ -10755,6 +10756,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; @@ -10774,6 +10778,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; @@ -10782,6 +10788,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); } #ifdef emacs @@ -10805,6 +10813,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/conf_post.h b/src/conf_post.h index 060b912..833beb0 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -265,8 +265,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 d221db4..1de42b7 100644 --- a/src/data.c +++ b/src/data.c @@ -740,7 +740,7 @@ The return value is undefined. */) { bool autoload = AUTOLOADP (definition); - if (NILP (Vpurify_flag) || !autoload) + if (!will_dump || !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. */ diff --git a/src/dbusbind.c b/src/dbusbind.c index a0146a3..e7aabbf 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -1827,6 +1827,8 @@ be called when the D-Bus reply message arrives. */); xd_registered_buses = Qnil; staticpro (&xd_registered_buses); + // XXX: reset buses on dump load + Fprovide (intern_c_string ("dbusbind"), Qnil); } diff --git a/src/dispnew.c b/src/dispnew.c index 70d4de0..b266b6e 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -41,6 +41,7 @@ along with GNU Emacs. If not, see . */ #include "systime.h" #include "tparam.h" #include "xwidget.h" +#include "pdumper.h" #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER @@ -5960,9 +5961,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) { struct sigaction action; emacs_sigaction_init (&action, deliver_window_change_signal); @@ -6026,11 +6025,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) { Vinitial_window_system = Qns; Vwindow_system_version = make_number (10); @@ -6118,10 +6113,8 @@ 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)) + /* Set up faces of the initial terminal frame. */ + if (!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. */ @@ -6168,6 +6161,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) { @@ -6275,11 +6270,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/doc.c b/src/doc.c index ce4f89b..c71e393 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) + 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) { /* 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) @@ -544,12 +541,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) { dirname = sibling_etc; dirlen = sizeof sibling_etc - 1; diff --git a/src/editfns.c b/src/editfns.c index 72c7a9c..3e64473 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -228,7 +228,7 @@ tzlookup (Lisp_Object zone, bool settz) } void -init_editfns (bool dumping) +init_editfns (void) { const char *user_name; register char *p; @@ -238,10 +238,9 @@ init_editfns (bool dumping) /* Set up system_name even when dumping. */ init_and_cache_system_name (); -#ifndef CANNOT_DUMP /* 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) { # ifdef HAVE_TZSET xputenv (dump_tz_string); @@ -249,17 +248,17 @@ init_editfns (bool dumping) # endif return; } -#endif char *tz = getenv ("TZ"); -#if !defined CANNOT_DUMP && defined HAVE_TZSET +#if defined HAVE_TZSET /* If the execution TZ happens to be the same as the dump TZ, change it to some other value and then change it back, to force the underlying implementation to reload the TZ info. This is needed on implementations that load TZ info from files, since the TZ file contents may differ between dump and execution. */ - if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0) + if (dumped_with_unexec && + tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0) { ++*tz; tzset (); @@ -1341,7 +1340,7 @@ of the user with that uid, or nil if there is no such user. */) (That can happen if Emacs is dumpable but you decide to run `temacs -l loadup' and not dump. */ if (NILP (Vuser_login_name)) - init_editfns (false); + init_editfns (); if (NILP (uid)) return Vuser_login_name; @@ -1364,7 +1363,7 @@ This ignores the environment variables LOGNAME and USER, so it differs from (That can happen if Emacs is dumpable but you decide to run `temacs -l loadup' and not dump. */ if (NILP (Vuser_login_name)) - init_editfns (false); + init_editfns (); return Vuser_real_login_name; } diff --git a/src/emacs-module.c b/src/emacs-module.c index 68aeb0c..ac84473 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -1010,7 +1010,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 efd4fa3..0380b5f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -113,6 +113,9 @@ extern void moncontrol (int mode); #include #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; @@ -125,16 +128,7 @@ 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. */ -bool initialized; - -/* Set to true if this instance of Emacs might dump. */ -#ifndef DOUG_LEA_MALLOC -static -#endif -bool might_dump; +struct gflags gflags; #ifdef DARWIN_OS extern void unexec_init_emacs_zone (void); @@ -509,8 +503,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *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; } } @@ -535,8 +528,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char *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; } } @@ -664,6 +656,136 @@ close_output_streams (void) _exit (EXIT_FAILURE); } +static bool +string_starts_with_p(const char* string, const char* prefix) +{ + return strncmp(string, prefix, strlen(prefix)) == 0; +} + +#define DUMP_FILE_ARGUMENT "--dump-file" + +static char * +find_and_remove_dump_file_argument (int *inout_argc, char ***inout_argv) +{ + int argc = *inout_argc; + char **argv = *inout_argv; + char *found = NULL; + int i; + + for (i = 1; i < argc; ++i) + if (string_starts_with_p (argv[i], DUMP_FILE_ARGUMENT) && + ((argv[i] + strlen (DUMP_FILE_ARGUMENT))[0] == '=' || + (argv[i] + strlen (DUMP_FILE_ARGUMENT))[0] == '\0')) + { + int j = i; + found = argv[j++] + strlen (DUMP_FILE_ARGUMENT); + if (*found == '=') + ++found; + else if (i < argc) + found = argv[j++]; + else + { + fprintf (stderr, "%s: no argument given for %s\n", + argv[0], DUMP_FILE_ARGUMENT); + exit (1); + } + + memmove (&argv[i], &argv[j], sizeof (*argv) * (argc - j)); + argc -= (j - i); + argv[argc] = NULL; + break; + } + else if (strcmp (argv[i], "--") == 0) + break; + + *inout_argc = argc; + *inout_argv = argv; + return found; +} + +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_VERSION_MISMATCH: + return "not built for this Emacs executable"; + default: + return "generic error"; + } +} + +static const char * +load_dump (int *inout_argc, char ***inout_argv, char *argv0_base) +{ + int argc = *inout_argc; + char **argv = *inout_argv; + const char *suffix = ".pdmp"; + enum pdumper_load_result result; + + char *dump_file = find_and_remove_dump_file_argument (&argc, &argv); + if (initialized && dump_file) + /* TODO: maybe more thoroughly scrub process environment in order + to make this use case possible? Right now, we assume that + things we don't touch are zero-initialized, and in an unexeced + Emacs, this assumption doesn't hold. */ + fatal ("cannot load dump file into unexeced Emacs"); + + if (initialized) + return NULL; + + 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; + + dump_file = alloca (strlen (argv[0]) + strlen (suffix) + 1); + 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)); + + /* For searching PATH_EXEC, just use "emacs". Emacs shouldn't break + if its binary is renamed. */ + argv0_base = "emacs"; + 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: + *inout_argc = argc; + *inout_argv = argv; + return dump_file ? strdup (dump_file) : NULL; +} + /* ARGSUSED */ int main (int argc, char **argv) @@ -671,7 +793,6 @@ main (int argc, char **argv) Lisp_Object dummy; char stack_bottom_variable; bool do_initial_setlocale; - bool dumping; int skip_args = 0; bool no_loadup = false; char *junk = 0; @@ -686,14 +807,36 @@ main (int argc, char **argv) stack_base = &dummy; - dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0 - || strcmp (argv[argc - 1], "bootstrap") == 0); + /* Figure out where we are. Fancy filesystem functions aren't + available at this point, so use pure text manipulation. */ + char *argv0_base = strrchr (argv[0], DIRECTORY_SEP); + argv0_base = argv0_base ? argv0_base + 1 : argv[0]; + bool is_temacs = strcmp ("temacs", argv0_base) == 0; + const char *loaded_dump = NULL; + + const char *dump_mode = NULL; + if (!initialized && is_temacs) + { +#ifndef CANNOT_DUMP + if (strcmp (argv[argc - 1], "dump") == 0 || + strcmp (argv[argc - 1], "bootstrap")) + gflags.will_dump_with_unexec_ = true; +#endif + if (strcmp (argv[argc - 1], "pdump") == 0 || + strcmp (argv[argc - 1], "pbootstrap")) + gflags.will_dump_with_pdumper_ = true; + gflags.will_dump_ = will_dump_with_pdumper || will_dump_with_unexec; + if (will_dump) + dump_mode = argv[argc - 1]; + } + else if (!is_temacs) + loaded_dump = load_dump (&argc, &argv, argv0_base); /* True if address randomization interferes with memory allocation. */ # ifdef __PPC64__ bool disable_aslr = true; # else - bool disable_aslr = dumping; + bool disable_aslr = will_dump_with_unexec; # endif if (disable_aslr && disable_address_randomization ()) @@ -710,10 +853,6 @@ main (int argc, char **argv) perror (argv[0]); } -#ifndef CANNOT_DUMP - might_dump = !initialized; -#endif - #ifdef GNU_LINUX if (!initialized) { @@ -841,10 +980,7 @@ main (int argc, char **argv) /* Extra space to cover what we're likely to use for other reasons. */ int extra = 200000; - 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) { @@ -1173,17 +1309,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) malloc_enable_thread (); #endif - init_signals (dumping); + init_signals (); noninteractive1 = noninteractive; @@ -1192,7 +1326,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!initialized) { init_alloc_once (); - init_obarray (); + init_obarray_once (); init_eval_once (); init_charset_once (); init_coding_once (); @@ -1230,7 +1364,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. */ @@ -1389,7 +1523,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) set_initial_environment (); #ifdef WINDOWSNT @@ -1403,7 +1537,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); /* must precede init_editfns. */ #endif /* AIX crashes are reported in system versions 3.2.3 and 3.2.4 @@ -1415,7 +1549,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. */ @@ -1581,6 +1715,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif /* WINDOWSNT */ syms_of_profiler (); + syms_of_pdumper (); keys_of_casefiddle (); keys_of_cmds (); @@ -1608,7 +1743,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* This calls putenv and so must precede init_process_emacs. Also, it sets Voperating_system_release, which init_process_emacs uses. */ - init_editfns (dumping); + init_editfns (); /* These two call putenv. */ #ifdef HAVE_DBUS @@ -1679,7 +1814,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif #endif - initialized = 1; + gflags.initialized_ = true; + + Fset (intern ("dump-mode"), dump_mode ? build_string (dump_mode) : Qnil); + if (loaded_dump) + Vdump_file_name = build_string (loaded_dump); // XXX: filesystem decode /* Enter editor command loop. This never returns. */ Frecursive_edit (); @@ -2184,12 +2323,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 @@ -2203,6 +2349,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, ""). */ @@ -2531,7 +2678,11 @@ 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 ("dump-file-name", Vdump_file_name, + doc: /* Name of the dump file used to start this Emacs process. */); DEFVAR_LISP ("kill-emacs-hook", Vkill_emacs_hook, doc: /* Hook run when `kill-emacs' is called. diff --git a/src/eval.c b/src/eval.c index 884e1eb..d3e9435 100644 --- a/src/eval.c +++ b/src/eval.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include "keyboard.h" #include "dispextern.h" #include "buffer.h" +#include "pdumper.h" /* Chain of condition and catch handlers currently in effect. */ @@ -78,10 +79,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; @@ -204,18 +201,25 @@ near_C_stack_top (void) return backtrace_args (backtrace_top ()); } +static void init_eval_once_for_pdumper (void); + 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; @@ -1954,7 +1958,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) error ("Attempt to autoload %s while preparing to dump", SDATA (SYMBOL_NAME (funname))); @@ -3711,33 +3715,33 @@ mark_specpdl (void) for (pdl = specpdl; pdl != specpdl_ptr; pdl++) { switch (pdl->kind) - { - case SPECPDL_UNWIND: - mark_object (specpdl_arg (pdl)); - break; - - case SPECPDL_BACKTRACE: - { - ptrdiff_t nargs = backtrace_nargs (pdl); - mark_object (backtrace_function (pdl)); - if (nargs == UNEVALLED) - nargs = 1; - while (nargs--) - mark_object (backtrace_args (pdl)[nargs]); - } - break; - - case SPECPDL_LET_DEFAULT: - case SPECPDL_LET_LOCAL: - mark_object (specpdl_where (pdl)); - /* Fall through. */ - case SPECPDL_LET: - mark_object (specpdl_symbol (pdl)); - mark_object (specpdl_old_value (pdl)); - break; - - case SPECPDL_UNWIND_PTR: - case SPECPDL_UNWIND_INT: + { + case SPECPDL_UNWIND: + mark_object (specpdl_arg (pdl)); + break; + + case SPECPDL_BACKTRACE: + { + ptrdiff_t nargs = backtrace_nargs (pdl); + mark_object (backtrace_function (pdl)); + if (nargs == UNEVALLED) + nargs = 1; + while (nargs--) + mark_object (backtrace_args (pdl)[nargs]); + } + break; + + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET_LOCAL: + mark_object (specpdl_where (pdl)); + /* Fall through. */ + case SPECPDL_LET: + mark_object (specpdl_symbol (pdl)); + mark_object (specpdl_old_value (pdl)); + break; + + case SPECPDL_UNWIND_PTR: + case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_VOID: break; @@ -3924,8 +3928,6 @@ alist of active lexical bindings. */); staticpro (&Vsignaling_function); Vsignaling_function = Qnil; - inhibit_lisp_code = Qnil; - defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); diff --git a/src/filelock.c b/src/filelock.c index a4b742a..5ffdf72 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) return boot_time; -#endif /* not CANNOT_DUMP */ /* Try to get boot time from utmp before wtmp, since utmp is typically much smaller than wtmp. @@ -671,7 +668,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) return; orig_fn = fn; diff --git a/src/fingerprint-dummy.c b/src/fingerprint-dummy.c new file mode 100644 index 0000000..295654a --- /dev/null +++ b/src/fingerprint-dummy.c @@ -0,0 +1,24 @@ +/* Dummy fingerprint + +Copyright (C) 2016 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include "fingerprint.h" + +/* Dummy fingerprint to use as hash input. */ +const uint8_t fingerprint[32] = { 0 }; diff --git a/src/fingerprint.h b/src/fingerprint.h new file mode 100644 index 0000000..b48d40f --- /dev/null +++ b/src/fingerprint.h @@ -0,0 +1,32 @@ +/* Header file for the Emacs build fingerprint. + +Copyright (C) 2016 Free Software Foundation, +Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef EMACS_FINGERPRINT_H +#define EMACS_FINGERPRINT_H + +#include + +/* 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 dfc7842..645c0bf 100644 --- a/src/fns.c +++ b/src/fns.c @@ -34,6 +34,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "intervals.h" #include "window.h" +#include "pdumper.h" static void sort_vector_copy (Lisp_Object, ptrdiff_t, Lisp_Object *restrict, Lisp_Object *restrict); @@ -2864,7 +2865,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) error ("(require %s) while preparing to dump", SDATA (SYMBOL_NAME (feature))); @@ -3735,7 +3736,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); @@ -3745,7 +3746,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) ? hashfn_equal (ht, key) : hashfn_eq (ht, key); @@ -3980,6 +3981,51 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) } } +static bool +hash_rehash_needed_p (const struct Lisp_Hash_Table *h) +{ + return h->count < 0; +} + +static void +hash_table_rehash (struct Lisp_Hash_Table *h) +{ + ptrdiff_t size = ASIZE (h->next); + Lisp_Object hash = h->hash; + Lisp_Object kv = h->key_and_value; + for (ptrdiff_t i = 0; i < size; ++i) + if (!NILP (AREF (hash, i))) + { + Lisp_Object key = AREF (kv, 2*i); + EMACS_UINT hash_code = h->test.hashfn (&h->test, key); + ASET (hash, i, make_number (hash_code)); + } + Lisp_Object index = h->index; + Ffillarray (index, Qnil); + Lisp_Object next = h->next; + for (ptrdiff_t i = 0; i < size; ++i) + if (!NILP (AREF (hash, i))) + { + EMACS_UINT hash_code = XUINT (AREF (hash, i)); + ptrdiff_t start_of_bucket = hash_code % ASIZE (index); + ASET (next, i, AREF (index, start_of_bucket)); + ASET (index, start_of_bucket, make_number (i)); + eassert (!EQ (AREF (next, i), make_number (i))); /* Stop loops. */ + } +} + +static void +hash_rehash_if_needed (struct Lisp_Hash_Table *h) +{ + if (hash_rehash_needed_p (h)) + { + hash_table_rehash (h); + /* Do 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 @@ -3992,6 +4038,8 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash) ptrdiff_t start_of_bucket; Lisp_Object idx; + hash_rehash_if_needed (h); + hash_code = h->test.hashfn (&h->test, key); eassert ((hash_code & ~INTMASK) == 0); if (hash) @@ -4025,6 +4073,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. */ @@ -4057,6 +4107,8 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) ptrdiff_t start_of_bucket; Lisp_Object idx, prev; + hash_rehash_if_needed (h); + hash_code = h->test.hashfn (&h->test, key); eassert ((hash_code & ~INTMASK) == 0); start_of_bucket = hash_code % ASIZE (h->index); @@ -4103,6 +4155,9 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) static void hash_clear (struct Lisp_Hash_Table *h) { + if (CONSP (h->index)) + h->index = CDR (h->index); + if (h->count > 0) { ptrdiff_t i, size = HASH_TABLE_SIZE (h); @@ -4137,6 +4192,8 @@ hash_clear (struct Lisp_Hash_Table *h) static bool sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) { + eassert (!hash_rehash_needed_p (h)); + ptrdiff_t n = gc_asize (h->index); bool marked = false; @@ -4221,9 +4278,17 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) current garbage collection. Remove weak tables that don't survive from Vweak_hash_tables. Called from gc_sweep. */ +static bool +ht_marked_p (struct Lisp_Hash_Table *h) +{ + return pdumper_object_p (h) + ? pdumper_marked_p (h) + : !!(h->header.size & ARRAY_MARK_FLAG); +} + NO_INLINE /* For better stack traces */ void -sweep_weak_hash_tables (void) +mark_and_sweep_weak_hash_tables (void) { struct Lisp_Hash_Table *h, *used, *next; bool marked; @@ -4239,7 +4304,7 @@ sweep_weak_hash_tables (void) marked = 0; for (h = weak_hash_tables; h; h = h->next_weak) { - if (h->header.size & ARRAY_MARK_FLAG) + if (ht_marked_p (h)) marked |= sweep_weak_table (h, 0); } } @@ -4250,7 +4315,7 @@ sweep_weak_hash_tables (void) { next = h->next_weak; - if (h->header.size & ARRAY_MARK_FLAG) + if (ht_marked_p (h)) { /* TABLE is marked as used. Sweep its contents. */ if (h->count > 0) @@ -5066,9 +5131,14 @@ If nil, use the current buffer." */ ) } +static void syms_of_fns_for_pdumper (void); + void syms_of_fns (void) { + /* Not staticpro! */ + pdumper_remember_lv_raw_ptr (&weak_hash_tables, Lisp_Vectorlike); + DEFSYM (Qmd5, "md5"); DEFSYM (Qsha1, "sha1"); DEFSYM (Qsha224, "sha224"); @@ -5232,4 +5302,20 @@ this variable. */); defsubr (&Ssecure_hash); defsubr (&Sbuffer_hash); defsubr (&Slocale_info); + + pdumper_do_now_and_after_load (syms_of_fns_for_pdumper); +} + +static void +syms_of_fns_for_pdumper (void) +{ + /* Rehash weak tables eagerly on dump load so that we don't have to + support running hash_rehash_if_needed during GC. (Rehashing can + invoke user-defined code, and we can't support running arbitrary + user code during GC. */ + if (dumped_with_pdumper) + for (struct Lisp_Hash_Table *ht = weak_hash_tables; + ht != NULL; + ht = ht->next_weak) + hash_rehash_if_needed (ht); } diff --git a/src/font.c b/src/font.c index ce63233..7612f48 100644 --- a/src/font.c +++ b/src/font.c @@ -38,6 +38,7 @@ along with GNU Emacs. If not, see . */ #include "fontset.h" #include "font.h" #include "termhooks.h" +#include "pdumper.h" #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER @@ -5293,9 +5294,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"); @@ -5333,13 +5335,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 = Fmake_vector (make_number (3), Qnil); + staticpro (&Vfont_log_deferred); #if 0 #ifdef HAVE_LIBOTF diff --git a/src/fontset.c b/src/fontset.c index 38ff780..130293d 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -39,6 +39,7 @@ along with GNU Emacs. If not, see . */ #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ #include "font.h" +#include "pdumper.h" /* FONTSET @@ -2126,6 +2127,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 b1d89f3..6e75dc3 100644 --- a/src/frame.c +++ b/src/frame.c @@ -52,6 +52,7 @@ along with GNU Emacs. If not, see . */ #ifdef USE_X_TOOLKIT #include "widget.h" #endif +#include "pdumper.h" /* The currently selected frame. */ @@ -840,10 +841,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 (); @@ -4904,6 +4902,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) { @@ -5304,8 +5322,6 @@ This variable is effective only with the X toolkit (and there only when Gtk+ tooltips are not used) and on Windows. */); tooltip_reuse_hidden_frame = false; - staticpro (&Vframe_list); - defsubr (&Sframep); defsubr (&Sframe_live_p); defsubr (&Swindow_system); diff --git a/src/fringe.c b/src/fringe.c index 986bde1..4515186 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" #include "termhooks.h" +#include "pdumper.h" /* Fringe bitmaps are represented in three different ways: @@ -1725,12 +1726,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 2676502..4532152 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -26,6 +26,7 @@ along with GNU Emacs. If not, see . */ #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); + void syms_of_ftcrfont (void) { @@ -289,7 +292,11 @@ syms_of_ftcrfont (void) abort (); DEFSYM (Qftcr, "ftcr"); +} +static void +syms_of_ftcrfont_for_pdumper (void) +{ ftcrfont_driver = ftfont_driver; ftcrfont_driver.type = Qftcr; ftcrfont_driver.list = ftcrfont_list; diff --git a/src/ftfont.c b/src/ftfont.c index 1ae3f88..d1e234f 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -34,6 +34,7 @@ along with GNU Emacs. If not, see . */ #include "composite.h" #include "font.h" #include "ftfont.h" +#include "pdumper.h" /* Flag to tell if FcInit is already called or not. */ static bool fc_initialized; @@ -2776,6 +2777,8 @@ ftfont_combining_capability (struct font *font) #endif } +static void syms_of_ftfont_for_pdumper (void); + void syms_of_ftfont (void) { @@ -2799,6 +2802,13 @@ 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); ftfont_driver.type = Qfreetype; register_font_driver (&ftfont_driver, NULL); } diff --git a/src/ftxfont.c b/src/ftxfont.c index bfdeb40..ea7f476 100644 --- a/src/ftxfont.c +++ b/src/ftxfont.c @@ -28,6 +28,7 @@ along with GNU Emacs. If not, see . */ #include "frame.h" #include "blockinput.h" #include "font.h" +#include "pdumper.h" /* FTX font driver. */ @@ -345,10 +346,18 @@ ftxfont_end_for_frame (struct frame *f) +static void syms_of_ftxfont_for_pdumper (void); + 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) +{ ftxfont_driver = ftfont_driver; ftxfont_driver.type = Qftx; diff --git a/src/gnutls.c b/src/gnutls.c index af2ba52..c7c708b 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see . */ #include "process.h" #include "gnutls.h" #include "coding.h" +#include "pdumper.h" #ifdef HAVE_GNUTLS @@ -1726,6 +1727,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 d82fedb..3c818a2 100644 --- a/src/image.c +++ b/src/image.c @@ -45,6 +45,7 @@ along with GNU Emacs. If not, see . */ #include "coding.h" #include "termhooks.h" #include "font.h" +#include "pdumper.h" #ifdef HAVE_SYS_STAT_H #include @@ -9794,7 +9795,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 ed914ec..3b4594e 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #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); @@ -1912,6 +1913,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 9a38d84..8ea36d9 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -26,7 +26,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 65938a5..c5a7f4d 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -66,6 +66,8 @@ along with GNU Emacs. If not, see . */ #include +#include "pdumper.h" + #ifdef HAVE_WINDOW_SYSTEM #include TERM_HEADER #endif /* HAVE_WINDOW_SYSTEM */ @@ -10996,6 +10998,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) { @@ -11006,9 +11010,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'. */); @@ -11820,7 +11826,38 @@ otherwise be lost. If nil, crash 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); } @@ -11911,8 +11948,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)); @@ -11936,17 +11973,17 @@ mark_kboards (void) union buffered_input_event *event; for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++) { - if (event == kbd_buffer + KBD_BUFFER_SIZE) - event = kbd_buffer; - /* These two special event types has no Lisp_Objects to mark. */ - if (event->kind != SELECTION_REQUEST_EVENT - && event->kind != SELECTION_CLEAR_EVENT) - { - mark_object (event->ie.x); - mark_object (event->ie.y); - mark_object (event->ie.frame_or_window); - mark_object (event->ie.arg); - } + if (event == kbd_buffer + KBD_BUFFER_SIZE) + event = kbd_buffer; + /* These two special event types has no Lisp_Objects to mark. */ + if (event->kind != SELECTION_REQUEST_EVENT + && event->kind != SELECTION_CLEAR_EVENT) + { + mark_object (event->ie.x); + mark_object (event->ie.y); + mark_object (event->ie.frame_or_window); + mark_object (event->ie.arg); + } } } } diff --git a/src/lisp.h b/src/lisp.h index e087828..73ccdee 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -343,9 +343,13 @@ error !; (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \ + (char *) lispsym)) # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) +#if 0 /* XXX */ # define lisp_h_XUNTAG(a, type) \ __builtin_assume_aligned ((void *) (intptr_t) (XLI (a) - (type)), \ - GCALIGNMENT) + GCALIGNMENT) +#else +# define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type))) +#endif #endif /* When compiling via gcc -O0, define the key operations as macros, as @@ -604,12 +608,42 @@ extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); /* Defined in emacs.c. */ -#ifdef DOUG_LEA_MALLOC -extern bool might_dump; + +extern struct gflags { + /* Set after Emacs has started up the first time. + Prevents reinitialization of the Lisp world and keymaps + on subsequent starts. */ + bool initialized_ : 1; + /* True means this Emacs instance was born to dump. */ + bool will_dump_ : 1; + bool will_dump_with_pdumper_ : 1; +#ifndef CANNOT_DUMP + bool will_dump_with_unexec_ : 1; +#endif +#ifndef CANNOT_DUMP + /* Set in an Emacs process that has been restored from an unexec + dump. */ + bool dumped_with_unexec_ : 1; #endif -/* True means Emacs has already been initialized. - Used during startup to detect startup of dumped Emacs. */ -extern bool initialized; + /* Set in an Emacs process that has been restored from a portable + dump. */ + bool dumped_with_pdumper_ : 1; +} gflags; + +#define CONST_GFLAGS ((const struct gflags *)(&gflags)) + +#define initialized CONST_GFLAGS->initialized_ +#define will_dump CONST_GFLAGS->will_dump_ +#define will_dump_with_pdumper CONST_GFLAGS->will_dump_with_pdumper_ +#ifdef CANNOT_DUMP +# define will_dump_with_unexec false +# define dumped_with_unexec false +#else +# define will_dump_with_unexec CONST_GFLAGS->will_dump_with_unexec_ +# define dumped_with_unexec CONST_GFLAGS->dumped_with_unexec_ +#endif + +#define dumped_with_pdumper CONST_GFLAGS->dumped_with_pdumper_ /* Defined in floatfns.c. */ extern double extract_float (Lisp_Object); @@ -744,6 +778,19 @@ struct Lisp_Symbol # 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" /* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. @@ -2279,6 +2326,9 @@ struct Lisp_Finalizer Lisp_Object function; }; +extern struct Lisp_Finalizer finalizers; +extern struct Lisp_Finalizer doomed_finalizers; + /* A miscellaneous object, when it's on the free list. */ struct Lisp_Free { @@ -2664,8 +2714,16 @@ BUFFER_OBJFWDP (union Lisp_Fwd *a) return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; } +INLINE enum pvec_type +PSEUDOVECTOR_TYPE (const struct vectorlike_header *a) +{ + return ((a->size & PSEUDOVECTOR_FLAG) + ? (a->size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS + : PVEC_NORMAL_VECTOR); +} + INLINE bool -PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code) +PSEUDOVECTOR_TYPEP (const struct vectorlike_header *a, int code) { return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); @@ -2920,6 +2978,16 @@ CHECK_NUMBER_CDR (Lisp_Object x) XSETCDR (x, tmp); } + +/* If we're not dumping and we might be using the portable dumper, try + to bunch all the subr structures together for more efficient dump + loading. */ +#ifdef CANNOT_DUMP +# define SUBR_SECTION_ATTRIBUTE ATTRIBUTE_SECTION (".subrs") +#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. @@ -2950,6 +3018,7 @@ CHECK_NUMBER_CDR (Lisp_Object x) #ifdef _MSC_VER #define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \ + SUBR_SECTION_ATTRIBUTE \ static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \ | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \ @@ -2958,6 +3027,7 @@ CHECK_NUMBER_CDR (Lisp_Object x) Lisp_Object fnname #else /* not _MSC_VER */ #define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + SUBR_SECTION_ATTRIBUTE \ static struct Lisp_Subr alignas (GCALIGNMENT) sname = \ { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ @@ -3234,6 +3304,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; @@ -3426,9 +3501,11 @@ extern void syms_of_syntax (void); enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; 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 void mark_and_sweep_weak_hash_tables (void); 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, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); @@ -3590,6 +3667,9 @@ extern Lisp_Object *stack_base; extern EMACS_INT consing_since_gc; extern EMACS_INT gc_relative_threshold; extern EMACS_INT memory_full_cons_threshold; +#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); @@ -3599,6 +3679,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 @@ -3627,6 +3722,7 @@ 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 vector_nbytes (struct Lisp_Vector *v); /* Make unibyte string from C string when the length isn't known. */ @@ -3827,7 +3923,7 @@ extern Lisp_Object string_to_number (char const *, int, bool); 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); @@ -3847,7 +3943,6 @@ intern_c_string (const char *str) extern Lisp_Object Vautoload_queue; extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; -extern Lisp_Object inhibit_lisp_code; extern struct handler *handlerlist; /* To run a normal hook, use the appropriate function from the list below. @@ -3945,7 +4040,7 @@ extern _Noreturn void time_overflow (void); extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool); extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); -extern void init_editfns (bool); +extern void init_editfns (void); extern void syms_of_editfns (void); /* Defined in buffer.c. */ @@ -3960,7 +4055,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); @@ -4104,6 +4199,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 eab9b8b..9466827 100644 --- a/src/lread.c +++ b/src/lread.c @@ -42,6 +42,7 @@ along with GNU Emacs. If not, see . */ #include "systime.h" #include "termhooks.h" #include "blockinput.h" +#include "pdumper.h" #include #ifdef MSDOS @@ -1826,7 +1827,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 && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename)) && !NILP (Ffboundp (Qfile_truename))) sourcename = call1 (Qfile_truename, sourcename) ; @@ -3980,13 +3981,6 @@ usage: (unintern NAME OBARRAY) */) if (SYMBOLP (name) && !EQ (name, tem)) return Qnil; - /* There are plenty of other symbols which will screw up the Emacs - session if we unintern them, as well as even more ways to use - `setq' or `fset' or whatnot to make the Emacs session - unusable. Let's not go down this silly road. --Stef */ - /* if (EQ (tem, Qnil) || EQ (tem, Qt)) - error ("Attempt to unintern t or nil"); */ - XSYMBOL (tem)->interned = SYMBOL_UNINTERNED; hash = oblookup_last_bucket_number; @@ -4101,11 +4095,12 @@ OBARRAY defaults to the value of `obarray'. */) #define OBARRAY_SIZE 1511 +static void init_obarray_once_for_pdumper (void); + void -init_obarray (void) +init_obarray_once (void) { Lisp_Object oblength; - ptrdiff_t size = 100 + MAX_MULTIBYTE_LENGTH; XSETFASTINT (oblength, OBARRAY_SIZE); @@ -4128,15 +4123,25 @@ init_obarray (void) XSYMBOL (Qt)->constant = 1; XSYMBOL (Qt)->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"); + pdumper_do_now_and_after_load (init_obarray_once_for_pdumper); +} + +static void +init_obarray_once_for_pdumper (void) +{ + ptrdiff_t size = 100 + MAX_MULTIBYTE_LENGTH; read_buffer = xmalloc (size); read_buffer_size = size; } + +int ndefsubr; + void defsubr (struct Lisp_Subr *sname) { @@ -4145,6 +4150,7 @@ defsubr (struct Lisp_Subr *sname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); + ++ndefsubr; } #ifdef NOTDEF /* Use fset in subr.el now! */ @@ -4262,9 +4268,9 @@ load_path_check (Lisp_Object lpath) are running uninstalled. Uses the following logic: - If CANNOT_DUMP: 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. @@ -4287,129 +4293,109 @@ load_path_check (Lisp_Object lpath) static Lisp_Object load_path_default (void) { + if (will_dump) + /* 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; -#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)) { - Lisp_Object tem, 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); + } - /* 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 (NILP (Fequal (Vinstallation_directory, Vsource_directory))) + { + Lisp_Object tem2; - /* 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. */ + 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; } @@ -4420,11 +4406,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; if (use_loadpath && egetenv ("EMACSLOADPATH")) { @@ -4475,7 +4457,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 && !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 3af9edc..233fa47 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -35,6 +35,7 @@ #include "nsterm.h" #include "macfont.h" #include "macuvs.h" +#include "pdumper.h" #include @@ -1032,12 +1033,12 @@ sorted in the canonical order (CTFontManagerCompareFontFamilyNames on 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, @@ -4054,13 +4055,12 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no } + void syms_of_macfont (void) { /* Core Text, for macOS. */ DEFSYM (Qmac_ct, "mac-ct"); - macfont_driver.type = Qmac_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 @@ -4075,4 +4075,18 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no 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 (RESTORING_FROM_DUMP) + 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 638810b..d530689 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1574,9 +1574,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 57eea05..ffd1d9c 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "window.h" #include "keymap.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 @@ -1888,21 +1889,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"); @@ -1912,7 +1928,6 @@ syms_of_minibuf (void) DEFSYM (Qminibuffer_completion_table, "minibuffer-completion-table"); staticpro (&last_minibuf_string); - last_minibuf_string = Qnil; DEFSYM (Qminibuffer_history, "minibuffer-history"); DEFSYM (Qbuffer_name_history, "buffer-name-history"); diff --git a/src/nsfns.m b/src/nsfns.m index cfaaf53..340fc9c 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -49,7 +49,6 @@ Updated by Christian Limpach (chris@nice.ch) #include "macfont.h" #endif - #ifdef HAVE_NS static EmacsTooltip *ns_tooltip = nil; @@ -3068,6 +3067,11 @@ - (NSString *)panel: (id)sender userEnteredFilename: (NSString *)filename ========================================================================== */ +static void +syms_of_nsfns_1 (void) +{ + +} void syms_of_nsfns (void) @@ -3147,5 +3151,6 @@ - (NSString *)panel: (id)sender userEnteredFilename: (NSString *)filename as_status = 0; as_script = Qnil; + staticpro (&as_script); as_result = 0; } diff --git a/src/nsfont.m b/src/nsfont.m index 389d0ed..236bda2 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -36,6 +36,7 @@ #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 @@ -1520,12 +1521,11 @@ - (void)setIntAttribute: (NSInteger)attributeTag value: (NSInteger)val fprintf (stderr, "\n"); } +static void syms_of_nsfont_for_pdumper (void); void syms_of_nsfont (void) { - nsfont_driver.type = Qns; - register_font_driver (&nsfont_driver, NULL); DEFSYM (Qcondensed, "condensed"); DEFSYM (Qexpanded, "expanded"); DEFSYM (Qapple, "apple"); @@ -1533,5 +1533,13 @@ - (void)setIntAttribute: (NSInteger)attributeTag value: (NSInteger)val 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); +} + +static void +syms_of_nsfont_for_pdumper (void) +{ + nsfont_driver.type = Qns; + register_font_driver (&nsfont_driver, NULL); ascii_printable = NULL; } diff --git a/src/nsmenu.m b/src/nsmenu.m index 3e9887a..ed2e91e 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -37,6 +37,7 @@ #include "termhooks.h" #include "keyboard.h" #include "menu.h" +#include "pdumper.h" #define NSMENUPROFILE 0 @@ -1883,6 +1884,7 @@ - (Lisp_Object)runDialogAt: (NSPoint)p /* 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 7e6ec85..a7a62cb 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -59,6 +59,7 @@ Updated by Christian Limpach (chris@nice.ch) #include "keyboard.h" #include "buffer.h" #include "font.h" +#include "pdumper.h" #ifdef NS_IMPL_GNUSTEP #include "process.h" @@ -8620,6 +8621,7 @@ Convert an X font name (XLFD) to an NS font name. NSTRACE ("syms_of_nsterm"); ns_antialias_threshold = 10.0; + PDUMPER_REMEMBER_SCALAR (ns_antialias_threshold); /* from 23+ we need to tell emacs what modifiers there are.. */ DEFSYM (Qmodifier_value, "modifier-value"); diff --git a/src/pdumper.c b/src/pdumper.c new file mode 100644 index 0000000..2efbad9 --- /dev/null +++ b/src/pdumper.c @@ -0,0 +1,3197 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "blockinput.h" +#include "buffer.h" +#include "charset.h" +#include "coding.h" +#include "frame.h" +#include "getpagesize.h" +#include "intervals.h" +#include "lisp.h" +#include "pdumper.h" +#include "window.h" +#include "fingerprint.h" + +/* We require an architecture in which all pointers are the same size + and have the same layout. */ +verify (sizeof (ptrdiff_t) == sizeof (void*)); +verify (sizeof (void (*)(void)) == sizeof (void*)); +verify (sizeof (ptrdiff_t) <= sizeof (Lisp_Object)); +verify (sizeof (ptrdiff_t) <= sizeof (EMACS_INT)); + +bool pdumper_loading_dump; + +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; + +/* Maximum number of cons cells in a list to print in a contiguous + chunk before going back to the normal dumping strategy. */ +static const ptrdiff_t max_cons_chain_depth = 256; + +typedef int32_t dump_off_t; + +enum dump_reloc_type + { + /* dump_ptr = dump_ptr + emacs_basis() */ + RELOC_DUMP_TO_EMACS_RAW_PTR, + /* dump_ptr = dump_ptr + dump_base */ + RELOC_DUMP_TO_DUMP_RAW_PTR, + /* 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. */ + RELOC_EMACS_COPY_FROM_DUMP, + /* Set a piece of memory in Emacs to a value we store directly in + this relocation. The length field contains the number of bytes + we actually copy into Emacs. */ + RELOC_EMACS_IMMEDIATE, + /* Set an aligned pointer-sized object in Emacs to a dump offset. */ + RELOC_EMACS_DUMP_PTR_RAW, + /* Set an aligned pointer-sized object in Emacs to point to + something also in Emacs. */ + RELOC_EMACS_EMACS_PTR_RAW, + /* Set an aligned Lisp_Object in Emacs to point to a value in the + dump. Must be last. */ + RELOC_EMACS_DUMP_LV, + }; + +#define EMACS_RELOC_TYPE_BITS 3 +#define EMACS_RELOC_LENGTH_BITS \ + (sizeof (dump_off_t) * 8 - EMACS_RELOC_TYPE_BITS) + +struct emacs_reloc +{ + ENUM_BF (emacs_reloc_type) type : EMACS_RELOC_TYPE_BITS; + dump_off_t length : EMACS_RELOC_LENGTH_BITS; + dump_off_t emacs_offset; + union + { + dump_off_t dump_offset; + dump_off_t emacs_offset2; + intmax_t immediate; + int8_t immediate_i8; + int16_t immediate_i16; + int32_t immediate_i32; + } u; +}; + +struct dump_table_locator +{ + dump_off_t offset; + dump_off_t nr_entries; +}; + +struct dump_reloc +{ + // XXX: We have a ton of these. Combine type and offset into one + // 32-bit word. Force alignment. + enum dump_reloc_type type; + dump_off_t offset; +}; + +/* 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. */ + 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 hot_end. */ + dump_off_t hot_discardable_start; + + /* End of the region that we expect to have many relocations. */ + dump_off_t hot_end; + +}; + +struct dump_tailq +{ + Lisp_Object head; + Lisp_Object tail; +}; + +enum cold_op + { + COLD_OP_OBJECT, + COLD_OP_STRING, + COLD_OP_CHARSET, + COLD_OP_BUFFER, + }; + +/* 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; + + /* 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. */ + ptrdiff_t offset; + + /* Starting offset of current object. */ + ptrdiff_t obj_offset; + /* Flags for writing the current object. */ + int flags; + /* Depth of cons-chain dumping. */ + ptrdiff_t cons_chain_depth; + + ptrdiff_t 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; + +#ifdef ENABLE_CHECKING + bool have_current_referrer; +#endif + + /* Queue of objects to dump. */ + struct dump_tailq dump_queue; + /* Fixups in the dump file. */ + Lisp_Object fixups; + /* 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; +}; + + + +#define DUMP_OBJECT_INTERN (1<<0) +#define DUMP_OBJECT_RECORD_START (1<<1) +#define DUMP_OBJECT_DRY_RUN (1<<2) +#define DUMP_OBJECT_FORCE_WORD_ALIGNMENT (1<<3) +#define DUMP_OBJECT_PROHIBIT_ENQUEUE (1<<4) + +static ptrdiff_t dump_object (struct dump_context *ctx, Lisp_Object object); +static ptrdiff_t dump_object_1 (struct dump_context *ctx, + Lisp_Object object, + int flags); + +static void +dump_push (Lisp_Object *where, Lisp_Object newelt) +{ + *where = Fcons (newelt, *where); +} + +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 +} + +/* 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); + +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 ptrdiff_t +emacs_basis (void) +{ + return (ptrdiff_t) &Vpurify_flag; +} + +static ptrdiff_t +emacs_offset (const void *emacs_ptr) +{ + /* TODO: assert that emacs_ptr is actually in emacs */ + eassert (emacs_ptr != NULL); + ptrdiff_t emacs_ptr_value = (ptrdiff_t) emacs_ptr; + ptrdiff_t emacs_ptr_relative = emacs_ptr_value - emacs_basis (); + return 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. */ +static bool +dump_object_self_representing_p (Lisp_Object object) +{ + return INTEGERP (object) || dump_builtin_symbol_p (object); +} + +#define DEFINE_FROMLISP_FUNC(fn, type) \ + static type \ + fn (Lisp_Object value) \ + { \ + type result; \ + CONS_TO_INTEGER (value, type, result); \ + return result; \ + } + +DEFINE_FROMLISP_FUNC (intmax_t_from_lisp, intmax_t); +DEFINE_FROMLISP_FUNC (ptrdiff_t_from_lisp, ptrdiff_t); +DEFINE_FROMLISP_FUNC (dump_off_from_lisp, dump_off_t); + +static void +dump_tailq_init (struct dump_tailq *tailq) +{ + tailq->head = tailq->tail = Qnil; +} + +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; + } +} + +static bool +dump_tailq_empty_p (struct dump_tailq *tailq) +{ + return NILP (tailq->head); +} + +static Lisp_Object +dump_tailq_pop (struct dump_tailq *tailq) +{ + eassert (!dump_tailq_empty_p (tailq)); + Lisp_Object value = XCAR (tailq->head); + tailq->head = XCDR (tailq->head); + if (NILP (tailq->head)) + tailq->tail = Qnil; + return value; +} + +static void +dump_write (struct dump_context *ctx, const void *buf, ptrdiff_t nbyte) +{ + eassert (nbyte == 0 || buf != NULL); + eassert (ctx->obj_offset == 0); + eassert ((ctx->flags & DUMP_OBJECT_DRY_RUN) == 0); + if (emacs_write (ctx->fd, buf, nbyte) < nbyte) + report_file_error ("Could not write to dump file", ctx->dump_filename); + ctx->offset += nbyte; +} + +static void +dump_seek (struct dump_context *ctx, ptrdiff_t 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, ptrdiff_t nbytes) +{ + while (nbytes > 0) + { + ptrdiff_t zero = 0; + ptrdiff_t 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, ptrdiff_t alignment) +{ + if (ctx->offset % alignment != 0) + dump_write_zero (ctx, alignment - (ctx->offset % alignment)); +} + +static ptrdiff_t +dump_object_start (struct dump_context *ctx, + int alignment, + void *out, + ptrdiff_t outsz) +{ + eassert (ctx->obj_offset == 0); + if ((ctx->flags & DUMP_OBJECT_FORCE_WORD_ALIGNMENT) && + alignment > sizeof (void*)) + alignment = sizeof (void*); + if ((ctx->flags & DUMP_OBJECT_DRY_RUN) == 0) + dump_align_output (ctx, alignment); + ctx->obj_offset = ctx->offset; + memset (out, 0, outsz); + return ctx->offset; +} + +static ptrdiff_t +dump_object_finish (struct dump_context *ctx, + const void *out, + ptrdiff_t sz) +{ + ptrdiff_t offset = ctx->obj_offset; + eassert (offset > 0); + eassert (offset == ctx->offset); /* No intervening writes. */ + ctx->obj_offset = 0; + if ((ctx->flags & DUMP_OBJECT_DRY_RUN) == 0) + dump_write (ctx, out, sz); + return offset; +} + +/* Return offset at which OBJECT has been dumped, or 0 if OBJECT has + not been dumped. */ +static ptrdiff_t +dump_recall_object (struct dump_context *ctx, Lisp_Object object) +{ + Lisp_Object dumped = ctx->objects_dumped; + return ptrdiff_t_from_lisp (Fgethash (object, dumped, make_number (0))); +} + +static void +dump_remember_object (struct dump_context *ctx, + Lisp_Object object, + ptrdiff_t offset) +{ + Fputhash (object, INTEGER_TO_CONS (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); + return NULL; +} + +static void +dump_enqueue_object (struct dump_context *ctx, Lisp_Object object) +{ + if ((!dump_object_self_representing_p (object) || + dump_object_emacs_ptr (object)) && + dump_recall_object (ctx, object) == 0) + { + eassert ((ctx->flags & DUMP_OBJECT_PROHIBIT_ENQUEUE) == 0); + + dump_remember_object (ctx, object, -1); + if (BOOL_VECTOR_P (object) || FLOATP (object)) + dump_remember_cold_op (ctx, COLD_OP_OBJECT, object); + else + dump_tailq_append (&ctx->dump_queue, 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_DRY_RUN) + return; + dump_push (&ctx->cold_queue, Fcons (make_number (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_raw_ptr (struct dump_context *ctx, + ptrdiff_t dump_offset) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + dump_push (&ctx->dump_relocs, + list2 (INTEGER_TO_CONS (RELOC_DUMP_TO_EMACS_RAW_PTR), + INTEGER_TO_CONS (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, + ptrdiff_t dump_offset, + enum Lisp_Type type) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + ptrdiff_t reloc_type; + switch (type) + { + case Lisp_Symbol: + case Lisp_Misc: + case Lisp_String: + case Lisp_Vectorlike: + case Lisp_Cons: + case Lisp_Float: + reloc_type = RELOC_DUMP_TO_DUMP_LV + type; + break; + default: + emacs_abort (); + } + + dump_push (&ctx->dump_relocs, + list2 (INTEGER_TO_CONS (reloc_type), + INTEGER_TO_CONS (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_raw_ptr (struct dump_context *ctx, + ptrdiff_t dump_offset) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + dump_push (&ctx->dump_relocs, + list2 (INTEGER_TO_CONS (RELOC_DUMP_TO_DUMP_RAW_PTR), + INTEGER_TO_CONS (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, + ptrdiff_t dump_offset, + enum Lisp_Type type) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + ptrdiff_t reloc_type; + switch (type) + { + case Lisp_Misc: + case Lisp_String: + case Lisp_Vectorlike: + case Lisp_Cons: + case Lisp_Float: + reloc_type = RELOC_DUMP_TO_EMACS_LV + type; + break; + default: + emacs_abort (); + } + + dump_push (&ctx->dump_relocs, + list2 (INTEGER_TO_CONS (reloc_type), + INTEGER_TO_CONS (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_Value (since by the time we copy the Lisp_Value, 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, + ptrdiff_t dump_offset, + void* emacs_ptr, + ptrdiff_t size) +{ + eassert (size >= 0); + eassert (size < (1 << EMACS_RELOC_LENGTH_BITS)); + + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + if (size == 0) + return; + + dump_push (&ctx->emacs_relocs, + list4 (make_number (RELOC_EMACS_COPY_FROM_DUMP), + INTEGER_TO_CONS (emacs_offset (emacs_ptr)), + INTEGER_TO_CONS (dump_offset), + INTEGER_TO_CONS (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, + ptrdiff_t size) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + intmax_t value = 0; + eassert (size <= sizeof (value)); + memcpy (&value, value_ptr, size); + dump_push (&ctx->emacs_relocs, + list4 (make_number (RELOC_EMACS_IMMEDIATE), + INTEGER_TO_CONS (emacs_offset (emacs_ptr)), + INTEGER_TO_CONS (value), + INTEGER_TO_CONS (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, + ptrdiff_t dump_offset) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + dump_push (&ctx->emacs_relocs, + list3 (make_number (RELOC_EMACS_DUMP_PTR_RAW), + INTEGER_TO_CONS (emacs_offset (emacs_ptr)), + INTEGER_TO_CONS (dump_offset))); +} + +/* Add an emacs relocation that points into the dump. + + When the dump is loaded, the Lisp_Object at EMACS_ROOT in Emacs to + point to VALUE. VALUE can be any Lisp value; this function + automatically queues the value for dumping if necessary. */ +static void +dump_emacs_reloc_to_dump_lv (struct dump_context *ctx, + Lisp_Object *emacs_ptr, + Lisp_Object value) +{ + if (dump_object_self_representing_p (value)) + dump_emacs_reloc_immediate_lv (ctx, emacs_ptr, value); + else + { + if ((ctx->flags & DUMP_OBJECT_DRY_RUN) == 0) + dump_push ( + &ctx->emacs_relocs, + list3 (INTEGER_TO_CONS (RELOC_EMACS_DUMP_LV + XTYPE (value)), + INTEGER_TO_CONS (emacs_offset (emacs_ptr)), + value)); + dump_enqueue_object (ctx, value); + } +} + +/* 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_DRY_RUN) + return; + + dump_push (&ctx->emacs_relocs, + list3 (make_number (RELOC_EMACS_EMACS_PTR_RAW), + INTEGER_TO_CONS (emacs_offset (emacs_ptr)), + INTEGER_TO_CONS (emacs_offset (target_emacs_ptr)))); +} + +/* Add an Emacs relocation that makes a raw pointer in Emacs point to + a different part of Emacs. */ + +enum dump_fixup_type + { + DUMP_FIXUP_LISP_OBJECT, + DUMP_FIXUP_LISP_OBJECT_RAW, + DUMP_FIXUP_PTR_DUMP_RAW, + }; + +enum dump_lv_fixup_type + { + LV_FIXUP_LISP_OBJECT, + LV_FIXUP_RAW_POINTER, + }; + +/* Make something in the dump point to a lisp object. + + CTX is a dump context. DUMP_OFFSET is the location in the dump to + fix. VALUE is the object to which the location in the dump + should point. + + If FIXUP_SUBTYPE is LV_FIXUP_LISP_OBJECT, we expect a Lisp_Object + at DUMP_OFFSET. If it's LV_FIXUP_RAW_POINTER, we expect a pointer. + */ +static void +dump_remember_fixup_lv (struct dump_context *ctx, + ptrdiff_t dump_offset, + Lisp_Object value, + enum dump_lv_fixup_type fixup_subtype) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + dump_push (&ctx->fixups, + list3 ( + make_number (fixup_subtype == LV_FIXUP_LISP_OBJECT + ? DUMP_FIXUP_LISP_OBJECT + : DUMP_FIXUP_LISP_OBJECT_RAW), + INTEGER_TO_CONS (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, + ptrdiff_t dump_offset, + ptrdiff_t new_dump_offset) +{ + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + dump_push (&ctx->fixups, + list3 ( + make_number (DUMP_FIXUP_PTR_DUMP_RAW), + INTEGER_TO_CONS (dump_offset), + INTEGER_TO_CONS (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); + dump_clear_referrer (ctx); + } + else + { + DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("emacs root", root_ptr)); + dump_emacs_reloc_to_dump_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 ptrdiff_t +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 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 *raw_ptr_type) +{ + eassert (ctx->obj_offset > 0); + + Lisp_Object value; + ptrdiff_t relpos = field_relpos (in_start, in_field); + void *out_field = (char *) out + relpos; + if (raw_ptr_type == NULL) + { + 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 (*raw_ptr_type) + { + case Lisp_Symbol: + value = make_lisp_symbol (ptrval); + break; + case Lisp_Misc: + case Lisp_String: + case Lisp_Vectorlike: + case Lisp_Cons: + case Lisp_Float: + value = make_lisp_ptr (ptrval, *raw_ptr_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. */ + + ptrdiff_t out_value; + ptrdiff_t out_field_offset = ctx->obj_offset + relpos; + ptrdiff_t target_offset = dump_recall_object (ctx, value); + if (target_offset > 0) + { + /* 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 (raw_ptr_type) + dump_reloc_dump_to_dump_raw_ptr (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 = (ptrdiff_t) 0xDEADF00D; + dump_remember_fixup_lv (ctx, + out_field_offset, + value, + ( raw_ptr_type + ? LV_FIXUP_RAW_POINTER + : LV_FIXUP_LISP_OBJECT )); + if (target_offset == 0) + dump_enqueue_object (ctx, value); + } + + 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) +{ + dump_field_lv_or_rawptr (ctx, out, in_start, in_field, &type); +} + +/* 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) +{ + dump_field_lv_or_rawptr (ctx, out, in_start, in_field, NULL); +} + +/* 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, + ptrdiff_t target_dump_offset) +{ + eassert (ctx->obj_offset > 0); + if (ctx->flags & DUMP_OBJECT_DRY_RUN) + return; + + ptrdiff_t relpos = field_relpos (in_start, in_field); + dump_reloc_dump_to_dump_raw_ptr (ctx, ctx->obj_offset + relpos); + ptrdiff_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_DRY_RUN) + return; + + ptrdiff_t abs_emacs_ptr; + cpyptr (&abs_emacs_ptr, in_field); + ptrdiff_t rel_emacs_ptr = abs_emacs_ptr - emacs_basis (); + ptrdiff_t relpos = field_relpos (in_start, in_field); + cpyptr ((char*) out + relpos, &rel_emacs_ptr); + dump_reloc_dump_to_emacs_raw_ptr (ctx, ctx->obj_offset + relpos); +} + +static ptrdiff_t +dump_cons (struct dump_context *ctx, const struct Lisp_Cons *cons) +{ + struct Lisp_Cons out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + dump_field_lv (ctx, &out, cons, &cons->car); + dump_field_lv (ctx, &out, cons, &cons->u.cdr); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_interval_tree (struct dump_context *ctx, + INTERVAL tree, + ptrdiff_t parent_offset) +{ + // TODO: output tree breadth-first? + struct interval out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, tree, total_length); + DUMP_FIELD_COPY (&out, tree, position); + if (tree->left) + dump_field_fixup_later (ctx, &out, tree, &tree->left); + if (tree->right) + dump_field_fixup_later (ctx, &out, tree, &tree->right); + if (!tree->up_obj) + { + eassert (parent_offset != 0); + dump_field_ptr_to_dump_offset ( + ctx, &out, + tree, &tree->up.interval, + parent_offset); + } + else + dump_field_lv (ctx, &out, tree, &tree->up.obj); + 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); + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + if (tree->left) + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct interval, left), + dump_interval_tree (ctx, tree->left, offset)); + if (tree->right) + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct interval, right), + dump_interval_tree (ctx, tree->right, offset)); + return offset; +} + +static ptrdiff_t +dump_string (struct dump_context *ctx, const struct Lisp_String *string) +{ + /* If we have text properties, write them _after_ the string so that + at runtime, the prefetcher and cache will DTRT. (We access the + string before its properties.). + + There's special code to dump string data contiguously later on. + we seldom write to string data and never relocate it, so lumping + it together at the end of the dump saves on COW faults. + + If, however, the string's size_byte field is -1, the string data + is actually a pointer to Emacs data segment, so we can do even + better by emitting a relocation instead of bothering to copy the + string data. */ + struct Lisp_String out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, string, size); + DUMP_FIELD_COPY (&out, string, size_byte); + if (string->intervals) + dump_field_fixup_later (ctx, &out, string, &string->intervals); + + if (string->size_byte == -2) + /* String literal in Emacs rodata. */ + dump_field_emacs_ptr (ctx, &out, string, &string->data); + else + { + dump_field_fixup_later (ctx, &out, string, &string->data); + dump_remember_cold_op (ctx, + COLD_OP_STRING, + make_lisp_ptr ((void*) string, Lisp_String)); + } + + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + if (string->intervals) + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct Lisp_String, intervals), + dump_interval_tree (ctx, string->intervals, 0)); + + return offset; +} + +static ptrdiff_t +dump_marker (struct dump_context *ctx, const struct Lisp_Marker *marker) +{ + struct Lisp_Marker out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, marker, type); + eassert (marker->gcmarkbit == 0); + (void) marker->spacer; /* Do not write padding. */ + DUMP_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); + dump_field_lv_rawptr ( + ctx, &out, + marker, &marker->next, + Lisp_Misc); + DUMP_FIELD_COPY (&out, marker, charpos); + DUMP_FIELD_COPY (&out, marker, bytepos); + } + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_overlay (struct dump_context *ctx, const struct Lisp_Overlay *overlay) +{ + struct Lisp_Overlay out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, overlay, type); + eassert (overlay->gcmarkbit == 0); + (void) overlay->spacer; /* Do not write padding. */ + dump_field_lv_rawptr (ctx, &out, overlay, &overlay->next, Lisp_Misc); + dump_field_lv (ctx, &out, overlay, &overlay->start); + dump_field_lv (ctx, &out, overlay, &overlay->end); + dump_field_lv (ctx, &out, overlay, &overlay->plist); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_save_value (struct dump_context *ctx, + const struct Lisp_Save_Value *ptr) +{ + struct Lisp_Save_Value out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, ptr, type); + eassert(ptr->gcmarkbit == 0); + (void) ptr->spacer; /* Do not write padding. */ + DUMP_FIELD_COPY (&out, ptr, save_type); + for (int i = 0; i < SAVE_VALUE_SLOTS; i++) + { + switch (save_type (&out, i)) + { + case SAVE_UNUSED: + break; + case SAVE_INTEGER: + DUMP_FIELD_COPY (&out, ptr, data[i].integer); + break; + case SAVE_FUNCPOINTER: + dump_field_emacs_ptr (ctx, &out, ptr, &ptr->data[i].funcpointer); + break; + case SAVE_OBJECT: + dump_field_lv (ctx, &out, ptr, &ptr->data[i].object); + break; + case SAVE_POINTER: + error_unsupported_dump_object( + ctx, make_lisp_ptr ((void *) ptr, Lisp_Misc), "SAVE_POINTER"); + default: + emacs_abort (); + } + } + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static void +dump_field_finalizer_ref (struct dump_context *ctx, + void *out, + const struct Lisp_Finalizer *finalizer, + struct Lisp_Finalizer *const *field) +{ + if (*field == &finalizers || *field == &doomed_finalizers) + dump_field_emacs_ptr (ctx, out, finalizer, field); + else + dump_field_lv_rawptr (ctx, out, finalizer, field, Lisp_Misc); +} + +static ptrdiff_t +dump_finalizer (struct dump_context *ctx, + const struct Lisp_Finalizer *finalizer) +{ + struct Lisp_Finalizer out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, finalizer, base.type); + eassert (finalizer->base.gcmarkbit == 0); + (void) finalizer->base.spacer; /* Do not write padding. */ + dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->prev); + dump_field_finalizer_ref (ctx, &out, finalizer, &finalizer->next); + dump_field_lv (ctx, &out, finalizer, &finalizer->function); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_misc_any (struct dump_context *ctx, struct Lisp_Misc_Any *misc_any) +{ + ptrdiff_t result; + + switch (misc_any->type) + { + case Lisp_Misc_Marker: + result = dump_marker (ctx, (struct Lisp_Marker *) misc_any); + break; + + case Lisp_Misc_Overlay: + result = dump_overlay (ctx, (struct Lisp_Overlay *) misc_any); + break; + + case Lisp_Misc_Save_Value: + result = dump_save_value (ctx, (struct Lisp_Save_Value *) misc_any); + break; + + case Lisp_Misc_Finalizer: + result = dump_finalizer (ctx, (struct Lisp_Finalizer *) misc_any); + break; + +#ifdef HAVE_MODULES + case Lisp_Misc_User_Ptr: + error_unsupported_dump_object( + ctx, + make_lisp_ptr (misc_any, Lisp_Misc), + "module user ptr"); + break; +#endif + + default: + case Lisp_Misc_Float: /* Not used */ + emacs_abort (); + } + + return result; +} + +static ptrdiff_t +dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat) +{ + struct Lisp_Float out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, lfloat, u.data); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd_int (struct dump_context *ctx, const struct Lisp_Intfwd *intfwd) +{ + dump_emacs_reloc_immediate_emacs_int (ctx, intfwd->intvar, *intfwd->intvar); + struct Lisp_Intfwd out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, intfwd, type); + dump_field_emacs_ptr (ctx, &out, intfwd, &intfwd->intvar); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd_bool (struct dump_context *ctx, const struct Lisp_Boolfwd *boolfwd) +{ + dump_emacs_reloc_immediate_bool (ctx, boolfwd->boolvar, *boolfwd->boolvar); + struct Lisp_Boolfwd out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, boolfwd, type); + dump_field_emacs_ptr (ctx, &out, boolfwd, &boolfwd->boolvar); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd_obj (struct dump_context *ctx, const struct Lisp_Objfwd *objfwd) +{ + dump_emacs_reloc_to_dump_lv (ctx, objfwd->objvar, *objfwd->objvar); + struct Lisp_Objfwd out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, objfwd, type); + dump_field_emacs_ptr (ctx, &out, objfwd, &objfwd->objvar); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd_buffer_obj (struct dump_context *ctx, + const struct Lisp_Buffer_Objfwd *buffer_objfwd) +{ + struct Lisp_Buffer_Objfwd out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, buffer_objfwd, type); + DUMP_FIELD_COPY (&out, buffer_objfwd, offset); + dump_field_lv (ctx, &out, buffer_objfwd, &buffer_objfwd->predicate); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd_kboard_obj (struct dump_context *ctx, + const struct Lisp_Kboard_Objfwd *kboard_objfwd) +{ + struct Lisp_Kboard_Objfwd out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, kboard_objfwd, type); + DUMP_FIELD_COPY (&out, kboard_objfwd, offset); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_fwd (struct dump_context *ctx, union Lisp_Fwd *fwd) +{ + ptrdiff_t 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 ptrdiff_t +dump_blv (struct dump_context *ctx, + const struct Lisp_Buffer_Local_Value *blv) +{ + struct Lisp_Buffer_Local_Value out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, blv, local_if_set); + DUMP_FIELD_COPY (&out, blv, frame_local); + 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); + dump_field_lv (ctx, &out, blv, &blv->defcell); + dump_field_lv (ctx, &out, blv, &blv->valcell); + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + if (blv->fwd) + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct Lisp_Buffer_Local_Value, fwd), + dump_fwd (ctx, blv->fwd)); + return offset; +} + +static ptrdiff_t +dump_symbol (struct dump_context *ctx, const struct Lisp_Symbol *symbol) +{ + struct Lisp_Symbol out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + eassert (symbol->gcmarkbit == 0); + DUMP_FIELD_COPY (&out, symbol, redirect); + DUMP_FIELD_COPY (&out, symbol, constant); + DUMP_FIELD_COPY (&out, symbol, interned); + DUMP_FIELD_COPY (&out, symbol, declared_special); + DUMP_FIELD_COPY (&out, symbol, pinned); + dump_field_lv (ctx, &out, symbol, &symbol->name); + switch (symbol->redirect) + { + case SYMBOL_PLAINVAL: + dump_field_lv (ctx, &out, symbol, &symbol->val.value); + break; + case SYMBOL_VARALIAS: + dump_field_lv_rawptr (ctx, &out, symbol, + &symbol->val.alias, Lisp_Symbol); + break; + case SYMBOL_LOCALIZED: + dump_field_fixup_later (ctx, &out, symbol, &symbol->val.blv); + break; + case SYMBOL_FORWARDED: + dump_field_fixup_later (ctx, &out, symbol, &symbol->val.fwd); + break; + default: + emacs_abort (); + } + dump_field_lv (ctx, &out, symbol, &symbol->function); + dump_field_lv (ctx, &out, symbol, &symbol->plist); + dump_field_lv_rawptr (ctx, &out, symbol, &symbol->next, Lisp_Symbol); + + // XXX: linearize symbol chains + + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + + switch (symbol->redirect) + { + case SYMBOL_LOCALIZED: + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct Lisp_Symbol, val.blv), + dump_blv (ctx, symbol->val.blv)); + break; + case SYMBOL_FORWARDED: + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct Lisp_Symbol, val.fwd), + dump_fwd (ctx, symbol->val.fwd)); + break; + default: + break; + } + return offset; +} + +static ptrdiff_t +dump_vectorlike_generic ( + struct dump_context *ctx, + const struct vectorlike_header *header) +{ + const struct Lisp_Vector *v = (const struct Lisp_Vector *) header; + ptrdiff_t size = header->size; + enum pvec_type pvectype = PSEUDOVECTOR_TYPE (header); + ptrdiff_t offset; + + if (size & PSEUDOVECTOR_FLAG) + { + /* Assert that the pseudovector contains only Lisp values --- + but see the PVEC_SUB_CHAR_TABLE special case below. */ + eassert (((size & PSEUDOVECTOR_REST_MASK) + >> PSEUDOVECTOR_REST_BITS) == 0); + size &= PSEUDOVECTOR_SIZE_MASK; + } + + dump_align_output (ctx, GCALIGNMENT); + ptrdiff_t prefix_start_offset = ctx->offset; + + ptrdiff_t skip; + if (pvectype == PVEC_SUB_CHAR_TABLE) + { + /* PVEC_SUB_CHAR_TABLE has a special case because it's a + variable-length vector (unlike other pseudovectors) and has + its non-Lisp data _before_ the variable-length Lisp part. */ + const struct Lisp_Sub_Char_Table *sct = + (const struct Lisp_Sub_Char_Table *) header; + struct Lisp_Sub_Char_Table out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, sct, header.size); + DUMP_FIELD_COPY (&out, sct, depth); + DUMP_FIELD_COPY (&out, sct, min_char); + offset = dump_object_finish (ctx, &out, sizeof (out)); + skip = SUB_CHAR_TABLE_OFFSET; + } + else + { + struct vectorlike_header out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, header, size); + offset = dump_object_finish (ctx, &out, sizeof (out)); + skip = 0; + } + + ptrdiff_t prefix_size = ctx->offset - prefix_start_offset; + eassert (prefix_size > 0); + ptrdiff_t skip_start = (char*) &v->contents[skip] - (char*) v; + eassert (skip_start >= prefix_size); + dump_write_zero (ctx, skip_start - prefix_size); + for (ptrdiff_t i = skip; i < size; ++i) + { + Lisp_Object out; + const Lisp_Object *vslot = &v->contents[i]; + eassert (ctx->offset % sizeof (out) == 0); + dump_object_start (ctx, 1, &out, sizeof (out)); + dump_field_lv (ctx, &out, vslot, vslot); + dump_object_finish (ctx, &out, sizeof (out)); + } + + return offset; +} + +static void +dump_object_start_pseudovector ( + struct dump_context *ctx, + struct vectorlike_header *out_hdr, + ptrdiff_t out_size, + const struct vectorlike_header *in_hdr) +{ + const struct Lisp_Vector *in = (const struct Lisp_Vector *) in_hdr; + struct Lisp_Vector *out = (struct Lisp_Vector *) out_hdr; + + eassert (vector_nbytes ((struct Lisp_Vector *) in) == out_size); + + dump_object_start (ctx, GCALIGNMENT, out, out_size); + DUMP_FIELD_COPY (out, in, header); + ptrdiff_t size = in->header.size; + eassert (size & PSEUDOVECTOR_FLAG); + size &= PSEUDOVECTOR_SIZE_MASK; + for (ptrdiff_t i = 0; i < size; ++i) + dump_field_lv (ctx, out, in, &in->contents[i]); +} + +/* 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 (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); + if (!(dump_builtin_symbol_p (key) || + INTEGERP (key) || + (is_equal && STRINGP (key)) || + ((is_equal || is_eql) && FLOATP (key)))) + return false; + } + + return true; +} + +static ptrdiff_t +dump_hash_table (struct dump_context *ctx, + const struct Lisp_Hash_Table *hash_in) +{ + 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 && !dump_hash_table_stable_p (hash)) + hash->count = -hash->count; + + struct Lisp_Hash_Table out; + dump_object_start_pseudovector ( + ctx, &out.header, sizeof (out), &hash->header); + DUMP_FIELD_COPY (&out, hash, count); + dump_field_lv (ctx, &out, hash, &hash->key_and_value); + dump_field_lv (ctx, &out, hash, &hash->test.name); + dump_field_lv (ctx, &out, hash, &hash->test.user_hash_function); + dump_field_lv (ctx, &out, hash, &hash->test.user_cmp_function); + dump_field_emacs_ptr (ctx, &out, hash, &hash->test.cmpfn); + dump_field_emacs_ptr (ctx, &out, hash, &hash->test.hashfn); + dump_field_lv_rawptr (ctx, &out, hash, &hash->next_weak, Lisp_Vectorlike); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static ptrdiff_t +dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) +{ + struct buffer munged_buffer = *in_buffer; + struct buffer *buffer = &munged_buffer; + + /* Clear some buffer state for correctness upon load. */ + if (buffer->base_buffer == NULL) + buffer->window_count = 0; + else + eassert (buffer->window_count == -1); + buffer->last_selected_window_ = Qnil; + buffer->display_count_ = make_number (0); + buffer->clip_changed = 0; + buffer->last_window_start = -1; + buffer->point_before_scroll_ = Qnil; + + ptrdiff_t base_offset = 0; + if (buffer->base_buffer) + { + eassert (buffer->base_buffer->base_buffer == NULL); + base_offset = dump_object ( + ctx, + make_lisp_ptr (buffer->base_buffer, Lisp_Vectorlike)); + } + + eassert ((base_offset == 0 && buffer->text == &in_buffer->own_text) || + (base_offset > 0 && buffer->text != &in_buffer->own_text)); + + struct buffer out; + dump_object_start_pseudovector ( + ctx, &out.header, sizeof (out), &buffer->header); + if (base_offset == 0) + base_offset = ctx->obj_offset; + eassert (base_offset > 0); + if (buffer->base_buffer == NULL) + { + eassert (base_offset == ctx->obj_offset); + + if (BUFFER_LIVE_P (buffer)) + { + dump_field_fixup_later (ctx, &out, buffer, &buffer->own_text.beg); + dump_remember_cold_op ( + ctx, + COLD_OP_BUFFER, + make_lisp_ptr ((void*) in_buffer, Lisp_Vectorlike)); + } + else + eassert (buffer->own_text.beg == NULL); + + DUMP_FIELD_COPY (&out, buffer, own_text.gpt); + DUMP_FIELD_COPY (&out, buffer, own_text.z); + DUMP_FIELD_COPY (&out, buffer, own_text.gpt_byte); + DUMP_FIELD_COPY (&out, buffer, own_text.z_byte); + DUMP_FIELD_COPY (&out, buffer, own_text.gap_size); + DUMP_FIELD_COPY (&out, buffer, own_text.modiff); + DUMP_FIELD_COPY (&out, buffer, own_text.chars_modiff); + DUMP_FIELD_COPY (&out, buffer, own_text.save_modiff); + DUMP_FIELD_COPY (&out, buffer, own_text.overlay_modiff); + DUMP_FIELD_COPY (&out, buffer, own_text.compact); + DUMP_FIELD_COPY (&out, buffer, own_text.beg_unchanged); + DUMP_FIELD_COPY (&out, buffer, own_text.end_unchanged); + DUMP_FIELD_COPY (&out, buffer, own_text.unchanged_modified); + DUMP_FIELD_COPY (&out, buffer, own_text.overlay_unchanged_modified); + if (buffer->own_text.intervals) + dump_field_fixup_later (ctx, &out, buffer, &buffer->own_text.intervals); + dump_field_lv_rawptr (ctx, &out, buffer, &buffer->own_text.markers, + Lisp_Misc); + 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 + offsetof (struct buffer, text), + base_offset + offsetof (struct buffer, own_text)); + + dump_field_lv_rawptr (ctx, &out, buffer, &buffer->next, Lisp_Vectorlike); + DUMP_FIELD_COPY (&out, buffer, pt); + DUMP_FIELD_COPY (&out, buffer, pt_byte); + DUMP_FIELD_COPY (&out, buffer, begv); + DUMP_FIELD_COPY (&out, buffer, begv_byte); + DUMP_FIELD_COPY (&out, buffer, zv); + DUMP_FIELD_COPY (&out, buffer, zv_byte); + + if (buffer->base_buffer) + { + eassert (ctx->obj_offset != base_offset); + dump_field_ptr_to_dump_offset ( + ctx, &out, buffer, &buffer->base_buffer, + base_offset); + } + + DUMP_FIELD_COPY (&out, buffer, indirections); + DUMP_FIELD_COPY (&out, buffer, window_count); + + memcpy (&out.local_flags, + &buffer->local_flags, + sizeof (out.local_flags)); + DUMP_FIELD_COPY (&out, buffer, modtime); + DUMP_FIELD_COPY (&out, buffer, modtime_size); + DUMP_FIELD_COPY (&out, buffer, auto_save_modified); + DUMP_FIELD_COPY (&out, buffer, display_error_modiff); + DUMP_FIELD_COPY (&out, buffer, auto_save_failure_time); + DUMP_FIELD_COPY (&out, buffer, last_window_start); + + /* Not worth serializing these caches. TODO: really? */ + out.newline_cache = NULL; + out.width_run_cache = NULL; + out.bidi_paragraph_cache = NULL; + + DUMP_FIELD_COPY (&out, buffer, prevent_redisplay_optimizations_p); + DUMP_FIELD_COPY (&out, buffer, clip_changed); + + dump_field_lv_rawptr (ctx, &out, buffer, &buffer->overlays_before, + Lisp_Misc); + + dump_field_lv_rawptr (ctx, &out, buffer, &buffer->overlays_after, + Lisp_Misc); + + DUMP_FIELD_COPY (&out, buffer, overlay_center); + dump_field_lv (ctx, &out, buffer, &buffer->undo_list_); + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + if (!buffer->base_buffer && buffer->own_text.intervals) + dump_remember_fixup_ptr_raw ( + ctx, + offset + offsetof (struct buffer, own_text.intervals), + dump_interval_tree (ctx, buffer->own_text.intervals, 0)); + + return offset; +} + +static ptrdiff_t +dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) +{ + /* No relocation needed, so we don't need dump_object_start. */ + dump_align_output (ctx, GCALIGNMENT); + eassert (ctx->offset >= ctx->header.hot_end); + ptrdiff_t offset = ctx->offset; + ptrdiff_t nbytes = vector_nbytes ((struct Lisp_Vector *) v); + dump_write (ctx, v, nbytes); + return offset; +} + +static ptrdiff_t +dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) +{ + struct Lisp_Subr out; + dump_object_start (ctx, GCALIGNMENT, &out, sizeof (out)); + DUMP_FIELD_COPY (&out, subr, header.size); + dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); + DUMP_FIELD_COPY (&out, subr, min_args); + DUMP_FIELD_COPY (&out, subr, max_args); + dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); + dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + DUMP_FIELD_COPY (&out, subr, doc); + return dump_object_finish (ctx, &out, sizeof (out)); +} + +static void +fill_pseudovec (struct 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 ptrdiff_t +dump_nilled_pseudovec (struct dump_context *ctx, + const struct vectorlike_header *in) +{ + ptrdiff_t nbytes = vector_nbytes ((struct Lisp_Vector *) in); + struct vectorlike_header *in_nilled = alloca (nbytes); + memset (in_nilled, 0, nbytes); + in_nilled->size = in->size; + fill_pseudovec (in_nilled, Qnil); + struct vectorlike_header *out = alloca (nbytes); + memset (out, 0, nbytes); + dump_object_start_pseudovector (ctx, out, nbytes, in_nilled); + return dump_object_finish (ctx, out, nbytes); +} + +static ptrdiff_t +dump_vectorlike (struct dump_context *ctx, const struct Lisp_Vector *v) +{ + ptrdiff_t offset; + Lisp_Object lv = make_lisp_ptr ((void *) v, Lisp_Vectorlike); + switch (PSEUDOVECTOR_TYPE (&v->header)) + { + 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"); + /* Fall through */ + case PVEC_NORMAL_VECTOR: + case PVEC_COMPILED: + case PVEC_CHAR_TABLE: + case PVEC_SUB_CHAR_TABLE: + offset = dump_vectorlike_generic (ctx, &v->header); + break; + case PVEC_BOOL_VECTOR: + offset = dump_bool_vector(ctx, v); + break; + case PVEC_HASH_TABLE: + offset = dump_hash_table (ctx, (struct Lisp_Hash_Table *) v); + break; + case PVEC_BUFFER: + offset = dump_buffer (ctx, (struct buffer *) v); + break; + case PVEC_SUBR: + offset = dump_subr(ctx, (const struct Lisp_Subr *) v); + break; + case PVEC_FRAME: + case PVEC_WINDOW: + case PVEC_PROCESS: + case PVEC_TERMINAL: + offset = dump_nilled_pseudovec (ctx, &v->header); + 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"); + default: + error_unsupported_dump_object(ctx, lv, "weird pseudovector"); + } + + return offset; +} + +/* Add an object to the dump. */ +static ptrdiff_t +dump_object_1 (struct dump_context *ctx, Lisp_Object object, int flags) +{ +#ifdef ENABLE_CHECKING + eassert (!EQ (object, Vdead)); +#endif + + if (flags & DUMP_OBJECT_DRY_RUN) + flags &= ~(DUMP_OBJECT_INTERN | DUMP_OBJECT_RECORD_START); + + int saved_flags = ctx->flags; + flags |= ctx->flags; + ctx->flags = flags; + + ptrdiff_t offset = dump_recall_object (ctx, object); + if (flags & DUMP_OBJECT_INTERN) + eassert (!dump_object_self_representing_p (object)); + + if (offset <= 0) + { + DUMP_SET_REFERRER (ctx, object); + switch (XTYPE (object)) + { + case Lisp_String: + offset = dump_string (ctx, XSTRING (object)); + break; + case Lisp_Vectorlike: + offset = dump_vectorlike (ctx, XVECTOR (object)); + break; + case Lisp_Symbol: + offset = dump_symbol (ctx, XSYMBOL (object)); + break; + case Lisp_Misc: + offset = dump_misc_any (ctx, XMISCANY (object)); + break; + case Lisp_Cons: + offset = dump_cons (ctx, XCONS (object)); + break; + case Lisp_Float: + offset = dump_float (ctx, XFLOAT (object)); + break; + case_Lisp_Int: + eassert (!"should not be dumping int: is self-representing"); + default: + emacs_abort (); + } + eassert (offset > 0); + if (flags & DUMP_OBJECT_INTERN) + dump_remember_object (ctx, object, offset); + if (flags & DUMP_OBJECT_RECORD_START) + dump_push (&ctx->object_starts, + list2 (INTEGER_TO_CONS (XTYPE (object)), + INTEGER_TO_CONS (offset))); + + dump_clear_referrer (ctx); + + /* If we dumped a cons cell, we put its car and cdr on the dump + queue; we'll eventually get around to dumping them. That's + fine from a correctness perspective, but but Lisp has lots of + lists, and code likes to traverse lists. Make sure the cons + cells for reasonable-sized lists are dumped next to each + other. */ + if (CONSP (object) && + CONSP (XCDR (object)) && + flags == (DUMP_OBJECT_INTERN | DUMP_OBJECT_RECORD_START) && + ctx->cons_chain_depth < max_cons_chain_depth) + { + ctx->cons_chain_depth += 1; + dump_object (ctx, XCDR (object)); + ctx->cons_chain_depth -= 1; + } + } + + ctx->flags = saved_flags; + return offset; +} + +static ptrdiff_t +dump_object (struct dump_context *ctx, Lisp_Object object) +{ + ptrdiff_t result; + if (dump_object_emacs_ptr (object) != NULL) + { + result = dump_recall_object (ctx, object); + eassert (result < 0); + if (result > -2) + { + dump_object_1 (ctx, object, DUMP_OBJECT_DRY_RUN); + dump_push (&ctx->copied_queue, object); + result = -2; + dump_remember_object (ctx, object, result); + } + } + else + result = dump_object_1 ( + ctx, + object, + DUMP_OBJECT_INTERN | DUMP_OBJECT_RECORD_START); + return result; +} + +static ptrdiff_t +dump_charset (struct dump_context *ctx, int cs_i) +{ + const struct charset *cs = charset_table + cs_i; + struct charset out; + dump_object_start (ctx, sizeof (int), &out, sizeof (out)); + DUMP_FIELD_COPY (&out, cs, id); + DUMP_FIELD_COPY (&out, cs, hash_index); + DUMP_FIELD_COPY (&out, cs, dimension); + memcpy (out.code_space, &cs->code_space, sizeof (cs->code_space)); + if (cs->code_space_mask) + dump_field_fixup_later (ctx, &out, cs, &cs->code_space_mask); + DUMP_FIELD_COPY (&out, cs, code_linear_p); + DUMP_FIELD_COPY (&out, cs, iso_chars_96); + DUMP_FIELD_COPY (&out, cs, ascii_compatible_p); + DUMP_FIELD_COPY (&out, cs, supplementary_p); + DUMP_FIELD_COPY (&out, cs, compact_codes_p); + DUMP_FIELD_COPY (&out, cs, unified_p); + DUMP_FIELD_COPY (&out, cs, iso_final); + DUMP_FIELD_COPY (&out, cs, iso_revision); + DUMP_FIELD_COPY (&out, cs, emacs_mule_id); + DUMP_FIELD_COPY (&out, cs, method); + DUMP_FIELD_COPY (&out, cs, min_code); + DUMP_FIELD_COPY (&out, cs, max_code); + DUMP_FIELD_COPY (&out, cs, char_index_offset); + DUMP_FIELD_COPY (&out, cs, min_char); + DUMP_FIELD_COPY (&out, cs, max_char); + DUMP_FIELD_COPY (&out, cs, invalid_code); + memcpy (out.fast_map, &cs->fast_map, sizeof (cs->fast_map)); + DUMP_FIELD_COPY (&out, cs, code_offset); + ptrdiff_t offset = dump_object_finish (ctx, &out, sizeof (out)); + if (cs->code_space_mask) + dump_remember_cold_op (ctx, COLD_OP_CHARSET, + Fcons (INTEGER_TO_CONS (cs_i), + INTEGER_TO_CONS (offset))); + return offset; +} + +static ptrdiff_t +dump_charset_table (struct dump_context *ctx) +{ + dump_align_output (ctx, GCALIGNMENT); + ptrdiff_t offset = ctx->offset; + for (int i = 0; i < charset_table_used; ++i) + dump_charset (ctx, i); + dump_emacs_reloc_to_dump_ptr_raw (ctx, &charset_table, offset); + dump_emacs_reloc_immediate_int ( + ctx, &charset_table_used, charset_table_used); + dump_emacs_reloc_immediate_emacs_int ( + ctx, &charset_table_size, charset_table_used); + return offset; +} + +static void +dump_finalizer_list_head_ptr (struct dump_context *ctx, + struct Lisp_Finalizer **ptr) +{ + struct Lisp_Finalizer *value = *ptr; + if (value != &finalizers && value != &doomed_finalizers) + dump_emacs_reloc_to_dump_ptr_raw ( + ctx, ptr, + dump_object (ctx, make_lisp_ptr (value, Lisp_Misc))); +} + +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); +} + +static void +dump_copied_objects (struct dump_context *ctx) +{ + /* Sort the objects into the order in which they'll appear in Emacs. */ + Lisp_Object copied_queue = + Fsort (Fnreverse (ctx->copied_queue), + Qdump_emacs_portable__sort_predicate_copied); + ctx->copied_queue = Qnil; + + /* Dump the objects and generate a copy relocation for each. We'll + merge adjacent copy relocations upon output. */ + while (!NILP (copied_queue)) + { + Lisp_Object copied = dump_pop (&copied_queue); + void *optr = dump_object_emacs_ptr (copied); + eassert (optr != NULL); + ptrdiff_t offset = dump_object_1 ( + ctx, + copied, + ( DUMP_OBJECT_FORCE_WORD_ALIGNMENT + | DUMP_OBJECT_PROHIBIT_ENQUEUE)); + ptrdiff_t size = ctx->offset - offset; + dump_emacs_reloc_copy_from_dump (ctx, offset, optr, size); + } +} + +static void +dump_cold_string (struct dump_context *ctx, Lisp_Object string) +{ + /* Dump string contents. */ + ptrdiff_t string_offset = dump_recall_object (ctx, string); + eassert (string_offset > 0); + ptrdiff_t total_size = SBYTES (string) + 1; + eassert (total_size > 0); + dump_remember_fixup_ptr_raw ( + ctx, + string_offset + offsetof (struct Lisp_String, data), + ctx->offset); + dump_write (ctx, XSTRING (string)->data, total_size); +} + +static void +dump_cold_charset (struct dump_context *ctx, Lisp_Object data) +{ + /* Dump charset lookup tables. */ + int cs_i = XFASTINT (XCAR (data)); + ptrdiff_t cs_dump_offset = ptrdiff_t_from_lisp (XCDR (data)); + dump_remember_fixup_ptr_raw ( + ctx, + cs_dump_offset + 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. */ + ptrdiff_t 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; + dump_remember_fixup_ptr_raw ( + ctx, + buffer_offset + offsetof (struct buffer, own_text.beg), + ctx->offset); + dump_write (ctx, b->own_text.beg, nbytes); +} + +static void +dump_cold_data (struct dump_context *ctx) +{ + if (!NILP (ctx->cold_queue)) + { + Lisp_Object cold_queue = Fnreverse (ctx->cold_queue); + ctx->cold_queue = Qnil; + while (!NILP (cold_queue)) + { + Lisp_Object item = dump_pop (&cold_queue); + enum cold_op op = XFASTINT (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_tailq_empty_p (&ctx->dump_queue)); + dump_object (ctx, data); + eassert (dump_tailq_empty_p (&ctx->dump_queue)); + break; + default: + emacs_abort (); + } + } + } +} + +static void +read_raw_ptr_and_lv (const void *mem, + enum Lisp_Type type, + void **out_ptr, + Lisp_Object *out_lv) +{ + memcpy (out_ptr, mem, sizeof (*out_ptr)); + if (*out_ptr != NULL) + { + switch (type) + { + case Lisp_Symbol: + *out_lv = make_lisp_symbol (*out_ptr); + break; + case Lisp_Misc: + case Lisp_String: + case Lisp_Vectorlike: + case Lisp_Cons: + case Lisp_Float: + *out_lv = make_lisp_ptr (*out_ptr, type); + break; + default: + emacs_abort (); + } + } +} + +/* Enqueue for dumping objects referenced by static non-Lisp_Object + pointers inside Emacs. */ +static void +dump_user_remembered_data_hot (struct dump_context *ctx) +{ + 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_raw_ptr_and_lv (mem, type, &value, &lv); + if (value != NULL) + { + DUMP_SET_REFERRER (ctx, dump_ptr_referrer ("user data", mem)); + dump_enqueue_object (ctx, lv); + dump_clear_referrer (ctx); + } + } + } +} + +/* Dump user-specified non-relocated data. */ +static void +dump_user_remembered_data_cold (struct dump_context *ctx) +{ + for (int i = 0; i < nr_remembered_data; ++i) + { + void *mem = remembered_data[i].mem; + int sz = remembered_data[i].sz; + if (sz > 0) + { + /* Scalar: try to inline the value into the relocation if + it's small enough; if it's bigger than we can fit in a + relocation, we have to copy the data into the dump proper + and issue a copy relocation. */ + if (sz <= sizeof (intmax_t)) + dump_emacs_reloc_immediate (ctx, mem, mem, sz); + else + { + dump_emacs_reloc_copy_from_dump (ctx, ctx->offset, mem, sz); + dump_write (ctx, mem, sz); + } + } + else + { + /* *mem is a raw pointer to a Lisp object of some sort. + The object to which it points should have already been + dumped by dump_user_remembered_data_hot. */ + void *value; + Lisp_Object lv; + enum Lisp_Type type = -sz; + read_raw_ptr_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_raw_ptr (&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)); + ptrdiff_t 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) +{ + // XXX: omit relocations that duplicate BSS? + // XXX: prevent ralloc moving + // XXX: dumb mode for GC + struct dump_context *ctx = data; + if (ctx->fd >= 0) + emacs_close (ctx->fd); + Vpurify_flag = ctx->old_purify_flag; + unblock_input (); +} + +static Lisp_Object +make_eq_hash_table (void) +{ + return CALLN (Fmake_hash_table, QCtest, Qeq); +} + +static void +dump_do_fixup (struct dump_context *ctx, Lisp_Object fixup) +{ + enum dump_fixup_type type = XFASTINT (XCAR (fixup)); + fixup = XCDR (fixup); + ptrdiff_t dump_fixup_offset = ptrdiff_t_from_lisp (XCAR (fixup)); + fixup = XCDR (fixup); + Lisp_Object arg = XCAR (fixup); + eassert (NILP (XCDR (fixup))); + dump_seek (ctx, dump_fixup_offset); + ptrdiff_t target_offset; + 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)) + { + target_offset = 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_raw_ptr (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 + { + target_offset = emacs_offset (XSYMBOL (arg)); + dump_reloc_dump_to_emacs_raw_ptr (ctx, ctx->offset); + } + } + else + { + eassert (dump_object_emacs_ptr (arg) == NULL); + target_offset = dump_recall_object (ctx, arg); + if (target_offset <= 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_raw_ptr (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. */ + target_offset = ptrdiff_t_from_lisp (arg); + dump_reloc_dump_to_dump_raw_ptr (ctx, ctx->offset); + break; + default: + emacs_abort (); + } + if (do_write) + dump_write (ctx, &target_offset, sizeof (target_offset)); +} + +static ptrdiff_t +dump_check_dump_off (struct dump_context *ctx, ptrdiff_t dump_offset) +{ + eassert (dump_offset > 0); + if (ctx) + eassert (dump_offset < ctx->end_heap); + return dump_offset; +} + +static void +dump_check_emacs_off (ptrdiff_t emacs_off) +{ + eassert (labs (emacs_off) <= 30*1024*1024); +} + +static void +dump_emit_dump_reloc (struct dump_context *ctx, Lisp_Object lreloc) +{ + struct dump_reloc reloc; + dump_object_start (ctx, 1, &reloc, sizeof (reloc)); + reloc.type = XFASTINT (dump_pop (&lreloc)); + eassert (reloc.type <= RELOC_DUMP_TO_EMACS_LV + Lisp_Float); + reloc.offset = dump_off_from_lisp (dump_pop (&lreloc)); + dump_check_dump_off (ctx, reloc.offset); + eassert (reloc.offset % 4 == 0); // Alignment + eassert (NILP (lreloc)); + dump_object_finish (ctx, &reloc, sizeof (reloc)); +} + +static struct emacs_reloc +decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) +{ + struct emacs_reloc reloc; + memset (&reloc, 0, sizeof (reloc)); + int type = XFASTINT (dump_pop (&lreloc)); + 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: + { + reloc.type = type; + eassert (reloc.type == type); + reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc)); + dump_check_dump_off (ctx, reloc.u.dump_offset); + dump_off_t length = dump_off_from_lisp (dump_pop (&lreloc)); + reloc.length = length; + if (reloc.length != length) + error ("relocation copy length too large"); + } + break; + case RELOC_EMACS_IMMEDIATE: + { + reloc.type = type; + eassert (reloc.type == type); + intmax_t value = intmax_t_from_lisp (dump_pop (&lreloc)); + ptrdiff_t size = ptrdiff_t_from_lisp (dump_pop (&lreloc)); + reloc.u.immediate = value; + reloc.length = size; + eassert (reloc.length == size); + } + break; + default: + { + eassert (RELOC_EMACS_DUMP_LV <= type); + eassert (type <= RELOC_EMACS_DUMP_LV + Lisp_Float); + reloc.type = RELOC_EMACS_DUMP_LV; + eassert (reloc.type == RELOC_EMACS_DUMP_LV); + reloc.length = type - RELOC_EMACS_DUMP_LV; + eassert (reloc.length == type - RELOC_EMACS_DUMP_LV); + Lisp_Object target_value = dump_pop (&lreloc); + /* If the object is self-representing, + dump_emacs_reloc_to_dump_lv didn't do its job. + dump_emacs_reloc_to_dump_lv should have added a + RELOC_EMACS_IMMEDIATE relocation instead. */ + eassert (!dump_object_self_representing_p (target_value)); + reloc.u.dump_offset = dump_recall_object (ctx, target_value); + if (reloc.u.dump_offset <= 0) + { + Lisp_Object repr = Fprin1_to_string (target_value, Qnil); + error ("relocation target was not dumped: %s", SDATA (repr)); + } + dump_check_dump_off (ctx, reloc.u.dump_offset); + } + break; + case RELOC_EMACS_EMACS_PTR_RAW: + reloc.type = type; + eassert (reloc.type == 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: + reloc.type = type; + eassert (reloc.type == type); + reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc)); + dump_check_dump_off (ctx, reloc.u.dump_offset); + break; + } + + eassert (NILP (lreloc)); + return reloc; +} + +static void +dump_emit_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) +{ + struct emacs_reloc reloc; + dump_object_start (ctx, 1, &reloc, sizeof (reloc)); + reloc = decode_emacs_reloc (ctx, lreloc); + dump_object_finish (ctx, &reloc, sizeof (reloc)); +} + +static Lisp_Object +dump_merge_emacs_relocs (Lisp_Object lreloc_a, Lisp_Object lreloc_b) +{ + /* Combine copy relocations together if they're copying from + adjacent chunks to adjacent chunks. */ + + if (XFASTINT (XCAR (lreloc_a)) != RELOC_EMACS_COPY_FROM_DUMP || + XFASTINT (XCAR (lreloc_b)) != RELOC_EMACS_COPY_FROM_DUMP) + 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; + + ptrdiff_t new_length = reloc_a.length + reloc_b.length; + reloc_a.length = new_length; + if (reloc_a.length != new_length) + return Qnil; /* Overflow */ + + return list4 (make_number (RELOC_EMACS_COPY_FROM_DUMP), + INTEGER_TO_CONS (reloc_a.emacs_offset), + INTEGER_TO_CONS (reloc_a.u.dump_offset), + INTEGER_TO_CONS (reloc_a.length)); +} + +static void +drain_reloc_list (struct dump_context *ctx, + void (*handler)(struct dump_context *, Lisp_Object), + Lisp_Object (*merger)(Lisp_Object a, Lisp_Object b), + Lisp_Object *reloc_list, + struct dump_table_locator *out_locator) +{ + Lisp_Object relocs = Fsort (Fnreverse (*reloc_list), + Qdump_emacs_portable__sort_predicate); + *reloc_list = Qnil; + dump_align_output (ctx, sizeof (dump_off_t)); + struct dump_table_locator locator; + memset (&locator, 0, sizeof (locator)); + locator.offset = ctx->offset; + for (; !NILP (relocs); locator.nr_entries += 1) + { + Lisp_Object reloc = dump_pop (&relocs); + Lisp_Object merged; + while (merger != NULL && + !NILP (relocs) && + ((merged = merger (reloc, XCAR (relocs))), !NILP (merged))) + { + reloc = merged; + relocs = XCDR (relocs); + } + handler (ctx, reloc); + } + *out_locator = locator; +} + +static void +dump_do_fixups (struct dump_context *ctx) +{ + ptrdiff_t saved_offset = ctx->offset; + Lisp_Object fixups = Fsort (Fnreverse (ctx->fixups), + Qdump_emacs_portable__sort_predicate); + ctx->fixups = Qnil; + while (!NILP (fixups)) + dump_do_fixup (ctx, dump_pop (&fixups)); + dump_seek (ctx, saved_offset); +} + +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) + 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."); + + 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_tailq_init (&ctx->dump_queue); + ctx->fixups = Qnil; + ctx->copied_queue = Qnil; + ctx->cold_queue = Qnil; + ctx->dump_relocs = Qnil; + ctx->object_starts = Qnil; + ctx->emacs_relocs = Qnil; + + 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 (); + + 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)); + + dump_write (ctx, &ctx->header, sizeof (ctx->header)); + + /* Start the dump process by processing the static roots and + queuing up the objects to which they refer. */ + dump_roots (ctx); + + dump_charset_table (ctx); + dump_finalizer_list_head_ptr (ctx, &finalizers.prev); + dump_finalizer_list_head_ptr (ctx, &finalizers.next); + dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.prev); + dump_finalizer_list_head_ptr (ctx, &doomed_finalizers.next); + dump_user_remembered_data_hot (ctx); + + /* We've already remembered all of the GC roots themselves, but we + have to manually save the list of GC roots. */ + 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. */ + while (!dump_tailq_empty_p (&ctx->dump_queue)) + dump_object (ctx, dump_tailq_pop (&ctx->dump_queue)); + + eassert (dump_tailq_empty_p (&ctx->dump_queue)); + ctx->header.hot_discardable_start = ctx->offset; + + dump_copied_objects (ctx); + eassert (dump_tailq_empty_p (&ctx->dump_queue)); + eassert (NILP (ctx->copied_queue)); + + dump_align_output (ctx, getpagesize ()); + ctx->header.hot_end = ctx->offset; + dump_cold_data (ctx); + /* dump_user_remembered_data_cold needs to be after dump_cold_data + in case dump_cold_data dumps a lisp object to which C code + points. dump_user_remembered_data_cold assumes that all lisp + objects have been dumped. */ + dump_user_remembered_data_cold (ctx); + ctx->end_heap = ctx->offset; + dump_do_fixups (ctx); + drain_reloc_list ( + ctx, dump_emit_dump_reloc, NULL, + &ctx->dump_relocs, + &ctx->header.dump_relocs); + drain_reloc_list ( + ctx, dump_emit_dump_reloc, NULL, + &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); + + eassert (dump_tailq_empty_p (&ctx->dump_queue)); + eassert (NILP (ctx->fixups)); + eassert (NILP (ctx->dump_relocs)); + eassert (NILP (ctx->emacs_relocs)); + + ctx->header.magic[0] = dump_magic[0]; /* Note dump is complete. */ + dump_seek (ctx, 0); + dump_write (ctx, &ctx->header, sizeof (ctx->header)); + + return unbind_to (count, Qnil); + + // XXX: consider getting rid of hooks and just rely + // on explicit calls? + + // XXX: nullify frame_and_buffer_state + + // XXX: inline stuff in pdumper.h + + // XXX: preferred base address + + // XXX: make offset math non-fwrapv-safe + + // XXX: output symbol chains consecutively +} + +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) +{ + ptrdiff_t a_offset = ptrdiff_t_from_lisp (XCAR (XCDR (a))); + ptrdiff_t b_offset = ptrdiff_t_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 (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 (void *mem, ptrdiff_t nbytes) +{ + eassert (0 <= nbytes && nbytes <= INT_MAX); + if (nbytes > 0) + pdumper_remember_user_data_1 (mem, nbytes); +} + +void +pdumper_remember_lv_raw_ptr (void* ptr, enum Lisp_Type type) +{ + pdumper_remember_user_data_1 (ptr, -type); +} + + + +struct loaded_dump +{ + char *start; + char *end; + struct dump_header header; + unsigned *mark_bits; +}; + +struct loaded_dump loaded_dump; + +/* 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 greatest + relocation RELOC such that RELOC.offset <= KEY or NULL if no such + relocation exists. */ +static const struct dump_reloc * +dump_find_relocation (struct loaded_dump *dump, + const struct dump_table_locator *table, + dump_off_t key) +{ + const struct dump_reloc *left = (void *)(dump->start + table->offset); + const struct dump_reloc *right = left + table->nr_entries; + const struct dump_reloc *found = NULL; + + while (left < right) + { + const struct dump_reloc *mid = left + (right - left) / 2; + if (mid->offset <= key) + { + found = mid; + left = mid + 1; + if (left >= right || left->offset > key) + break; + } + else + right = mid; + } + + return found; +} + +static bool +dump_loaded_p (void) +{ + return loaded_dump.start != NULL; +} + +/* 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. */ +bool +pdumper_object_p (const void *obj) +{ + const char *p = obj; + return loaded_dump.start <= p && p < loaded_dump.end; +} + +/* 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. */ +bool +pdumper_object_p_precise (const void *obj) +{ + return pdumper_find_object_type (obj) != PDUMPER_NO_OBJECT; +} + +/* 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. */ +enum Lisp_Type +pdumper_find_object_type (const void *obj) +{ + eassert (pdumper_object_p (obj)); + ptrdiff_t offset = (char *) obj - (char *)loaded_dump.start; + if (offset % GCALIGNMENT != 0) + return PDUMPER_NO_OBJECT; + const struct dump_reloc *reloc = + dump_find_relocation (&loaded_dump, + &loaded_dump.header.object_starts, + offset); + return (reloc != NULL && reloc->offset == offset) + ? reloc->type + : PDUMPER_NO_OBJECT; +} + +static ptrdiff_t +dump_mark_bits_nbytes (ptrdiff_t max_offset) +{ + ptrdiff_t bits_needed = (max_offset + GCALIGNMENT - 1) / GCALIGNMENT; + ptrdiff_t bytes_needed = (bits_needed + CHAR_BIT - 1) / CHAR_BIT; + return ROUNDUP (bytes_needed, sizeof (unsigned)); +} + +bool +pdumper_marked_p (const void *obj) +{ + eassert (pdumper_object_p (obj)); + ptrdiff_t offset = (char *) obj - loaded_dump.start; + eassert (offset % GCALIGNMENT == 0); + eassert (offset < loaded_dump.header.hot_discardable_start); + ptrdiff_t bitno = offset / GCALIGNMENT; + ptrdiff_t slotno = bitno / (CHAR_BIT * sizeof (unsigned)); + unsigned *slot = &loaded_dump.mark_bits[slotno]; + return *slot & (1U << (bitno % (CHAR_BIT * sizeof (unsigned)))); +} + +void +pdumper_set_marked (const void *obj) +{ + eassert (pdumper_object_p (obj)); + ptrdiff_t offset = (char *) obj - loaded_dump.start; + eassert (offset % GCALIGNMENT == 0); + eassert (offset < loaded_dump.header.hot_discardable_start); + ptrdiff_t bitno = offset / GCALIGNMENT; + ptrdiff_t slotno = bitno / (CHAR_BIT * sizeof (unsigned)); + unsigned *slot = &loaded_dump.mark_bits[slotno]; + *slot |= (1U << (bitno % (CHAR_BIT * sizeof (unsigned)))); +} + +void +pdumper_clear_marks (void) +{ + memset (loaded_dump.mark_bits, 0, + dump_mark_bits_nbytes (loaded_dump.header.hot_discardable_start)); +} + +static ssize_t +pdumper_read (int fd, void *buf, size_t bytes_to_read) +{ + eassert (bytes_to_read <= SSIZE_MAX); + size_t bytes_read = 0; + while (bytes_read < bytes_to_read) + { + ssize_t chunk = + read (fd, (char*) buf + bytes_read, bytes_to_read - bytes_read); + if (chunk < 0) + return chunk; + if (chunk == 0) + break; + bytes_read += chunk; + } + + return bytes_read; +} + +static void * +dump_ptr (struct loaded_dump *dump, ptrdiff_t offset) +{ + eassert (dump->start + offset < dump->end); + return dump->start + offset; +} + +static void * +emacs_ptr (ptrdiff_t offset) +{ + // TODO: assert somehow that offset is actually inside Emacs + return (void *) (emacs_basis () + offset); +} + +static void +dump_do_dump_relocation (struct loaded_dump *dump, + struct dump_reloc reloc) +{ + ptrdiff_t *dump_ptr_ptr = dump_ptr (dump, reloc.offset); + ptrdiff_t dump_ptr = *dump_ptr_ptr; + ptrdiff_t dump_base = (ptrdiff_t) dump->start; + + /* For -O0 debugging: optimizer realizes this variable is dead and + optimizes it away. */ + ptrdiff_t orig_dump_ptr = dump_ptr; + (void) orig_dump_ptr; + + switch (reloc.type) + { + case RELOC_DUMP_TO_EMACS_RAW_PTR: + dump_ptr = dump_ptr + emacs_basis (); + *dump_ptr_ptr = dump_ptr; + break; + case RELOC_DUMP_TO_DUMP_RAW_PTR: + dump_ptr = dump_ptr + dump_base; + *dump_ptr_ptr = dump_ptr; + break; + default: + { + 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; + dump_ptr = dump_ptr + dump_base; + } + 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; + dump_ptr = dump_ptr + emacs_basis (); + } + + Lisp_Object lv; + if (lisp_type == Lisp_Symbol) + lv = make_lisp_symbol ((void *) dump_ptr); + else + lv = make_lisp_ptr ((void *) dump_ptr, lisp_type); + + * (Lisp_Object *) dump_ptr_ptr = lv; + break; + } + } + + // XXX: raw_ptr or ptr_raw. Pick one. +} + +static void +dump_do_dump_relocations (struct loaded_dump *dump) +{ + struct dump_header *header = &dump->header; + struct dump_reloc *r = dump_ptr (dump, header->dump_relocs.offset); + dump_off_t nr_entries = header->dump_relocs.nr_entries; + for (dump_off_t i = 0; i < nr_entries; ++i) + dump_do_dump_relocation (dump, r[i]); +} + +static void +dump_do_emacs_relocation (struct loaded_dump *dump, + struct emacs_reloc reloc) +{ + ptrdiff_t dump_base = (ptrdiff_t) dump->start; + 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, reloc.u.dump_offset), + reloc.length); + break; + case RELOC_EMACS_IMMEDIATE: + eassume (reloc.length > 0); + eassume (reloc.length <= sizeof (reloc.u.immediate)); + memcpy (emacs_ptr (reloc.emacs_offset), + &reloc.u.immediate, + reloc.length); + break; + case RELOC_EMACS_DUMP_PTR_RAW: + pval = reloc.u.dump_offset + dump_base; + memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval)); + break; + case RELOC_EMACS_EMACS_PTR_RAW: + pval = reloc.u.emacs_offset2 + emacs_basis (); + memcpy (emacs_ptr (reloc.emacs_offset), &pval, sizeof (pval)); + break; + case RELOC_EMACS_DUMP_LV: + eassume (reloc.length <= Lisp_Float); + if (reloc.length == Lisp_Symbol) + lv = make_lisp_symbol (dump_ptr (dump, reloc.u.dump_offset)); + else + lv = make_lisp_ptr (dump_ptr (dump, reloc.u.dump_offset), + 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_emacs_relocations (struct loaded_dump *dump) +{ + struct dump_header *header = &dump->header; + struct emacs_reloc *r = dump_ptr (dump, header->emacs_relocs.offset); + dump_off_t nr_entries = header->emacs_relocs.nr_entries; + for (dump_off_t i = 0; i < nr_entries; ++i) + dump_do_emacs_relocation (dump, r[i]); +} + +/* Load a dump from DUMP_FILENAME. 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) +{ + int fd = -1; + enum pdumper_load_result err = PDUMPER_LOAD_ERROR; + struct loaded_dump ndump; + struct stat stat; + struct dump_header *header = &ndump.header; + ptrdiff_t mark_nbytes; + + memset (&ndump, 0, sizeof (ndump)); + eassert (!initialized); + eassert (!dump_loaded_p ()); + + err = PDUMPER_LOAD_FILE_NOT_FOUND; + fd = emacs_open (dump_filename, O_RDONLY, 0); + if (fd < 0) + goto out; + + if (fstat (fd, &stat) < 0) + goto out; + + err = PDUMPER_LOAD_BAD_FILE_TYPE; + if (stat.st_size < sizeof (*header)) + goto out; + + err = PDUMPER_LOAD_OOM; + ndump.start = malloc (stat.st_size); + if (ndump.start == NULL) + goto out; + eassert ((ptrdiff_t) ndump.start % GCALIGNMENT == 0); + ndump.end = ndump.start + stat.st_size; + + err = PDUMPER_LOAD_BAD_FILE_TYPE; + if (pdumper_read (fd, ndump.start, stat.st_size) < stat.st_size) + goto out; + + memcpy (header, ndump.start, sizeof (*header)); + if (memcmp (header->magic, dump_magic, sizeof (dump_magic) != 0)) + goto out; + + err = PDUMPER_LOAD_VERSION_MISMATCH; + verify (sizeof (header->fingerprint) == sizeof (fingerprint)); + if (memcmp (header->fingerprint, fingerprint, sizeof (fingerprint))) + goto out; + + err = PDUMPER_LOAD_ERROR; + mark_nbytes = dump_mark_bits_nbytes (ndump.header.hot_discardable_start); + ndump.mark_bits = calloc (1, mark_nbytes); + if (ndump.mark_bits == NULL) + goto out; + + /* Point of no return. */ + + gflags.dumped_with_pdumper_ = true; + loaded_dump = ndump; + memset (&ndump, 0, sizeof (ndump)); + err = PDUMPER_LOAD_SUCCESS; + + dump_do_dump_relocations (&loaded_dump); + dump_do_emacs_relocations (&loaded_dump); + + /* Run the functions Emacs registered for doing post-dump-load + initialization. */ + for (int i = 0; i < nr_dump_hooks; ++i) + dump_hooks[i] (); + gflags.initialized_ = true; + + out: + free (ndump.mark_bits); + free (ndump.start); + if (0 <= fd) + emacs_close (fd); + return err; +} + + + +void +syms_of_pdumper (void) +{ + 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"); +} diff --git a/src/pdumper.h b/src/pdumper.h new file mode 100644 index 0000000..d6922b7 --- /dev/null +++ b/src/pdumper.h @@ -0,0 +1,115 @@ +/* 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 . */ + +#ifndef EMACS_PDUMPER_H +#define EMACS_PDUMPER_H + +#include "lisp.h" + +/* 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. */ + +/* 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)) + +/* 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)) +void pdumper_remember_scalar (void *data, ptrdiff_t nbytes); + +/* 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. */ +void pdumper_remember_lv_raw_ptr (void* ptr, enum Lisp_Type type); + +/* Remember the pointer at *PTR. *PTR must be null or point to + something in the Emacs process image (e.g., a function). */ +void pdumper_remember_emacs_ptr (void *ptr); + +typedef void (*pdumper_hook)(void); +void pdumper_do_now_and_after_load (pdumper_hook); + +/* 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) \ + (variable) = (value); \ + else \ + eassert ((variable) == (value)); \ + } while (0) + +#define PDUMPER_RESET_LV(variable, value) \ + do { \ + if (dumped_with_pdumper) \ + (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_OOM, + PDUMPER_LOAD_VERSION_MISMATCH, + PDUMPER_LOAD_ERROR, + }; + +enum pdumper_load_result pdumper_load (const char *dump_filename); + +_GL_ATTRIBUTE_CONST +bool pdumper_object_p (const void *obj); +#define PDUMPER_NO_OBJECT ((enum Lisp_Type) -1) +_GL_ATTRIBUTE_CONST +enum Lisp_Type pdumper_find_object_type (const void *obj); +_GL_ATTRIBUTE_CONST +bool pdumper_object_p_precise (const void *obj); + +bool pdumper_marked_p (const void *obj); +void pdumper_set_marked (const void *obj); +void pdumper_clear_marks (void); + +void syms_of_pdumper (void); + + + +#endif diff --git a/src/process.c b/src/process.c index 49340b1..6bb2c02 100644 --- a/src/process.c +++ b/src/process.c @@ -7797,9 +7797,7 @@ init_process_emacs (int sockfd) inhibit_sentinels = 0; -#ifndef CANNOT_DUMP - if (! noninteractive || initialized) -#endif + if (!will_dump_with_unexec) { #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 07e21ae..8036fe6 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see . */ #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. */ @@ -572,6 +573,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) { @@ -610,4 +613,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) + { + 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 e597c33..68b788b 100644 --- a/src/search.c +++ b/src/search.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include "region-cache.h" #include "blockinput.h" #include "intervals.h" +#include "pdumper.h" #include #include "regex.h" @@ -3390,25 +3391,18 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) return val; } + +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].whitespace_regexp = Qnil; - searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); staticpro (&searchbufs[i].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"); @@ -3466,4 +3460,22 @@ 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].whitespace_regexp = Qnil; + 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/sysdep.c b/src/sysdep.c index 892e976..00f128c 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -1850,7 +1850,7 @@ maybe_fatal_sig (int sig) } void -init_signals (bool dumping) +init_signals (void) { struct sigaction thread_fatal_action; struct sigaction action; @@ -2001,7 +2001,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) return; sigfillset (&process_fatal_action.sa_mask); diff --git a/src/syssignal.h b/src/syssignal.h index 3de83c7..5f9a0da 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -22,7 +22,7 @@ along with GNU Emacs. If not, see . */ #include -extern void init_signals (bool); +extern void init_signals (void); extern void block_child_signal (sigset_t *); extern void unblock_child_signal (sigset_t const *); extern void block_tty_out_signal (sigset_t *); diff --git a/src/textprop.c b/src/textprop.c index 7af8c69..fdbb761 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -2340,11 +2340,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/w32fns.c b/src/w32fns.c index 8c8272b..4c8b651 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -56,6 +56,8 @@ along with GNU Emacs. If not, see . */ #include "w32.h" #endif +#include "pdumper.h" + #include #include #include @@ -9767,6 +9769,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 4d15cff..69c0763 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -32,6 +32,8 @@ along with GNU Emacs. If not, see . */ #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. @@ -2567,6 +2569,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) { @@ -2746,6 +2751,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) +{ w32font_driver.type = Qgdi; register_font_driver (&w32font_driver, NULL); } diff --git a/src/w32menu.c b/src/w32menu.c index 7c66360..bc187e2 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -30,6 +30,7 @@ along with GNU Emacs. If not, see . */ #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. */ @@ -1585,6 +1586,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/w32uniscribe.c b/src/w32uniscribe.c index 5f91b50..000adcb 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see . */ #include "composite.h" #include "font.h" #include "w32font.h" +#include "pdumper.h" struct uniscribe_font_info { @@ -1168,9 +1169,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 acbefcd..aa87283 100644 --- a/src/window.c +++ b/src/window.c @@ -42,6 +42,7 @@ along with GNU Emacs. If not, see . */ #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 **, @@ -7274,10 +7275,56 @@ 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; + if (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 (dumped_with_pdumper) + mode_line_in_non_selected_windows = + old_mode_line_in_non_selected_windows; XSETFRAME (selected_frame, f); Vterminal_frame = selected_frame; minibuf_window = f->minibuffer_window; @@ -7324,16 +7371,6 @@ syms_of_window (void) DEFSYM (Qfloor, "floor"); DEFSYM (Qceiling, "ceiling"); - 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 c2b7317..53d3632 100644 --- a/src/xfont.c +++ b/src/xfont.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include "character.h" #include "charset.h" #include "font.h" +#include "pdumper.h" /* X core font driver. */ @@ -1113,6 +1114,9 @@ xfont_check (struct frame *f, struct font *font) } + +static void syms_of_xfont_for_pdumper (void); + void syms_of_xfont (void) { @@ -1120,6 +1124,12 @@ syms_of_xfont (void) xfont_scripts_cache = CALLN (Fmake_hash_table, QCtest, Qequal); staticpro (&xfont_scratch_props); xfont_scratch_props = Fmake_vector (make_number (8), Qnil); + pdumper_do_now_and_after_load (syms_of_xfont_for_pdumper); +} + +static void +syms_of_xfont_for_pdumper (void) +{ xfont_driver.type = Qx; register_font_driver (&xfont_driver, NULL); } diff --git a/src/xftfont.c b/src/xftfont.c index 861ad80..c9efb6d 100644 --- a/src/xftfont.c +++ b/src/xftfont.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #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); + void syms_of_xftfont (void) { @@ -768,8 +771,12 @@ 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) +{ xftfont_driver = ftfont_driver; xftfont_driver.type = Qxft; xftfont_driver.get_cache = xfont_driver.get_cache; @@ -789,8 +796,8 @@ This is needed with some fonts to correct vertical overlap of glyphs. */); xftfont_driver.shape = xftfont_shape; #endif /* When using X double buffering, the XftDraw structure we build - seems to be useless once a frame is resized, so recreate it on - ConfigureNotify and in some other cases. */ + seems to be useless once a frame is resized, so recreate it on + ConfigureNotify and in some other cases. */ xftfont_driver.drop_xrender_surfaces = xftfont_drop_xrender_surfaces; register_font_driver (&xftfont_driver, NULL); diff --git a/src/xmenu.c b/src/xmenu.c index 9ab7bdf..f080ffb 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -44,6 +44,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "coding.h" #include "sysselect.h" +#include "pdumper.h" #ifdef MSDOS #include "msdos.h" @@ -2337,15 +2338,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); @@ -2354,4 +2352,16 @@ syms_of_xmenu (void) Ffset (intern_c_string ("accelerate-menu"), intern_c_string (Sx_menu_bar_open_internal.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 b997cc8..bfa0dfb 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -35,6 +35,7 @@ along with GNU Emacs. If not, see . */ #include "blockinput.h" #include "termhooks.h" #include "keyboard.h" +#include "pdumper.h" #include @@ -2620,6 +2621,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) { @@ -2635,17 +2639,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. @@ -2724,4 +2720,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 d7af68f..259cc57 100644 --- a/src/xsettings.c +++ b/src/xsettings.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "keyboard.h" #include "blockinput.h" #include "termhooks.h" +#include "pdumper.h" #include @@ -1008,13 +1009,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 bdc21e6..ea21e8f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -81,6 +81,7 @@ along with GNU Emacs. If not, see . */ #include "xsettings.h" #include "sysselect.h" #include "menu.h" +#include "pdumper.h" #ifdef USE_X_TOOLKIT #include @@ -12809,6 +12810,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"); --------------6DD91D7A55B57EBB568F2D24--