diff options
Diffstat (limited to 'lisp/emacs-lisp/comp.el')
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 83 |
1 files changed, 46 insertions, 37 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a363bed3642..7c755372bfc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -238,7 +238,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -483,7 +483,7 @@ Useful to hook into pass checkers.") (point-min (function () integer)) (preceding-char (function () fixnum)) (previous-window (function (&optional window t t) window)) - (prin1-to-string (function (t &optional t) string)) + (prin1-to-string (function (t &optional t t) string)) (processp (function (t) boolean)) (proper-list-p (function (t) integer)) (propertize (function (string &rest t) string)) @@ -898,6 +898,8 @@ non local exit (ends with an `unreachable' insn).")) :documentation "Doc string.") (int-spec nil :type list :documentation "Interactive form.") + (command-modes nil :type list + :documentation "Command modes.") (lap () :type list :documentation "LAP assembly representation.") (ssa-status nil :type symbol @@ -1021,7 +1023,7 @@ To be used by all entry points." (defun comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. -Assume allocation class 'd-default as default." +Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defsubst comp-add-const-to-relocs (obj) @@ -1243,6 +1245,7 @@ clashes." :c-name c-name :doc (documentation f t) :int-spec (interactive-form f) + :command-modes (command-modes f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name 'pure)))) @@ -1282,10 +1285,12 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) @@ -1327,6 +1332,7 @@ clashes." (comp-func-byte-func func) byte-func (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) @@ -1767,6 +1773,7 @@ This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) + (declare-function comp-body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1945,7 +1952,6 @@ and the annotation emission." (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) @@ -2079,7 +2085,8 @@ and the annotation emission." (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i) - (comp-func-int-spec f))) + (comp-func-int-spec f) + (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -2122,7 +2129,8 @@ These are stored in the reloc data array." (i (hash-table-count h))) (puthash i (comp-func-doc func) h) i) - (comp-func-int-spec func))) + (comp-func-int-spec func) + (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) @@ -2625,8 +2633,8 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) - "Rewrite conditional branches adding appropriate 'assume' insns. -This is introducing and placing 'assume' insns in use by fwprop + "Rewrite conditional branches adding appropriate `assume' insns. +This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) @@ -3088,13 +3096,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) - (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval) - (comp-mvar-neg lval) (comp-mvar-neg rval))) - (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) @@ -3144,10 +3145,7 @@ Fold the call in case." (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. (setf (comp-block-lap-non-ret-insn comp-block) insn)) - (setf (comp-mvar-range lval) (comp-cstr-range cstr) - (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (comp-cstr-shallow-copy lval cstr))) (cl-case f (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) @@ -3165,9 +3163,9 @@ Fold the call in case." (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (comp-fwprop-call insn lval f args))) (_ - (comp-mvar-propagate lval rval)))) + (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) - (comp-mvar-propagate lval rval)) + (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and @@ -3484,7 +3482,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with a normal 'set' op." +These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b @@ -3580,7 +3578,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -4016,9 +4014,12 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (let* ((print-symbols-bare t) + (max-specpdl-size (max max-specpdl-size 5000)) + (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 @@ -4062,10 +4063,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. @@ -4205,9 +4206,9 @@ last directory in `native-comp-eln-load-path')." if (or (null byte+native-compile) (cl-notany (lambda (re) (string-match re file)) native-comp-bootstrap-deny-list)) - do (comp--native-compile file) + collect (comp--native-compile file) else - do (byte-compile-file file)))) + collect (byte-compile-file file)))) ;;;###autoload (defun batch-byte+native-compile () @@ -4216,17 +4217,25 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." +variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) - (let ((byte+native-compile t) - (byte-to-native-output-file nil)) - (batch-native-compile) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (let* ((byte+native-compile t) + (byte-to-native-output-buffer-file nil) + (eln-file (car (batch-native-compile)))) + (pcase byte-to-native-output-buffer-file + (`(,temp-buffer . ,target-file) + (unwind-protect + (progn + (byte-write-target-file temp-buffer target-file) + ;; Touch the .eln in order to have it older than the + ;; corresponding .elc. + (when (stringp eln-file) + (set-file-times eln-file))) + (kill-buffer temp-buffer)))) + (setq command-line-args-left (cdr command-line-args-left))))) ;;;###autoload (defun native-compile-async (files &optional recursively load selector) |