X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Floadup.el;h=fa64a15e9c54fc5dd32ac7596304d1113ff56471;hb=2df059c60e547b9e6c827eea2682bd1511983dc0;hp=61188a9a694d18c46c152db0559d469977a6821d;hpb=77dcef404dc78635f6ffa8f71a803d2bc7cc8921;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/loadup.el b/lisp/loadup.el index 61188a9..fa64a15 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -42,16 +42,44 @@ (defvar preloaded-file-list nil "List of files preloaded into the XEmacs binary image.") +(defvar Installation-string nil + "Description of XEmacs installation.") -(let ((gc-cons-threshold 30000)) +;(start-profiling) + +(let ((gc-cons-threshold + ;; setting it low makes loadup incredibly fucking slow. + ;; no need to do it when not dumping. + (if (and purify-flag + (not (memq 'quick-build internal-error-checking))) + 30000 3000000))) ;; This is awfully damn early to be getting an error, right? (call-with-condition-handler 'really-early-error-handler #'(lambda () - ;; message not defined yet ... - (setq load-path (split-path (getenv "EMACSBOOTSTRAPLOADPATH"))) + ;; Initialize Installation-string. We do it before loading + ;; anything so that dumped code can make use of its value. + (setq Installation-string + (save-current-buffer + (set-buffer (get-buffer-create (generate-new-buffer-name + " *temp*"))) + ;; insert-file-contents-internal bogusly calls + ;; format-decode without checking if it's defined. + (fset 'format-decode #'(lambda (f l &optional v) l)) + (insert-file-contents-internal "../Installation") + (fmakunbound 'format-decode) + (prog1 (buffer-substring) + (kill-buffer (current-buffer))))) + + (let ((build-root (expand-file-name ".." invocation-directory))) + (setq load-path (list (expand-file-name "lisp" build-root))) + (setq module-load-path (list (expand-file-name "modules" build-root)))) + + ;; message not defined yet ... (external-debugging-output (format "\nUsing load-path %s" load-path)) + (external-debugging-output (format "\nUsing module-load-path %s" + module-load-path)) ;; We don't want to have any undo records in the dumped XEmacs. (buffer-disable-undo (get-buffer "*scratch*")) @@ -84,11 +112,14 @@ (defun pureload (file) (let ((full-path (locate-file file load-path - (if load-ignore-elc-files ".el:" ".elc:.el:")))) + (if load-ignore-elc-files + '(".el" "") '(".elc" ".el" ""))))) (if full-path (prog1 (load full-path) - (garbage-collect)) + ;; but garbage collection really slows down loading. + (unless (memq 'quick-build internal-error-checking) + (garbage-collect))) (external-debugging-output (format "\nLoad file %s: not found\n" file)) ;; Uncomment in case of trouble @@ -96,7 +127,7 @@ ;;(print (format "guessed-roots: %S" (paths-find-emacs-roots invocation-directory invocation-name))) nil))) - (load (concat default-directory "../lisp/dumped-lisp.el")) + (load (expand-file-name "../lisp/dumped-lisp.el")) (let ((files preloaded-file-list) file) @@ -134,7 +165,8 @@ ;; is generated. For VMS, you must edit ../../vms/makedoc.com. ;; For other systems, you must edit ../../src/Makefile.in.in. (when (load "site-load" t) - (garbage-collect)) + (garbage-collect) +) ;;FSFmacs randomness ;;(if (fboundp 'x-popup-menu) @@ -143,7 +175,6 @@ ;;; for the sake of the next call to precompute-menubar-bindings. ;(setq define-key-rebound-commands nil) - ;; Note: all compiled Lisp files loaded above this point ;; must be among the ones parsed by make-docfile ;; to construct DOC. Any that are not processed @@ -172,6 +203,71 @@ ) ;; frequent garbage collection +;(stop-profiling) + +;; yuck! need to insert the function def here, and rewrite the dolist +;; loop below. + +;(defun loadup-profile-results (&optional info stream) +; "Print profiling info INFO to STREAM in a pretty format. +;If INFO is omitted, the current profiling info is retrieved using +; `get-profiling-info'. +;If STREAM is omitted, either a *Profiling Results* buffer or standard +; output are used, depending on whether the function was called +; interactively or not." +; (interactive) +; (setq info (if info +; (copy-alist info) +; (get-profiling-info))) +; (when (and (not stream) +; (interactive-p)) +; (pop-to-buffer (get-buffer-create "*Profiling Results*")) +; (erase-buffer)) +; (let ((standard-output (or stream (if (interactive-p) +; (current-buffer) +; standard-output))) +; ;; Calculate the longest function +; (maxfunlen (apply #'max +; (length "Function Name") +; (mapcar +; (lambda (el) +; ;; Functions longer than 50 characters (usually +; ;; anonymous functions) don't qualify +; (let ((l (length (format "%s" (car el))))) +; (if (< l 50) +; l 0))) +; info)))) +; (princ (format "%-*s Ticks %%/Total Call Count\n" +; maxfunlen "Function Name")) +; (princ (make-string maxfunlen ?=)) +; (princ " ===== ======= ==========\n") +; (let ((sum (float (apply #'+ (mapcar #'cdr info))))) +; (let (entry +; (entry-list (nreverse (sort info #'cdr-less-than-cdr)))) +; (while entry-list +; (setq entry (car entry-list)) +; (princ (format "%-*s %-5d %-6.3f %s\n" +; maxfunlen (car entry) (cdr entry) +; (* 100 (/ (cdr entry) sum)) +; (or (gethash (car entry) call-count-profile-table) +; ""))) +; (setq entry-list (cdr entry-list)))) +; (princ (make-string maxfunlen ?-)) +; (princ "---------------------------------\n") +; (princ (format "%-*s %-5d %-6.2f\n" maxfunlen "Total" sum 100.0)) +; (princ (format "\n\nOne tick = %g ms\n" +; (/ default-profiling-interval 1000.0))) +; (and (boundp 'internal-error-checking) +; internal-error-checking +; (princ " +;WARNING: Error checking is turned on in this XEmacs. This might make +; the measurements very unreliable.\n")))) +; (when (and (not stream) +; (interactive-p)) +; (goto-char (point-min)))) + +;(loadup-profile-results nil 'external-debugging-output) + ;; Dump into the name `xemacs' (only) (when (member "dump" command-line-args) (message "Dumping under the name xemacs") @@ -179,7 +275,14 @@ ;; (condition-case () (delete-file "xemacs") (file-error nil)) (when (fboundp 'really-free) (really-free)) - (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") + (dump-emacs + (cond + ((featurep 'infodock) "infodock") + ;; #### BILL!!! + ;; If we want to dump under a name other than `xemacs', do that here! + ;; ((featurep 'gtk) "xemacs-gtk") + (t "xemacs")) + "temacs") (kill-emacs)) ;; Avoid error if user loads some more libraries now.