diff options
Diffstat (limited to 'lisp/loadup.el')
| -rw-r--r-- | lisp/loadup.el | 383 |
1 files changed, 342 insertions, 41 deletions
diff --git a/lisp/loadup.el b/lisp/loadup.el index af42cd97111..e063ad8fc54 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -1,4 +1,4 @@ -;;; loadup.el --- load up standardly loaded Lisp files for Emacs +;;; loadup.el --- load up standardly loaded Lisp files for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1986, 1992, 1994, 2001-2017 Free Software ;; Foundation, Inc. @@ -57,6 +57,17 @@ ;; Add subdirectories to the load-path for files that might get ;; autoloaded when bootstrapping. ;; This is because PATH_DUMPLOADSEARCH is just "../lisp". +(let ((dir (car load-path))) + (message "load path is %S" load-path) + (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)))) + +(setq purify-flag nil) + (if (or (equal (member "bootstrap" command-line-args) '("bootstrap")) ;; FIXME this is irritatingly fragile. (and (stringp (nth 4 command-line-args)) @@ -64,22 +75,13 @@ (nth 4 command-line-args))) (member (nth 7 command-line-args) '("unidata-gen-file" "unidata-gen-charprop")) - (if (fboundp 'dump-emacs) + (if t; (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))))) + ;; 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. @@ -88,7 +90,7 @@ (message "Using load-path %s" load-path) ;; This is a poor man's `last', since we haven't loaded subr.el yet. -(if (and (fboundp 'dump-emacs) +(if (and t; (fboundp 'dump-emacs) (or (equal (member "bootstrap" command-line-args) '("bootstrap")) (equal (member "dump" command-line-args) '("dump")))) (progn @@ -314,9 +316,12 @@ ;; Preload some constants and floating point functions. (load "emacs-lisp/float-sup") +(load "emacs-lisp/cl-macs") +(load "emacs-lisp/cl-lib") +(load "emacs-lisp/gv") + (load "vc/vc-hooks") (load "vc/ediff-hook") -(load "uniquify") (load "electric") (load "emacs-lisp/eldoc") (load "cus-start") ;Late to reduce customize-rogue (needs loaddefs.el anyway) @@ -350,14 +355,14 @@ lost after dumping"))) ;; in non-ASCII directories is to manipulate unibyte strings in the ;; current locale's encoding. (if (and (member (car (last command-line-args)) '("dump" "bootstrap")) - (fboundp 'dump-emacs) + t; (fboundp 'dump-emacs) (multibyte-string-p default-directory)) (error "default-directory must be unibyte when dumping Emacs!")) ;; Determine which build number to use ;; based on the executables that now exist. (if (and (equal (last command-line-args) '("dump")) - (fboundp 'dump-emacs) + t; (fboundp 'dump-emacs) (not (eq system-type 'ms-dos))) (let* ((base (concat "emacs-" emacs-version ".")) (exelen (if (eq system-type 'windows-nt) -4)) @@ -375,9 +380,9 @@ lost after dumping"))) (message "Finding pointers to doc strings...") -(if (and (fboundp 'dump-emacs) +(if (and t; (fboundp 'dump-emacs) (equal (last command-line-args) '("dump"))) - (Snarf-documentation "DOC") + (Snarf-documentation "DOC" 'clear) (condition-case nil (Snarf-documentation "DOC") (error nil))) @@ -445,7 +450,7 @@ lost after dumping"))) ;; Make sure we will attempt bidi reordering henceforth. (setq redisplay--inhibit-bidi nil) -(if (and (fboundp 'dump-emacs) +(if (and t; (fboundp 'dump-emacs) (member (car (last command-line-args)) '("dump" "bootstrap"))) (progn ;; Prevent build-time PATH getting stored in the binary. @@ -461,29 +466,325 @@ lost after dumping"))) ;; 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 (format "emacs-%s.%d" emacs-version emacs-build-number)) - (exe (if (eq system-type 'windows-nt) ".exe" ""))) - (while (string-match "[^-+_.a-zA-Z0-9]+" name) - (setq name (concat (downcase (substring name 0 (match-beginning 0))) + ;; (dump-emacs "emacs" "temacs") + ;; (message "%d pure bytes used" pure-bytes-used) + (let ((exe (if (memq system-type '(cygwin windows-nt ms-dos)) ".exe" ""))) + (copy-file (expand-file-name (concat "temacs" exe) invocation-directory) + (expand-file-name (concat "emacs" exe) invocation-directory) + t) + ;; Recompute NAME now, so that it isn't set when we dump. + (if (not (or (eq system-type 'ms-dos) + ;; Don't bother adding another name if we're just + ;; building bootstrap-emacs. + (equal (last command-line-args) '("bootstrap")))) + (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))) + (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))) + (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)))) + (message "Dumping into dumped.elc...preparing...") + + ;; Dump the current state into a file so we can reload it! + (message "Dumping into dumped.elc...generating...") + (let ((faces '()) + (coding-systems '()) (coding-system-aliases '()) + (charsets '()) (charset-aliases '()) + (unified-charsets '()) + (abbrev-tables (make-hash-table :test 'eq)) + (abbrev-assign-cmds '()) + (abbrev-make-cmds '()) + (abbrev-counter 0) + (cmds '())) + (setcdr global-buffers-menu-map nil) ;; Get rid of buffer objects! + (push `(internal--set-standard-syntax-table + ,(standard-syntax-table)) + cmds) + (mapatoms + (lambda (s) + (when (fboundp s) + (if (subrp (symbol-function s)) + ;; subr objects aren't readable! + (unless (equal (symbol-name s) (subr-name (symbol-function s))) + (push `(fset ',s (symbol-function ',(intern (subr-name (symbol-function s))))) cmds)) + (push `(fset ',s ,(macroexp-quote (symbol-function s))) + cmds))) + (if (not (eq (indirect-variable s) s)) + (push `(defvaralias ',s ',(indirect-variable s)) + cmds)) + (when (and (default-boundp s) + (not (macroexp--const-symbol-p s 'any-value)) + ;; I think we don't need/want these! + (not (memq s '(terminal-frame obarray + initial-window-system window-system + ;; custom-delayed-init-variables + current-load-list + coding-system-list + internal--text-quoting-flag + exec-path + process-environment + initial-environment + exec-directory + data-directory + charset-map-path + source-directory + invocation-directory + load-file-name + doc-directory + load-path + user-full-name + user-login-name + user-real-login-name + system-name + command-line-args noninteractive + load-history + ;; Any let-bound variables during + ;; dump process will be useless. + faces coding-systems coding-system-aliases + charsets charset-aliases unified-charsets + abbrev-tables abbrev-counter + abbrev-make-cmds abbrev-assign-cmds + cmds))) + (eq (indirect-variable s) s)) + (let ((v (default-value s))) + (push `(set-default + ',s + ,(cond + ;; FIXME: (Correct) hack to avoid + ;; unprintable objects. + ((eq s 'undo-auto--undoably-changed-buffers) nil) + ;; FIXME: Incorrect hack to avoid + ;; unprintable objects. + ((eq s 'advertised-signature-table) + (make-hash-table :test 'eq :weakness 'key)) + ((subrp v) + `(symbol-function ',(intern (subr-name v)))) + ((and (markerp v) (null (marker-buffer v))) + '(make-marker)) + ((and (overlayp v) (null (overlay-buffer v))) + (let (propsets + (props (overlay-properties v))) + (while props + (let ((prop (car props)) + (val (cadr props))) + (push `(overlay-put ol ',prop ',val) propsets) + (setq props (cddr props)))) + `(let ((ol (make-overlay (point-min) (point-min)))) + ,@propsets + (delete-overlay ol) + ol))) + ;; abbrev-table-p isn't very robust + ((condition-case nil + (abbrev-table-p v) + (error nil)) + (cl-labels ((replace-abbrevs-for-dump + (table) + (or (abbrev-table-empty-p table) + (error "Non-empty abbrev tables not handled")) + (let ((newval (gethash table abbrev-tables))) + (if newval + `(aref scratch-abbrev-tables ,newval) + (let* ((props (symbol-plist (obarray-get table "")))) + (cond ((plist-get props :parents) + (setq props (copy-sequence props)) + (plist-put props + :parents + (mapcar (lambda (value) + (list '\, (replace-abbrevs-for-dump value))) + (plist-get props :parents))) + (setq props (list '\` props))) + ((eq (length props) 2) + ;; Only :abbrev-table-modiff, which gets added at creation anyway. + (setq props nil))) + (push `(aset scratch-abbrev-tables + ,abbrev-counter + ,(if props + `(make-abbrev-table ,props) + '(make-abbrev-table))) + abbrev-make-cmds) + (puthash table abbrev-counter abbrev-tables) + (prog1 + `(aref scratch-abbrev-tables ,abbrev-counter) + (setq abbrev-counter (1+ abbrev-counter)))))))) + (push `(set-default ',s + ,(replace-abbrevs-for-dump v)) + abbrev-assign-cmds)) + ;; Placeholder to be used before we know + ;; we've defined make-abbrev-table. + 0) + (v (macroexp-quote v)))) + cmds) + ;; Local variables: make-variable-buffer-local, + ;; make-local-variable, and make-variable-frame-local. + ;; + ;; We may need better introspection facilities to get + ;; this right. For now, assume only the first kind is + ;; in use during loadup. + (if (local-variable-if-set-p s) + (push `(make-variable-buffer-local ',s) cmds)) + (if (special-variable-p s) + ;; A dummy initializer is needed for defvar to mark + ;; the variable as special. + (push `(defvar ,s 0) cmds)))) + (when (symbol-plist s) + (push `(setplist ',s ',(symbol-plist s)) cmds)) + (when (get s 'face-defface-spec) + (push s faces)) + (if (get s 'internal--cs-args) + (push s coding-systems)) + (when (and (coding-system-p s) + (not (eq s (car (coding-system-aliases s))))) + (push (cons s (car (coding-system-aliases s))) + coding-system-aliases)) + (if (get s 'internal--charset-args) + (progn + (push s charsets) + (if (member :unify-map + (nth 15 (get s 'internal--charset-args))) + (push s unified-charsets))) + (when (and (charsetp s) + (not (eq s (get-charset-property s :name)))) + (push (cons s (get-charset-property s :name)) + charset-aliases)))) + obarray) + + ;; Convert preloaded file names in load-history to relative + (let ((simple-file-name + ;; Look for simple.el or simple.elc and use their directory + ;; as the place where all Lisp files live. + (locate-file "simple" load-path (get-load-suffixes))) + lisp-dir lisp-dir-length) + ;; Don't abort if simple.el cannot be found, but print a warning. + ;; Although in most usage we are going to cryptically abort a moment + ;; later anyway, due to missing required bidi data files (eg bug#13430). + (if (null simple-file-name) + (let ((standard-output 'external-debugging-output) + (lispdir (expand-file-name "../lisp" data-directory))) + (princ "Warning: Could not find simple.el or simple.elc") + (terpri) + (when (getenv "EMACSLOADPATH") + (princ "The EMACSLOADPATH environment variable is set, \ +please check its value") + (terpri)) + (unless (file-readable-p lispdir) + (princ (format "Lisp directory %s not readable?" lispdir)) + (terpri))) + (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-dir-length (length lisp-dir)) + (let ((fake-load-history + (mapcar (lambda (elt) + (if (and (stringp (car elt)) + (file-name-absolute-p (car elt)) + (> (length (car elt)) lisp-dir-length) + (string-equal lisp-dir + (substring (car elt) 0 lisp-dir-length)) + ) + (cons (substring (car elt) lisp-dir-length) + (cdr elt)) + elt)) + load-history))) + (push `(setq load-history ',fake-load-history) + cmds)))) + + (message "Dumping into dumped.elc...printing...") + (with-current-buffer (generate-new-buffer "dumped.elc") + (setq default-directory invocation-directory) + (insert ";ELC\^W\^@\^@\^@\n;;; Compiled\n;;; in Emacs version " + emacs-version "\n") + (let ((print-circle t) + (print-gensym t) + (print-quoted t) + (print-level nil) + (print-length nil) + (print-escape-newlines t) + (print-symbols-as-references t) + (standard-output (current-buffer))) + (print '(setq purify-flag nil)) + (print '(get-buffer-create "*Messages*")) + (print `(progn . ,cmds)) + ;; Now that make-abbrev-table is defined, use it. + (print `(let ((scratch-abbrev-tables (make-vector ,abbrev-counter 0))) + ,@(nreverse abbrev-make-cmds) + ,@abbrev-assign-cmds)) + (print `(let ((css ',charsets)) + (dotimes (i 3) + (dolist (cs (prog1 css (setq css nil))) + ;; (message "Defining charset %S..." cs) + (condition-case nil + (progn + (apply #'define-charset-internal + cs (get cs 'internal--charset-args)) + ;; (message "Defining charset %S...done" cs) + ) + (error + ;; (message "Defining charset %S...postponed" + ;; cs) + (push cs css))))))) + (print `(dolist (cs ',charset-aliases) + (define-charset-alias (car cs) (cdr cs)))) + (print `(let ((css ',coding-systems)) + (dotimes (i 3) + (dolist (cs (prog1 css (setq css nil))) + ;; (message "Defining coding-system %S..." cs) + (condition-case nil + (progn + (apply #'define-coding-system-internal + cs (get cs 'internal--cs-args)) + ;; (message "Defining coding-system %S...done" cs) + ) + (error + ;; (message "Defining coding-system %S...postponed" + ;; cs) + (push cs css))))))) + (print `(mapcar 'unify-charset ',unified-charsets)) + (print `(dolist (f ',faces) + (face-spec-set f (get f 'face-defface-spec) + 'face-defface-spec))) + ;; This creates some rather large data structures that are + ;; more quickly reconstructed than read from the dumped + ;; Lisp state. + (print '(load "international/characters" nil t)) + ;; This sets advice on a subr, so cannot be preloaded. + (print '(load "uniquify" nil t)) + ;; Lisp functions have their DOC file offsets stored + ;; already, but for a subr it's hidden away from Lisp. + (print '(condition-case nil + (Snarf-documentation "DOC") + (file-missing + (message "Couldn't load DOC file")))) + (print `(dolist (cs ',coding-system-aliases) + (define-coding-system-alias (car cs) (cdr cs)))) + (print `(progn + ;; (message "Done preloading!") + ;; (message "custom-delayed-init-variables = %S" + ;; custom-delayed-init-variables) + ;; (message "Running top-level = %S" top-level) + (setq debug-on-error t) + (use-global-map global-map) + (eval top-level) + ;; (message "top-level done!?") + ))) + (goto-char (point-min)) + (while (re-search-forward " (\\(defvar\\|setplist\\|fset\\) " nil t) + (goto-char (match-beginning 0)) + (delete-char 1) (insert "\n")) + (message "Dumping into dumped.elc...saving...") + (let ((coding-system-for-write 'emacs-internal)) + (write-region (point-min) (point-max) (buffer-name))) + (message "Dumping into dumped.elc...done") + )) + (kill-emacs))) +(load "uniquify") + ;; For machines with CANNOT_DUMP defined in config.h, ;; this file must be loaded each time Emacs is run. ;; So run the startup code now. First, remove `-l loadup' from args. |