Download
(require 'advice)
(defgroup byte-code-cache nil
"Instead of separately byte-compiling everything, this package
intercepts LOADs and byte-compiles files on the fly."
:group 'internal)
(defcustom bcc-cache-directory "~/.emacs.d/byte-cache"
"The directory in which we store cached byte-compiled files"
:type 'directory
:group 'byte-code-cache)
(defcustom bcc-enabled t
"Whether to use the byte-code cache when loading"
:type 'boolean
:group 'byte-code-cache)
(defcustom bcc-blacklist '("/\\.recentf$" "/history$")
"List of regular expressions matching files that should
not be cached. Files that are modified every time Emacs
is run are good candidates for this list."
:type '(repeat regexp)
:group 'byte-code-cache)
(unless (boundp 'load-source-file-function)
(error "byte-code-cache requires LOAD-SOURCE-FILE-FUNCTION"))
(defvar bcc-old-load-source-file-function
load-source-file-function
"Saved LOAD-SOURCE-FILE-FUNCTION")
(defvar bcc-regenerate-toplevel t
"t unless we're inside BCC-REGENERATE-CACHE")
(defvar bcc-loaded-fake-cache-entry nil
"Internal. Fake cache entries set this to t to indicate that
BCC-LOAD-SOURCE-FILE should load the original file.")
(defvar bcc-loaded nil
"List of files loaded with bcc-load-source-file. List of conses.
car is origname, cdr is cachename.")
(defconst bcc-compiled-doc-string 4
"From lisp.h")
(defmacro bcc-assert (expr)
"Like ASSERT, but doesn't depend on CL"
`(or ,expr (signal 'bcc-assert-failed (list ',expr))))
(defun bcc-delete-file-noerror (filename)
"Delete file FILENAME. No error if it doesn't exist."
(condition-case nil
(delete-file filename)
(error nil)))
(defun bcc-unconditionally-kill-buffer (buffer)
"Kill buffer without asking the user or running any hooks"
(when (buffer-modified-p buffer)
(with-current-buffer buffer
(restore-buffer-modified-p nil)))
(let (kill-buffer-hook kill-buffer-query-functions)
(kill-buffer buffer)))
(defun bcc-alist-member-delete-all (alist &rest keys)
"Delete from ALIST all elements whose car is `equal' to any element in KEYS.
Return the modified alist. Elements of ALIST that are not conses
are ignored."
(while (and (consp (car alist))
(member (car (car alist)) keys))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(member (car (car tail-cdr)) keys))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
(defun bcc-cache-file-name (file-name)
"Transform an absolute file-name into its cache directory entry.
The resulting name is always an absolute path to a file ending in
.elc"
(concat
(file-name-as-directory (expand-file-name bcc-cache-directory))
(subst-char-in-string
?/ ?!
(file-name-sans-extension
(file-relative-name file-name "/")))
".elc"))
(defun bcc-in-blacklist (string blist)
"Return non-NIL iff STRING matches a regexp in BLIST.
Does not save match data."
(cond
((null blist) nil)
((string-match (car blist) string))
(t (bcc-in-blacklist string (cdr blist)))))
(defun bcc-byte-compile-to (input output)
"Like byte-compile-file, but puts the result in OUTPUT. Returns
the result of BYTE-COMPILE-FILE."
(require 'bytecomp)
(let ((saved-dest-func (symbol-function #'byte-compile-dest-file)))
(unwind-protect
(progn
(fset #'byte-compile-dest-file
#'(lambda (src)
(if (equal src input)
output
(funcall saved-dest-func src))))
(byte-compile-file input))
(fset #'byte-compile-dest-file saved-dest-func))))
(defun bcc-make-fake-cache-entry (cachename origname)
"Creates a compiled lisp file called CACHENAME that simply
loads ORIGNAME."
(let ((byte-compile-verbose nil)
(font-lock-verbose nil)
(byte-compile-warnings '())
(temp-file
(make-temp-file (expand-file-name
"fake-cache-"
(or small-temporary-file-directory
temporary-file-directory))
nil
".el")))
(unwind-protect
(progn
(with-temp-file temp-file
(prin1 `(setq bcc-loaded-fake-cache-entry t)
(current-buffer)))
(bcc-byte-compile-to temp-file cachename)
(bcc-assert (file-readable-p cachename)))
(delete-file temp-file))))
(defun bcc-regenerate-cache (input cachename nomessage)
"Regenerate the byte-code cache for INPUT,
putting the result in OUTPUT. If INPUT cannot be compiled,
generate a fake cache entry instead. NOMESSAGE means the same
thing it does for LOAD."
(unless nomessage
(message "Regenerating cache for %s" fullname))
(let ((byte-compile-verbose nil)
(font-lock-verbose nil)
(byte-compile-warnings '())
(kill-buffer-query-functions '())
(emacs-lisp-mode-hook '())
(bcc-regenerate-toplevel nil))
(let ((buf (find-buffer-visiting cachename)))
(when buf
(bcc-unconditionally-kill-buffer buf)))
(bcc-delete-file-noerror cachename)
(bcc-byte-compile-to input cachename)
(unless (file-readable-p cachename)
(unless nomessage
(message "Making fake cache entry for %S" cachename))
(bcc-make-fake-cache-entry cachename input)))
(unless nomessage
(message "Regenerating cache for %s...done" fullname)))
(defun bcc-load-cached-file (cachename origname noerror nomessage)
"Load compiled file CACHENAME, but pretend we're loading
ORIGNAME. NOERROR and NOMESSAGE mean what they do for LOAD."
(if (null (file-readable-p cachename))
(and (null noerror)
(signal 'file-error (list "Cannot open load file" cachename)))
(let* ((default-major-mode 'fundamental-mode)
(default-enable-multibyte-characters nil)
(buffer (get-buffer-create (generate-new-buffer-name " *load*")))
(load-in-progress t)
(byte-compile-warnings
(if (boundp 'byte-compile-warnings) byte-compile-warnings nil))
(byte-compile-verbose
(if (boundp 'byte-compile-verbose) byte-compile-verbose nil)))
(unless nomessage
(message "Loading %S as %S..." cachename origname))
(unwind-protect
(let ((load-file-name origname)
(inhibit-file-name-operation nil))
(with-current-buffer buffer
(let ((coding-system-for-read 'no-conversion)
deactivate-mark
buffer-undo-list)
(insert-file-contents cachename)
(set-buffer-multibyte nil)))
(setq bcc-loaded (cons (cons origname cachename) bcc-loaded))
(eval-buffer buffer nil origname nil t))
(bcc-unconditionally-kill-buffer buffer))
(do-after-load-evaluation origname)
(unless nomessage
(message "Loading %S as %S...done" cachename origname))
t)))
(defun bcc-load-source-file (fullname file noerror nomessage)
"Load the given file. If it's a plain elisp file, compile it
and stuff the compiled file in the cache directory. Then load
it."
(let (cachename
hist-ent loaded-from-bcc-cache
bcc-loaded-fake-cache-entry)
(when (and bcc-enabled
(not (save-match-data
(bcc-in-blacklist fullname bcc-blacklist))))
(setq cachename (file-truename (bcc-cache-file-name fullname)))
(make-directory (file-name-directory cachename) t)
(when (and bcc-regenerate-toplevel
(file-newer-than-file-p fullname cachename))
(bcc-regenerate-cache fullname cachename nomessage))
(when (file-readable-p cachename)
(bcc-load-cached-file cachename fullname noerror nomessage)
(unless bcc-loaded-fake-cache-entry
(setq loaded-from-bcc-cache t))))
(unless loaded-from-bcc-cache
(funcall bcc-old-load-source-file-function
fullname file noerror nomessage))))
(defadvice documentation-property (before bcc-documentation-property-fix activate)
"Work around Emacs bug"
(let ((docobj (get (ad-get-arg 0) (ad-get-arg 1)))
loadinfo)
(when (and (numberp (cdr-safe docobj))
(setq loadinfo (assoc (car docobj) bcc-loaded)))
(setcar docobj (cdr loadinfo)))))
(defadvice documentation (before bcc-documentation-fix activate preactivate)
"Work around Emacs bug"
(let* ((fun (ad-get-arg 0))
docobj loadinfo funcar prop)
(if (and (symbolp fun)
(setq prop (get fun 'function-documentation)))
(documentation-property fun 'function-documentation (ad-get-arg 1))
(setq fun (indirect-function fun t))
(setq funcar (car-safe fun))
(when (eq funcar 'macro)
(setq fun (indirect-function (cdr fun)))
(setq funcar (car-safe fun)))
(cond ((memq funcar '(lambda autoload))
(setq docobj (car (cdr (cdr fun)))))
((and (byte-code-function-p fun)
(> (length fun) bcc-compiled-doc-string))
(setq docobj (aref fun bcc-compiled-doc-string))))
(when (and (consp docobj)
(setq loadinfo (assoc (car docobj) bcc-loaded)))
(setcar docobj (cdr loadinfo))))))
(setq load-source-file-function #'bcc-load-source-file)
(provide 'byte-code-cache)