[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/correct-warning-pos 1cd188799f: Make symbols with positions work
|
From: |
Alan Mackenzie |
|
Subject: |
scratch/correct-warning-pos 1cd188799f: Make symbols with positions work with native compilation |
|
Date: |
Thu, 30 Dec 2021 05:17:15 -0500 (EST) |
branch: scratch/correct-warning-pos
commit 1cd188799f86bcb13ad76e82e3436b1b7e9f9e9f
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Make symbols with positions work with native compilation
This version of the software should bootstrap Emacs successfully with native
compilation enabled.
* lisp/emacs-lisp/bytecomp.el (byte-compile-strip-s-p-1)
(byte-compile-strip-symbol-positions): Rename and move to macroexp.el.
Rename
calls to these functions throughout the file.
(byte-compile-initial-macro-environment): In the code sections for
eval-when-compile and eval-and-compile, call macroexp-strip-symbol-positions
before evaluating code.
(byte-compile-file, byte-compile-output-file-form)
(byte-compile-file-form-defmumble, byte-compile, batch-byte-compile): Call
macroexp-strip-symbol-positions from code being passed to the native
compiler.
* lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1)
(cl-macs--strip-symbol-positions): Remove, replacing them with the renamed
functions in macroexp.el.
(cl-define-compiler-macro): Apply macroexp-strip-symbol-positions to ARGS
and
BODY.
* lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Use `null' to compile
byte-not rather than a compilation of `eq'.
(comp--native-compile): bind symbols-with-pos-enabled to t.
* lisp/emacs-lisp/macroexp.el (byte-compile--ssp-conses-seen)
(byte-compile--ssp-vectors-seen, byte-compile--ssp-records-seen):
Provisional
auxiliary variables to support the following functions.
(macroexp--strip-s-p-2, byte-compile-strip-s-p-1)
(macroexp-strip-symbol-positions): Functions moved from bytecomp.el,
renamed,
and further developed.
(macroexp--compiler-macro): Bind symbol-with-pos-enabled to t around the
call
to `handler'.
(internal-macroexpand-for-load): Strip symbol positions from the form being
eagerly expanded for macros.
* src/comp.c (F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM): New macro for a
relocation symbol.
(comp_t): New elements bool_ptr_type, f_symbols_with_pos_enabled_ref,
lisp_symbol_with_position, lisp_symbol_with_position_header,
lisp_symbol_with_position_sym, lisp_symbol_with_position_pos,
lisp_symbol_with_position_type, lisp_symbol_with_position_ptr_type,
get_symbol_with_position.
(helper_GET_SYMBOL_WITH_POSITION): New function.
(emit_BASE_EQ): Function rename from emit_EQ.
(emit_AND, emit_OR, emit_BARE_SYMBOL_P, emit_SYMBOL_WITH_POS_P)
(emit_SYMBOL_WITH_POS_SYM): New functions.
(emit_EQ): New function which handles symbols with position correctly.
(emit_NILP): Use emit_BASE_EQ rather than emit_EQ.
(emit_limple_insn): When emitting a conditional branch, check each operand
for
being a literal Qnil, and if one of them is, use emit_BASE_EQ rather than
emit_EQ.
(declare_runtime_imported_funcs): Declare helper_GET_SYMBOL_WITH_POSITION.
(emit_ctxt_code): Export the global F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM.
(define_lisp_symbol_with_position, define_GET_SYMBOL_WITH_POSITION): New
functions.
(Fcomp__init_ctxt): Initialise comp.bool_ptr_type, call the two new
define_.... functions.
(load_comp_unit): Initialise **f_symbols_with_pos_enabled_reloc.
* src/fns.c (Fput): Strip positions from symbols in PROPNAME and VALUE.
---
lisp/emacs-lisp/bytecomp.el | 507 +++++++++++++++++++++-----------------------
lisp/emacs-lisp/cl-macs.el | 35 +--
lisp/emacs-lisp/comp.el | 13 +-
lisp/emacs-lisp/macroexp.el | 66 +++++-
src/comp.c | 242 ++++++++++++++++++++-
src/fns.c | 5 +
6 files changed, 561 insertions(+), 307 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 2f23fe743e..47b5d6ceca 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -465,36 +465,6 @@ This is used by the warning message routines to determine a
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."
@@ -535,8 +505,9 @@ 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
@@ -547,10 +518,13 @@ Return the compile-time value of FORM."
;; 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)
@@ -1435,7 +1409,7 @@ function directly; use `byte-compile-warn' or
(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
@@ -2117,175 +2091,179 @@ See also `emacs-lisp-byte-compile-and-load'."
;; 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
@@ -2458,8 +2436,10 @@ Call from the source buffer."
;; 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)
@@ -2659,7 +2639,7 @@ list that represents a doc string reference.
;; 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,
@@ -2676,7 +2656,7 @@ list that represents a doc string reference.
(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)))
@@ -2717,7 +2697,7 @@ list that represents a doc string reference.
((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))))
@@ -2800,7 +2780,7 @@ list that represents a doc string reference.
(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.
@@ -2926,13 +2906,15 @@ not to take responsibility for the actual compilation
of the code."
(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
@@ -3020,37 +3002,40 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(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."
@@ -3197,8 +3182,8 @@ for symbols generated by the byte compiler itself."
;; 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))))
@@ -3213,7 +3198,7 @@ for symbols generated by the byte compiler itself."
(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
@@ -3237,7 +3222,7 @@ for symbols generated by the byte compiler itself."
;; 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.
@@ -3785,7 +3770,7 @@ assignment (i.e. `setq')."
(byte-compile-out
'byte-constant
(byte-compile-get-constant
- (byte-compile-strip-symbol-positions const))))
+ (macroexp-strip-symbol-positions const))))
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
@@ -4619,7 +4604,7 @@ Return (TAIL VAR TEST CASES), where:
(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)
@@ -5265,7 +5250,7 @@ binding slots have been popped."
(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)
@@ -5332,9 +5317,9 @@ OP and OPERAND are as passed to `byte-compile-out'."
;;; 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))
@@ -5552,8 +5537,10 @@ already up-to-date."
(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)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 3659a0c95a..fbcf0020e8 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -53,36 +53,6 @@
`(prog1 (car (cdr ,place))
(setq ,place (cdr (cdr ,place)))))
-(defun cl-macs--strip-s-p-1 (arg)
- "Strip all positions from symbols with position 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 (cl-macs--strip-s-p-1 (car a)))
- (setq a (cdr a)))
- (setcar a (cl-macs--strip-s-p-1 (car a)))
- ;; (if (cdr a)
- (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
- (setcdr a (cl-macs--strip-s-p-1 (cdr a)))))
- arg)
- ((vectorp arg)
- (let ((i 0)
- (len (length arg)))
- (while (< i len)
- (aset arg i (cl-macs--strip-s-p-1 (aref arg i)))
- (setq i (1+ i))))
- arg)
- (t arg)))
-
-(defun cl-macs--strip-symbol-positions (arg)
- "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
- (let ((arg1 (copy-tree arg t)))
- (cl-macs--strip-s-p-1 arg1)))
-
(defvar cl--optimize-safety)
(defvar cl--optimize-speed)
@@ -3534,8 +3504,9 @@ and then returning foo."
`(eval-and-compile
;; Name the compiler-macro function, so that `symbol-file' can find it.
(cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args)
- (cons '_cl-whole-arg args))
- ,@body)
+ (cons '_cl-whole-arg
+ (macroexp-strip-symbol-positions args)))
+ ,@(macroexp-strip-symbol-positions body))
(put ',func 'compiler-macro #',fname))))
;;;###autoload
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 0a10505257..8581fe8066 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1829,9 +1829,7 @@ and the annotation emission."
(byte-listp auto)
(byte-eq auto)
(byte-memq auto)
- (byte-not
- (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
- (make-comp-mvar :constant nil))))
+ (byte-not null)
(byte-car auto)
(byte-cdr auto)
(byte-cons auto)
@@ -4017,6 +4015,7 @@ the deferred compilation mechanism."
(let* ((data function-or-file)
(comp-native-compiling t)
(byte-native-qualities nil)
+ (symbols-with-pos-enabled t)
;; Have byte compiler signal an error when compilation fails.
(byte-compile-debug t)
(comp-ctxt (make-comp-ctxt :output output
@@ -4060,10 +4059,10 @@ the deferred compilation mechanism."
(signal (car err) (if (consp err-val)
(cons function-or-file err-val)
(list function-or-file err-val)))))))
- (if (stringp function-or-file)
- data
- ;; So we return the compiled function.
- (native-elisp-load data)))))
+ (if (stringp function-or-file)
+ data
+ ;; So we return the compiled function.
+ (native-elisp-load data)))))
(defun native-compile-async-skip-p (file load selector)
"Return non-nil if FILE's compilation should be skipped.
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 60fac98130..dafd549763 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -32,6 +32,64 @@
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
+(defvar byte-compile--ssp-conses-seen nil
+ "Which conses have been processed in a strip-symbol-positions operation?")
+(defvar byte-compile--ssp-vectors-seen nil
+ "Which vectors have been processed in a strip-symbol-positions operation?")
+(defvar byte-compile--ssp-records-seen nil
+ "Which records have been processed in a strip-symbol-positions operation?")
+
+(defun macroexp--strip-s-p-2 (arg)
+ "Strip all positions from symbols in ARG, destructively modifying ARG.
+Return the modified ARG."
+ (cond
+ ((symbolp arg)
+ (bare-symbol arg))
+ ((consp arg)
+ (unless (memq arg byte-compile--ssp-conses-seen)
+ ;; (push arg byte-compile--ssp-conses-seen)
+ (let ((a arg))
+ (while (consp (cdr a))
+ (setcar a (macroexp--strip-s-p-2 (car a)))
+ (setq a (cdr a)))
+ (setcar a (macroexp--strip-s-p-2 (car a)))
+ ;; (if (cdr a)
+ (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
+ (setcdr a (macroexp--strip-s-p-2 (cdr a))))))
+ arg)
+ ((vectorp arg)
+ (unless (memq arg byte-compile--ssp-vectors-seen)
+ (push arg byte-compile--ssp-vectors-seen)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (macroexp--strip-s-p-2 (aref arg i)))
+ (setq i (1+ i)))))
+ arg)
+ ((recordp arg)
+ (unless (memq arg byte-compile--ssp-records-seen)
+ (push arg byte-compile--ssp-records-seen)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (macroexp--strip-s-p-2 (aref arg i)))
+ (setq i (1+ i)))))
+ arg)
+ (t arg)))
+
+(defun byte-compile-strip-s-p-1 (arg)
+ "Strip all positions from symbols in ARG, destructively modifying ARG.
+Return the modified ARG."
+ (setq byte-compile--ssp-conses-seen nil)
+ (setq byte-compile--ssp-vectors-seen nil)
+ (setq byte-compile--ssp-records-seen nil)
+ (macroexp--strip-s-p-2 arg))
+
+(defun macroexp-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 macroexp--cons (car cdr original-cons)
"Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR,
respectively.
If not, return (CAR . CDR)."
@@ -96,10 +154,11 @@ each clause."
(defun macroexp--compiler-macro (handler form)
(condition-case-unless-debug err
- (apply handler form (cdr form))
+ (let ((symbols-with-pos-enabled t))
+ (apply handler form (cdr form)))
(error
- (message "Compiler-macro error for %S: %S" (car form) err)
- form)))
+ (message "Compiler-macro error for %S: Handler: %S\n%S" (car form)
handler err)
+ form)))
(defun macroexp--funcall-if-compiled (_form)
"Pseudo function used internally by macroexp to delay warnings.
@@ -683,6 +742,7 @@ test of free variables in the following ways:
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
+ (setq form (macroexp-strip-symbol-positions form))
(cond
;; Don't repeat the same warning for every top-level element.
((eq 'skip (car macroexp--pending-eager-loads)) form)
diff --git a/src/comp.c b/src/comp.c
index 5b947fc99b..ac38c2131f 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -454,6 +454,7 @@ load_gccjit_if_necessary (bool mandatory)
/* 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"
@@ -542,6 +543,7 @@ typedef struct {
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;
@@ -563,6 +565,15 @@ typedef struct {
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. */
@@ -655,7 +666,10 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object
x);
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,
@@ -664,6 +678,7 @@ void *helper_link_table[] =
record_unwind_protect_excursion,
helper_unbind_n,
helper_save_restriction,
+ helper_GET_SYMBOL_WITH_POSITION,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
@@ -1328,9 +1343,9 @@ emit_XCONS (gcc_jit_rvalue *a)
}
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,
@@ -1340,6 +1355,30 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
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)
{
@@ -1401,6 +1440,94 @@ emit_CONSP (gcc_jit_rvalue *obj)
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)
{
@@ -1615,7 +1742,7 @@ static gcc_jit_rvalue *
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 *
@@ -2095,7 +2222,13 @@ emit_limple_insn (Lisp_Object insn)
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))
{
@@ -2714,7 +2847,8 @@ declare_imported_data (void)
/*
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)
@@ -2751,6 +2885,10 @@ 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;
@@ -2798,6 +2936,15 @@ emit_ctxt_code (void)
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 (
@@ -2977,6 +3124,39 @@ define_lisp_cons (void)
}
+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
@@ -3672,6 +3852,40 @@ define_PSEUDOVECTORP (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)
{
@@ -4309,6 +4523,7 @@ Return t on success. */)
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),
@@ -4381,6 +4596,7 @@ Return t on success. */)
/* Define data structures. */
define_lisp_cons ();
+ define_lisp_symbol_with_position ();
define_jmp_buf ();
define_handler_struct ();
define_thread_state_struct ();
@@ -4602,6 +4818,7 @@ DEFUN ("comp--compile-ctxt-to-file",
Fcomp__compile_ctxt_to_file,
/* Define inline functions. */
define_CAR_CDR ();
define_PSEUDOVECTORP ();
+ define_GET_SYMBOL_WITH_POSITION ();
define_CHECK_TYPE ();
define_CHECK_IMPURE ();
define_bool_to_lisp_obj ();
@@ -4734,6 +4951,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum
pvec_type code)
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);
+}
+
/* `native-comp-eln-load-path' clean-up support code. */
@@ -5018,12 +5243,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
{
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
@@ -5035,6 +5263,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
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. */
@@ -5541,3 +5770,6 @@ be preloaded. */);
defsubr (&Snative_comp_available_p);
}
+/* Local Variables: */
+/* c-file-offsets: ((arglist-intro . +)) */
+/* End: */
diff --git a/src/fns.c b/src/fns.c
index 43df40aa9e..5df4ecfb36 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2414,6 +2414,11 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */)
(Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
{
CHECK_SYMBOL (symbol);
+ if (symbols_with_pos_enabled)
+ {
+ propname = call1 (intern ("macroexp-strip-symbol-positions"), propname);
+ value = call1 (intern ("macroexp-strip-symbol-positions"), value);
+ }
set_symbol_plist
(symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value));
return value;
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/correct-warning-pos 1cd188799f: Make symbols with positions work with native compilation,
Alan Mackenzie <=