source code position. The most accessible element is the current
most deeply nested form.")
-(defun byte-compile-strip-s-p-1 (arg)
- "Strip all positions from symbols in ARG, destructively modifying ARG.
-Return the modified ARG."
- (cond
- ((symbolp arg)
- (bare-symbol arg))
- ((consp arg)
- (let ((a arg))
- (while (consp (cdr a))
- (setcar a (byte-compile-strip-s-p-1 (car a)))
- (setq a (cdr a)))
- (setcar a (byte-compile-strip-s-p-1 (car a)))
- ;; (if (cdr a)
- (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
- (setcdr a (byte-compile-strip-s-p-1 (cdr a)))))
- arg)
- ((vectorp arg)
- (let ((i 0)
- (len (length arg)))
- (while (< i len)
- (aset arg i (byte-compile-strip-s-p-1 (aref arg i)))
- (setq i (1+ i))))
- arg)
- (t arg)))
-
-(defun byte-compile-strip-symbol-positions (arg)
- "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
- (let ((arg1 (copy-tree arg t)))
- (byte-compile-strip-s-p-1 arg1)))
-
(defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM."
byte-compile-new-defuns))
(setf result
(byte-compile-eval
- (byte-compile-top-level
- (byte-compile-preprocess form)))))))
+ (macroexp-strip-symbol-positions
+ (byte-compile-top-level
+ (byte-compile-preprocess form))))))))
(list 'quote result))))
(eval-and-compile . ,(lambda (&rest body)
(byte-compile-recurse-toplevel
;; or byte-compile-file-form.
(let* ((print-symbols-bare t)
(expanded
- (macroexpand-all
- form
- macroexpand-all-environment)))
- (eval expanded lexical-binding)
+ (macroexpand-all
+ form
+ macroexpand-all-environment)))
+ (eval
+ (macroexp-strip-symbol-positions
+ expanded)
+ lexical-binding)
expanded)))))
(with-suppressed-warnings
. ,(lambda (warnings &rest body)
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message."
- (setq args (mapcar #'byte-compile-strip-symbol-positions args))
+ (setq args (mapcar #'macroexp-strip-symbol-positions args))
(setq format (apply #'format-message format args))
(if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it
;; Force logging of the file name for each file compiled.
(setq byte-compile-last-logged-file nil)
- (let ((byte-compile-current-file filename)
- (byte-compile-current-group nil)
- (set-auto-coding-for-load t)
- (byte-compile--seen-defvars nil)
- (byte-compile--known-dynamic-vars
- (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
- target-file input-buffer output-buffer
- byte-compile-dest-file byte-compiler-error-flag)
- (setq target-file (byte-compile-dest-file filename))
- (setq byte-compile-dest-file target-file)
- (with-current-buffer
- ;; It would be cleaner to use a temp buffer, but if there was
- ;; an error, we leave this buffer around for diagnostics.
- ;; Its name is documented in the lispref.
- (setq input-buffer (get-buffer-create
- (concat " *Compiler Input*"
- (if (zerop byte-compile-level) ""
- (format "-%s" byte-compile-level)))))
- (erase-buffer)
- (setq buffer-file-coding-system nil)
- ;; Always compile an Emacs Lisp file as multibyte
- ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
- (set-buffer-multibyte t)
- (insert-file-contents filename)
- ;; Mimic the way after-insert-file-set-coding can make the
- ;; buffer unibyte when visiting this file.
- (when (or (eq last-coding-system-used 'no-conversion)
- (eq (coding-system-type last-coding-system-used) 5))
- ;; For coding systems no-conversion and raw-text...,
- ;; edit the buffer as unibyte.
- (set-buffer-multibyte nil))
- ;; Run hooks including the uncompression hook.
- ;; If they change the file name, then change it for the output also.
- (let ((buffer-file-name filename)
- (dmm (default-value 'major-mode))
- ;; Ignore unsafe local variables.
- ;; We only care about a few of them for our purposes.
- (enable-local-variables :safe)
- (enable-local-eval nil))
- (unwind-protect
- (progn
- (setq-default major-mode 'emacs-lisp-mode)
- ;; Arg of t means don't alter enable-local-variables.
- (delay-mode-hooks (normal-mode t)))
- (setq-default major-mode dmm))
- ;; There may be a file local variable setting (bug#10419).
- (setq buffer-read-only nil
- filename buffer-file-name))
- ;; Don't inherit lexical-binding from caller (bug#12938).
- (unless (local-variable-p 'lexical-binding)
- (setq-local lexical-binding nil))
- ;; Set the default directory, in case an eval-when-compile uses it.
- (setq default-directory (file-name-directory filename)))
- ;; Check if the file's local variables explicitly specify not to
- ;; compile this file.
- (if (with-current-buffer input-buffer no-byte-compile)
- (progn
- ;; (message "%s not compiled because of `no-byte-compile: %s'"
- ;; (byte-compile-abbreviate-file filename)
- ;; (with-current-buffer input-buffer no-byte-compile))
- (when (and target-file (file-exists-p target-file))
- (message "%s deleted because of `no-byte-compile: %s'"
- (byte-compile-abbreviate-file target-file)
- (buffer-local-value 'no-byte-compile input-buffer))
- (condition-case nil (delete-file target-file) (error nil)))
- ;; We successfully didn't compile this file.
- 'no-byte-compile)
- (when byte-compile-verbose
- (message "Compiling %s..." filename))
- ;; It is important that input-buffer not be current at this call,
- ;; so that the value of point set in input-buffer
- ;; within byte-compile-from-buffer lingers in that buffer.
- (setq output-buffer
- (save-current-buffer
- (let ((symbols-with-pos-enabled t)
- (byte-compile-level (1+ byte-compile-level)))
- (byte-compile-from-buffer input-buffer))))
- (if byte-compiler-error-flag
- nil
- (when byte-compile-verbose
- (message "Compiling %s...done" filename))
- (kill-buffer input-buffer)
- (with-current-buffer output-buffer
- (when (and target-file
- (or (not byte-native-compiling)
- (and byte-native-compiling byte+native-compile)))
- (goto-char (point-max))
- (insert "\n") ; aaah, unix.
- (cond
- ((and (file-writable-p target-file)
- ;; We attempt to create a temporary file in the
- ;; target directory, so the target directory must be
- ;; writable.
- (file-writable-p
- (file-name-directory
- ;; Need to expand in case TARGET-FILE doesn't
- ;; include a directory (Bug#45287).
- (expand-file-name target-file))))
- ;; We must disable any code conversion here.
- (let* ((coding-system-for-write 'no-conversion)
- ;; Write to a tempfile so that if another Emacs
- ;; process is trying to load target-file (eg in a
- ;; parallel bootstrap), it does not risk getting a
- ;; half-finished file. (Bug#4196)
- (tempfile
- (make-temp-file (when (file-writable-p target-file)
- (expand-file-name target-file))))
- (default-modes (default-file-modes))
- (temp-modes (logand default-modes #o600))
- (desired-modes (logand default-modes #o666))
- (kill-emacs-hook
- (cons (lambda () (ignore-errors
- (delete-file tempfile)))
- kill-emacs-hook)))
- (unless (= temp-modes desired-modes)
- (set-file-modes tempfile desired-modes 'nofollow))
- (write-region (point-min) (point-max) tempfile nil 1)
- ;; This has the intentional side effect that any
- ;; hard-links to target-file continue to
- ;; point to the old file (this makes it possible
- ;; for installed files to share disk space with
- ;; the build tree, without causing problems when
- ;; emacs-lisp files in the build tree are
- ;; recompiled). Previously this was accomplished by
- ;; deleting target-file before writing it.
- (if byte-native-compiling
- ;; Defer elc final renaming.
- (setf byte-to-native-output-file
- (cons tempfile target-file))
- (rename-file tempfile target-file t)))
- (or noninteractive
- byte-native-compiling
- (message "Wrote %s" target-file)))
- ((file-writable-p target-file)
- ;; In case the target directory isn't writable (see e.g. Bug#44631),
- ;; try writing to the output file directly. We must disable any
- ;; code conversion here.
- (let ((coding-system-for-write 'no-conversion))
- (with-file-modes (logand (default-file-modes) #o666)
- (write-region (point-min) (point-max) target-file nil 1)))
- (or noninteractive (message "Wrote %s" target-file)))
- (t
- ;; This is just to give a better error message than write-region
- (let ((exists (file-exists-p target-file)))
- (signal (if exists 'file-error 'file-missing)
- (list "Opening output file"
- (if exists
- "Cannot overwrite file"
- "Directory not writable or nonexistent")
- target-file))))))
- (kill-buffer (current-buffer)))
- (if (and byte-compile-generate-call-tree
- (or (eq t byte-compile-generate-call-tree)
- (y-or-n-p (format "Report call tree for %s? "
- filename))))
- (save-excursion
- (display-call-tree filename)))
- (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
- (when (and gen-dynvars (not (equal gen-dynvars ""))
- byte-compile--seen-defvars)
- (let ((dynvar-file (concat target-file ".dynvars")))
- (message "Generating %s" dynvar-file)
- (with-temp-buffer
- (dolist (var (delete-dups byte-compile--seen-defvars))
- (insert (format "%S\n" (cons var filename))))
- (write-region (point-min) (point-max) dynvar-file)))))
- (if load
- (load target-file))
- t))))
+ (prog1
+ (let ((byte-compile-current-file filename)
+ (byte-compile-current-group nil)
+ (set-auto-coding-for-load t)
+ (byte-compile--seen-defvars nil)
+ (byte-compile--known-dynamic-vars
+ (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
+ target-file input-buffer output-buffer
+ byte-compile-dest-file byte-compiler-error-flag)
+ (setq target-file (byte-compile-dest-file filename))
+ (setq byte-compile-dest-file target-file)
+ (with-current-buffer
+ ;; It would be cleaner to use a temp buffer, but if there was
+ ;; an error, we leave this buffer around for diagnostics.
+ ;; Its name is documented in the lispref.
+ (setq input-buffer (get-buffer-create
+ (concat " *Compiler Input*"
+ (if (zerop byte-compile-level) ""
+ (format "-%s" byte-compile-level)))))
+ (erase-buffer)
+ (setq buffer-file-coding-system nil)
+ ;; Always compile an Emacs Lisp file as multibyte
+ ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
+ (set-buffer-multibyte t)
+ (insert-file-contents filename)
+ ;; Mimic the way after-insert-file-set-coding can make the
+ ;; buffer unibyte when visiting this file.
+ (when (or (eq last-coding-system-used 'no-conversion)
+ (eq (coding-system-type last-coding-system-used) 5))
+ ;; For coding systems no-conversion and raw-text...,
+ ;; edit the buffer as unibyte.
+ (set-buffer-multibyte nil))
+ ;; Run hooks including the uncompression hook.
+ ;; If they change the file name, then change it for the output also.
+ (let ((buffer-file-name filename)
+ (dmm (default-value 'major-mode))
+ ;; Ignore unsafe local variables.
+ ;; We only care about a few of them for our purposes.
+ (enable-local-variables :safe)
+ (enable-local-eval nil))
+ (unwind-protect
+ (progn
+ (setq-default major-mode 'emacs-lisp-mode)
+ ;; Arg of t means don't alter enable-local-variables.
+ (delay-mode-hooks (normal-mode t)))
+ (setq-default major-mode dmm))
+ ;; There may be a file local variable setting (bug#10419).
+ (setq buffer-read-only nil
+ filename buffer-file-name))
+ ;; Don't inherit lexical-binding from caller (bug#12938).
+ (unless (local-variable-p 'lexical-binding)
+ (setq-local lexical-binding nil))
+ ;; Set the default directory, in case an eval-when-compile uses it.
+ (setq default-directory (file-name-directory filename)))
+ ;; Check if the file's local variables explicitly specify not to
+ ;; compile this file.
+ (if (with-current-buffer input-buffer no-byte-compile)
+ (progn
+ ;; (message "%s not compiled because of `no-byte-compile: %s'"
+ ;; (byte-compile-abbreviate-file filename)
+ ;; (with-current-buffer input-buffer no-byte-compile))
+ (when (and target-file (file-exists-p target-file))
+ (message "%s deleted because of `no-byte-compile: %s'"
+ (byte-compile-abbreviate-file target-file)
+ (buffer-local-value 'no-byte-compile input-buffer))
+ (condition-case nil (delete-file target-file) (error nil)))
+ ;; We successfully didn't compile this file.
+ 'no-byte-compile)
+ (when byte-compile-verbose
+ (message "Compiling %s..." filename))
+ ;; It is important that input-buffer not be current at this call,
+ ;; so that the value of point set in input-buffer
+ ;; within byte-compile-from-buffer lingers in that buffer.
+ (setq output-buffer
+ (save-current-buffer
+ (let ((symbols-with-pos-enabled t)
+ (byte-compile-level (1+ byte-compile-level)))
+ (byte-compile-from-buffer input-buffer))))
+ (if byte-compiler-error-flag
+ nil
+ (when byte-compile-verbose
+ (message "Compiling %s...done" filename))
+ (kill-buffer input-buffer)
+ (with-current-buffer output-buffer
+ (when (and target-file
+ (or (not byte-native-compiling)
+ (and byte-native-compiling byte+native-compile)))
+ (goto-char (point-max))
+ (insert "\n") ; aaah, unix.
+ (cond
+ ((and (file-writable-p target-file)
+ ;; We attempt to create a temporary file in the
+ ;; target directory, so the target directory must be
+ ;; writable.
+ (file-writable-p
+ (file-name-directory
+ ;; Need to expand in case TARGET-FILE doesn't
+ ;; include a directory (Bug#45287).
+ (expand-file-name target-file))))
+ ;; We must disable any code conversion here.
+ (let* ((coding-system-for-write 'no-conversion)
+ ;; Write to a tempfile so that if another Emacs
+ ;; process is trying to load target-file (eg in a
+ ;; parallel bootstrap), it does not risk getting a
+ ;; half-finished file. (Bug#4196)
+ (tempfile
+ (make-temp-file (when (file-writable-p target-file)
+ (expand-file-name target-file))))
+ (default-modes (default-file-modes))
+ (temp-modes (logand default-modes #o600))
+ (desired-modes (logand default-modes #o666))
+ (kill-emacs-hook
+ (cons (lambda () (ignore-errors
+ (delete-file tempfile)))
+ kill-emacs-hook)))
+ (unless (= temp-modes desired-modes)
+ (set-file-modes tempfile desired-modes 'nofollow))
+ (write-region (point-min) (point-max) tempfile nil 1)
+ ;; This has the intentional side effect that any
+ ;; hard-links to target-file continue to
+ ;; point to the old file (this makes it possible
+ ;; for installed files to share disk space with
+ ;; the build tree, without causing problems when
+ ;; emacs-lisp files in the build tree are
+ ;; recompiled). Previously this was accomplished by
+ ;; deleting target-file before writing it.
+ (if byte-native-compiling
+ ;; Defer elc final renaming.
+ (setf byte-to-native-output-file
+ (cons tempfile target-file))
+ (rename-file tempfile target-file t)))
+ (or noninteractive
+ byte-native-compiling
+ (message "Wrote %s" target-file)))
+ ((file-writable-p target-file)
+ ;; In case the target directory isn't writable (see e.g. Bug#44631),
+ ;; try writing to the output file directly. We must disable any
+ ;; code conversion here.
+ (let ((coding-system-for-write 'no-conversion))
+ (with-file-modes (logand (default-file-modes) #o666)
+ (write-region (point-min) (point-max) target-file nil 1)))
+ (or noninteractive (message "Wrote %s" target-file)))
+ (t
+ ;; This is just to give a better error message than write-region
+ (let ((exists (file-exists-p target-file)))
+ (signal (if exists 'file-error 'file-missing)
+ (list "Opening output file"
+ (if exists
+ "Cannot overwrite file"
+ "Directory not writable or nonexistent")
+ target-file))))))
+ (kill-buffer (current-buffer)))
+ (if (and byte-compile-generate-call-tree
+ (or (eq t byte-compile-generate-call-tree)
+ (y-or-n-p (format "Report call tree for %s? "
+ filename))))
+ (save-excursion
+ (display-call-tree filename)))
+ (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
+ (when (and gen-dynvars (not (equal gen-dynvars ""))
+ byte-compile--seen-defvars)
+ (let ((dynvar-file (concat target-file ".dynvars")))
+ (message "Generating %s" dynvar-file)
+ (with-temp-buffer
+ (dolist (var (delete-dups byte-compile--seen-defvars))
+ (insert (format "%S\n" (cons var filename))))
+ (write-region (point-min) (point-max) dynvar-file)))))
+ (if load
+ (load target-file))
+ t)))
+ ;; Strip positions from symbols for the native compiler.
+ (setq byte-to-native-top-level-forms
+ (macroexp-strip-symbol-positions byte-to-native-top-level-forms))))
;;; compiling a single function
;;;###autoload
;; it here.
(when byte-native-compiling
;; Spill output for the native compiler here
- (push (make-byte-to-native-top-level :form form :lexical lexical-binding)
- byte-to-native-top-level-forms))
+ (push
+ (macroexp-strip-symbol-positions
+ (make-byte-to-native-top-level :form form :lexical lexical-binding))
+ byte-to-native-top-level-forms))
(let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
;; byte-compile-noruntime-functions, in case we have an autoload
;; of foo-func following an (eval-when-compile (require 'foo)).
(unless (fboundp funsym)
- (push (byte-compile-strip-symbol-positions
+ (push (macroexp-strip-symbol-positions
(cons funsym (cons 'autoload (cdr (cdr form)))))
byte-compile-function-environment))
;; If an autoload occurs _before_ the first call to a function,
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- (prog1 (byte-compile-strip-symbol-positions form)
+ (prog1 (macroexp-strip-symbol-positions form)
(byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
((symbolp (nth 2 form))
(setcar (cddr form) (bare-symbol (nth 2 form))))
(t (setcar (cddr form)
- (byte-compile-strip-symbol-positions (nth 2 form)))))
+ (macroexp-strip-symbol-positions (nth 2 form)))))
(setcar form (bare-symbol (car form)))
(if (symbolp (nth 1 form))
(setcar (cdr form) (bare-symbol (nth 1 form))))
(prog1 (byte-compile-keep-pending form)
(apply 'make-obsolete
(mapcar 'eval
- (byte-compile-strip-symbol-positions (cdr form))))))
+ (macroexp-strip-symbol-positions (cdr form))))))
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
(if (not (stringp (documentation code t))) -1 4)))
(when byte-native-compiling
;; Spill output for the native compiler here.
- (push (if macro
- (make-byte-to-native-top-level
- :form `(defalias ',name '(macro . ,code) nil)
- :lexical lexical-binding)
- (make-byte-to-native-func-def :name name
- :byte-func code))
- byte-to-native-top-level-forms))
+ (push
+ (macroexp-strip-symbol-positions
+ (if macro
+ (make-byte-to-native-top-level
+ :form `(defalias ',name '(macro . ,code) nil)
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code)))
+ byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
(macro (eq (car-safe fun) 'macro)))
(if macro
(setq fun (cdr fun)))
- (cond
- ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
- ;; compile something invalid. So let's tune down the complaint from an
- ;; error to a simple message for the known case where signaling an error
- ;; causes problems.
- ((byte-code-function-p fun)
- (message "Function %s is already compiled"
- (if (symbolp form) form "provided"))
- fun)
- (t
- (let (final-eval)
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun))
- (setq final-eval t))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent to the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if final-eval
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun)))))))
+ (prog1
+ (cond
+ ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
+ ;; compile something invalid. So let's tune down the complaint from an
+ ;; error to a simple message for the known case where signaling an error
+ ;; causes problems.
+ ((byte-code-function-p fun)
+ (message "Function %s is already compiled"
+ (if (symbolp form) form "provided"))
+ fun)
+ (t
+ (let (final-eval)
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; `fun' is a function *value*, so try to recover its corresponding
+ ;; source code.
+ (setq lexical-binding (eq (car fun) 'closure))
+ (setq fun (byte-compile--reify-function fun))
+ (setq final-eval t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (if (symbolp form)
+ ;; byte-compile-top-level returns an *expression* equivalent to the
+ ;; `fun' expression, so we need to evaluate it, tho normally
+ ;; this is not needed because the expression is just a constant
+ ;; byte-code object, which is self-evaluating.
+ (setq fun (eval fun t)))
+ (if final-eval
+ (setq fun (eval fun t)))
+ (if macro (push 'macro fun))
+ (if (symbolp form) (fset form fun))
+ fun)))
+ (setq byte-to-native-top-level-forms
+ (macroexp-strip-symbol-positions byte-to-native-top-level-forms)))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
;; which may include "calls" to
;; internal-make-closure (Bug#29988).
lexical-binding)
- (setq int (byte-compile-strip-symbol-positions `(interactive ,newform)))
- (setq int (byte-compile-strip-symbol-positions int)))))
+ (setq int (macroexp-strip-symbol-positions `(interactive ,newform)))
+ (setq int (macroexp-strip-symbol-positions int)))))
((cdr int) ; Invalid (interactive . something).
(byte-compile-warn-x int "malformed interactive spec: %s"
int))))
(byte-compile-make-lambda-lexenv
arglistvars))
reserved-csts))
- (bare-arglist (byte-compile-strip-symbol-positions arglist)))
+ (bare-arglist (macroexp-strip-symbol-positions arglist)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
;; We have some command modes, so use the vector form.
(command-modes
(list (vector (nth 1 int)
- (byte-compile-strip-symbol-positions
+ (macroexp-strip-symbol-positions
command-modes))))
;; No command modes, use the simple form with just the
;; interactive spec.
(byte-compile-out
'byte-constant
(byte-compile-get-constant
- (byte-compile-strip-symbol-positions const))))
+ (macroexp-strip-symbol-positions const))))
\f
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
(dolist (case cases)
(setq tag (byte-compile-make-tag)
- test-objects (byte-compile-strip-symbol-positions (car case))
+ test-objects (macroexp-strip-symbol-positions (car case))
body (cdr case))
(byte-compile-out-tag tag)
(dolist (value test-objects)
(when (null form)
(byte-compile-warn-x form "Uneven number of key bindings in %S" form))
(push (pop form) result))
- (byte-compile-strip-symbol-positions orig-form)))
+ (macroexp-strip-symbol-positions orig-form)))
(put 'define-keymap--define 'byte-hunk-handler
#'byte-compile-define-keymap--define)
;;; call tree stuff
(defun byte-compile-annotate-call-tree (form)
- (let ((current-form (byte-compile-strip-symbol-positions
+ (let ((current-form (macroexp-strip-symbol-positions
byte-compile-current-form))
- (bare-car-form (byte-compile-strip-symbol-positions (car form)))
+ (bare-car-form (macroexp-strip-symbol-positions (car form)))
entry)
;; annotate the current call
(if (setq entry (assq bare-car-form byte-compile-call-tree))
(or (not (file-exists-p dest))
(file-newer-than-file-p source dest))))
(if (null (batch-byte-compile-file (car command-line-args-left)))
- (setq error t))))
+ (setq error t))))
(setq command-line-args-left (cdr command-line-args-left)))
+ (setq byte-to-native-top-level-forms
+ (macroexp-strip-symbol-positions byte-to-native-top-level-forms))
(kill-emacs (if error 1 0))))
(defun batch-byte-compile-file (file)
/* C symbols emitted for the load relocation mechanism. */
#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
+#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc"
#define PURE_RELOC_SYM "pure_reloc"
#define DATA_RELOC_SYM "d_reloc"
#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
gcc_jit_type *emacs_int_type;
gcc_jit_type *emacs_uint_type;
gcc_jit_type *void_ptr_type;
+ gcc_jit_type *bool_ptr_type;
gcc_jit_type *char_ptr_type;
gcc_jit_type *ptrdiff_type;
gcc_jit_type *uintptr_type;
gcc_jit_field *lisp_cons_u_s_u_cdr;
gcc_jit_type *lisp_cons_type;
gcc_jit_type *lisp_cons_ptr_type;
+ /* struct Lisp_Symbol_With_Position */
+ gcc_jit_rvalue *f_symbols_with_pos_enabled_ref;
+ gcc_jit_struct *lisp_symbol_with_position;
+ gcc_jit_field *lisp_symbol_with_position_header;
+ gcc_jit_field *lisp_symbol_with_position_sym;
+ gcc_jit_field *lisp_symbol_with_position_pos;
+ gcc_jit_type *lisp_symbol_with_position_type;
+ gcc_jit_type *lisp_symbol_with_position_ptr_type;
+ gcc_jit_function *get_symbol_with_position;
/* struct jmp_buf. */
gcc_jit_struct *jmp_buf_s;
/* struct handler. */
Lisp_Object helper_unbind_n (Lisp_Object n);
void helper_save_restriction (void);
bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
+struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a);
+/* Note: helper_link_table must match the list created by
+ `declare_runtime_imported_funcs'. */
void *helper_link_table[] =
{ wrong_type_argument,
helper_PSEUDOVECTOR_TYPEP_XUNTAG,
record_unwind_protect_excursion,
helper_unbind_n,
helper_save_restriction,
+ helper_GET_SYMBOL_WITH_POSITION,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
}
static gcc_jit_rvalue *
-emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
- emit_comment ("EQ");
+ emit_comment ("BASE_EQ");
return gcc_jit_context_new_comparison (
comp.ctxt,
emit_XLI (y));
}
+static gcc_jit_rvalue *
+emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return gcc_jit_context_new_binary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_BINARY_OP_LOGICAL_AND,
+ comp.bool_type,
+ x,
+ y);
+}
+
+static gcc_jit_rvalue *
+emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return gcc_jit_context_new_binary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ x,
+ y);
+}
+
static gcc_jit_rvalue *
emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
{
return emit_TAGGEDP (obj, Lisp_Cons);
}
+static gcc_jit_rvalue *
+emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj)
+{
+ emit_comment ("BARE_SYMBOL_P");
+
+ return gcc_jit_context_new_cast (comp.ctxt,
+ NULL,
+ emit_TAGGEDP (obj, Lisp_Symbol),
+ comp.bool_type);
+}
+
+static gcc_jit_rvalue *
+emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj)
+{
+ emit_comment ("SYMBOL_WITH_POS_P");
+
+ gcc_jit_rvalue *args[] =
+ { obj,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ PVEC_SYMBOL_WITH_POS)
+ };
+
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.pseudovectorp,
+ 2,
+ args);
+}
+
+static gcc_jit_rvalue *
+emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
+{
+ emit_comment ("SYMBOL_WITH_POS_SYM");
+
+ gcc_jit_rvalue *tmp2, *swp;
+ gcc_jit_lvalue *tmpl;
+
+ gcc_jit_rvalue *args[] = { obj };
+ swp = gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.get_symbol_with_position,
+ 1,
+ args);
+ tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0));
+ tmp2 = gcc_jit_lvalue_as_rvalue (tmpl);
+ return
+ gcc_jit_rvalue_access_field (tmp2,
+ NULL,
+ comp.lisp_symbol_with_position_sym);
+}
+
+static gcc_jit_rvalue *
+emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return
+ emit_OR (
+ gcc_jit_context_new_comparison (
+ comp.ctxt, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0),
+ GCC_JIT_COMPARISON_EQ,
+ emit_XLI (x), emit_XLI (y)),
+ emit_AND (
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref,
+ gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0))),
+ emit_OR (
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (x),
+ emit_OR (
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (y),
+ emit_BASE_EQ (
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))),
+ emit_AND (
+ emit_BARE_SYMBOL_P (y),
+ emit_BASE_EQ (
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
+ emit_XLI (y))))),
+ emit_AND (
+ emit_BARE_SYMBOL_P (x),
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (y),
+ emit_BASE_EQ (
+ emit_XLI (x),
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (y))))))));
+}
+
static gcc_jit_rvalue *
emit_FLOATP (gcc_jit_rvalue *obj)
{
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
- return emit_EQ (x, emit_lisp_obj_rval (Qnil));
+ return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil));
}
static gcc_jit_rvalue *
gcc_jit_block *target1 = retrive_block (arg[2]);
gcc_jit_block *target2 = retrive_block (arg[3]);
- emit_cond_jump (emit_EQ (a, b), target1, target2);
+ if ((CALL1I (comp-cstr-imm-vld-p, arg[0])
+ && NILP (CALL1I (comp-cstr-imm, arg[0])))
+ || (CALL1I (comp-cstr-imm-vld-p, arg[1])
+ && NILP (CALL1I (comp-cstr-imm, arg[1]))))
+ emit_cond_jump (emit_BASE_EQ (a, b), target1, target2);
+ else
+ emit_cond_jump (emit_EQ (a, b), target1, target2);
}
else if (EQ (op, Qcond_jump_narg_leq))
{
/*
Declare as imported all the functions that are requested from the runtime.
- These are either subrs or not.
+ These are either subrs or not. Note that the list created here must match
+ the array `helper_link_table'.
*/
static Lisp_Object
declare_runtime_imported_funcs (void)
ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
+ args[0] = comp.lisp_obj_type;
+ ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type,
+ 1, args);
+
ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
args[0] = args[1] = args[2] = comp.lisp_obj_type;
gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
CURRENT_THREAD_RELOC_SYM));
+ comp.f_symbols_with_pos_enabled_ref =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ comp.bool_ptr_type,
+ F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
+
comp.pure_ptr =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
}
+static void
+define_lisp_symbol_with_position (void)
+{
+ comp.lisp_symbol_with_position_header =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.ptrdiff_type,
+ "header");
+ comp.lisp_symbol_with_position_sym =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "sym");
+ comp.lisp_symbol_with_position_pos =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "pos");
+ gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header,
+ comp.lisp_symbol_with_position_sym,
+ comp.lisp_symbol_with_position_pos};
+ comp.lisp_symbol_with_position =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "comp_lisp_symbol_with_position",
+ 3,
+ fields);
+ comp.lisp_symbol_with_position_type =
+ gcc_jit_struct_as_type (comp.lisp_symbol_with_position);
+ comp.lisp_symbol_with_position_ptr_type =
+ gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type);
+}
+
/* Opaque jmp_buf definition. */
static void
comp.bool_type, 2, args, false));
}
+static void
+define_GET_SYMBOL_WITH_POSITION (void)
+{
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "a") };
+
+ comp.get_symbol_with_position =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_symbol_with_position_ptr_type,
+ "GET_SYMBOL_WITH_POSITION",
+ 1,
+ param,
+ 0);
+
+ DECL_BLOCK (entry_block, comp.get_symbol_with_position);
+
+ comp.block = entry_block;
+ comp.func = comp.get_symbol_with_position;
+
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_param_as_rvalue (param[0]) };
+ /* FIXME use XUNTAG now that's available. */
+ gcc_jit_block_end_with_return (
+ entry_block,
+ NULL,
+ emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"),
+ comp.lisp_symbol_with_position_ptr_type,
+ 1, args, false));
+}
+
static void
define_CHECK_IMPURE (void)
{
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
comp.unsigned_long_long_type =
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
+ comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type);
comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
sizeof (EMACS_INT),
/* Define data structures. */
define_lisp_cons ();
+ define_lisp_symbol_with_position ();
define_jmp_buf ();
define_handler_struct ();
define_thread_state_struct ();
/* Define inline functions. */
define_CAR_CDR ();
define_PSEUDOVECTORP ();
+ define_GET_SYMBOL_WITH_POSITION ();
define_CHECK_TYPE ();
define_CHECK_IMPURE ();
define_bool_to_lisp_obj ();
code);
}
+struct Lisp_Symbol_With_Pos *
+helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
+{
+ if (!SYMBOL_WITH_POS_P (a))
+ wrong_type_argument (Qwrong_type_argument, a);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
+}
+
\f
/* `native-comp-eln-load-path' clean-up support code. */
{
struct thread_state ***current_thread_reloc =
dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
+ bool **f_symbols_with_pos_enabled_reloc =
+ dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
if (!(current_thread_reloc
+ && f_symbols_with_pos_enabled_reloc
&& pure_reloc
&& data_relocs
&& data_imp_relocs
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
*current_thread_reloc = ¤t_thread;
+ *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
*pure_reloc = pure;
/* Imported functions. */
defsubr (&Snative_comp_available_p);
}
+/* Local Variables: */
+/* c-file-offsets: ((arglist-intro . +)) */
+/* End: */
projects / emacs.git / commitdiff