mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-03 10:31:37 -08:00
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.
This commit is contained in:
Alan Mackenzie
parent
8f1106ddf2
commit
1cd188799f
6 changed files with 561 additions and 307 deletions
|
|
@ -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
|
||||
(macroexp-strip-symbol-positions
|
||||
(byte-compile-top-level
|
||||
(byte-compile-preprocess form)))))))
|
||||
(byte-compile-preprocess form))))))))
|
||||
(list 'quote result))))
|
||||
(eval-and-compile . ,(lambda (&rest body)
|
||||
(byte-compile-recurse-toplevel
|
||||
|
|
@ -550,7 +521,10 @@ Return the compile-time value of FORM."
|
|||
(macroexpand-all
|
||||
form
|
||||
macroexpand-all-environment)))
|
||||
(eval expanded lexical-binding)
|
||||
(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,6 +2091,7 @@ 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)
|
||||
(prog1
|
||||
(let ((byte-compile-current-file filename)
|
||||
(byte-compile-current-group nil)
|
||||
(set-auto-coding-for-load t)
|
||||
|
|
@ -2285,7 +2260,10 @@ See also `emacs-lisp-byte-compile-and-load'."
|
|||
(write-region (point-min) (point-max) dynvar-file)))))
|
||||
(if load
|
||||
(load target-file))
|
||||
t))))
|
||||
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,7 +2436,9 @@ 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)
|
||||
(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)
|
||||
|
|
@ -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,12 +2906,14 @@ 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
|
||||
(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-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.
|
||||
|
|
@ -3020,6 +3002,7 @@ 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)))
|
||||
(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
|
||||
|
|
@ -3050,7 +3033,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
|||
(setq fun (eval fun t)))
|
||||
(if macro (push 'macro fun))
|
||||
(if (symbolp form) (fset form fun))
|
||||
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))
|
||||
|
|
@ -5554,6 +5539,8 @@ already up-to-date."
|
|||
(if (null (batch-byte-compile-file (car command-line-args-left)))
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,9 +154,10 @@ 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)
|
||||
(message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err)
|
||||
form)))
|
||||
|
||||
(defun macroexp--funcall-if-compiled (_form)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
240
src/comp.c
240
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,6 +2222,12 @@ emit_limple_insn (Lisp_Object insn)
|
|||
gcc_jit_block *target1 = retrive_block (arg[2]);
|
||||
gcc_jit_block *target2 = retrive_block (arg[3]);
|
||||
|
||||
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: */
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue