procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make symbols with positions work with native compilation

Browse source 
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.
This commit is contained in:
Alan Mackenzie 2021-12-30 10:14:58 +00:00
parent 8f1106ddf2
commit 1cd188799f
6 changed files with 561 additions and 307 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

507
lisp/emacs-lisp/bytecomp.el
View file

@ -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)

35
lisp/emacs-lisp/cl-macs.el
View file

@ -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

13
lisp/emacs-lisp/comp.el
View file

@ -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.

66
lisp/emacs-lisp/macroexp.el
View file

@ -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)

242
src/comp.c
View file

@ -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 = &current_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: */

5
src/fns.c
View file

@ -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;