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

* Some clean-up in comp.el

Browse source 
* lisp/emacs-lisp/comp.el (comp-emit-cond-jump, comp-emit-switch)
	(comp-limplify-block, comp-compute-edges)
	(comp-ssa-rename, comp-fwprop*, comp-effective-async-max-jobs)
	(comp-run-async-workers): Respect max 80 columns.
	(batch-byte-native-compile-for-bootstrap): Improve doc + remove
	some now unnecessary error handling.
This commit is contained in:
Andrea Corallo 2020-09-28 21:09:00 +02:00
parent 3129b3ffcb
commit 89f064104c
1 changed files with 41 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -973,8 +973,9 @@ block.
If NEGATED non null negate the tested condition.
Return value is the fall through block name."
(cl-destructuring-bind (label-num . label-sp) lap-label
(let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
(comp-sp)))) ; Fall through block.
(let* ((bb (comp-block-name (comp-bb-maybe-add
(1+ (comp-limplify-pc comp-pass))
(comp-sp)))) ; Fall through block.
(target-sp (+ target-offset (comp-sp)))
(target-addr (comp-label-to-addr label-num))
(target (comp-bb-maybe-add target-addr target-sp))
@ -1065,8 +1066,9 @@ Return value is the fall through block name."
for n from 1
for last = (= n len)
for m-test = (make-comp-mvar :constant test)
for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label)
(comp-sp)))
for target-name = (comp-block-name (comp-bb-maybe-add
(comp-label-to-addr target-label)
(comp-sp)))
for ff-bb = (if last
(comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
(comp-sp))
@ -1562,7 +1564,9 @@ into the C code forwarding the compilation unit."
(let* ((stack-depth (if label-sp
(1- label-sp)
(comp-sp)))
(next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth))))
(next-bb (comp-block-name (comp-bb-maybe-add
(comp-limplify-pc comp-pass)
stack-depth))))
(unless (comp-block-closed bb)
(comp-emit `(jump ,next-bb))))
(cl-return)))
@ -1733,14 +1737,17 @@ into the C code forwarding the compilation unit."
(list "block does not end with a branch"
bb
(comp-func-name comp-func)))))
finally (setf (comp-func-edges comp-func)
(nreverse (comp-func-edges comp-func)))
;; Update edge refs into blocks.
(cl-loop for edge in (comp-func-edges comp-func)
do (push edge
(comp-block-out-edges (comp-edge-src edge)))
(push edge
(comp-block-in-edges (comp-edge-dst edge))))
finally
(setf (comp-func-edges comp-func)
(nreverse (comp-func-edges comp-func)))
;; Update edge refs into blocks.
(cl-loop
for edge in (comp-func-edges comp-func)
do
(push edge
(comp-block-out-edges (comp-edge-src edge)))
(push edge
(comp-block-in-edges (comp-edge-dst edge))))
(comp-log-edges comp-func))))
(defun comp-collect-rev-post-order (basic-block)
@ -1932,10 +1939,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(setf (comp-block-final-frame bb)
(copy-sequence in-frame))
(when-let ((out-edges (comp-block-out-edges bb)))
(cl-loop for ed in out-edges
for child = (comp-edge-dst ed)
;; Provide a copy of the same frame to all childs.
do (ssa-rename-rec child (copy-sequence in-frame)))))))
(cl-loop
for ed in out-edges
for child = (comp-edge-dst ed)
;; Provide a copy of the same frame to all children.
do (ssa-rename-rec child (copy-sequence in-frame)))))))
(ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
(comp-new-frame frame-size t)))))
@ -2118,7 +2126,8 @@ Return t if something was changed."
(cl-loop with modified = nil
for b being each hash-value of (comp-func-blocks comp-func)
do (cl-loop for insn in (comp-block-insns b)
for orig-insn = (unless modified ; Save consing after 1th change.
for orig-insn = (unless modified
;; Save consing after 1th change.
(comp-copy-insn insn))
do (comp-fwprop-insn insn)
when (and (null modified) (not (equal insn orig-insn)))
@ -2689,9 +2698,11 @@ processes from `comp-async-compilations'"
;; the number of processors, see get_native_system_info in w32.c.
;; The result needs to be exported to Lisp.
(max 1 (/ (cond ((eq 'windows-nt system-type)
(string-to-number (getenv "NUMBER_OF_PROCESSORS")))
(string-to-number (getenv
"NUMBER_OF_PROCESSORS")))
((executable-find "nproc")
(string-to-number (shell-command-to-string "nproc")))
(string-to-number
(shell-command-to-string "nproc")))
(t 1))
2))))
comp-async-jobs-number))
@ -2712,8 +2723,8 @@ display a message."
when (or comp-always-compile
load ; Always compile when the compilation is
; commanded for late load.
(file-newer-than-file-p source-file
(comp-el-to-eln-filename source-file)))
(file-newer-than-file-p
source-file (comp-el-to-eln-filename source-file)))
do (let* ((expr `(progn
(require 'comp)
(setf comp-speed ,comp-speed
@ -2841,21 +2852,18 @@ Ultra cheap impersonation of `batch-byte-compile'."
;;;###autoload
(defun batch-byte-native-compile-for-bootstrap ()
"As `batch-byte-compile' but used for booststrap.
Always generate elc files too and handle native compiler expected errors."
Generate .elc files in addition to the .eln one. If the
environment variable 'NATIVE_DISABLED' is set byte compile only."
(comp-ensure-native-compiler)
(if (equal (getenv "NATIVE_DISABLED") "1")
(batch-byte-compile)
(cl-assert (= 1 (length command-line-args-left)))
(let ((byte-native-for-bootstrap t)
(byte-to-native-output-file nil))
(unwind-protect
(condition-case _
(batch-native-compile)
(native-compiler-error-dyn-func)
(native-compiler-error-empty-byte))
(pcase byte-to-native-output-file
(`(,tempfile . ,target-file)
(rename-file tempfile target-file t)))))))
(batch-native-compile)
(pcase byte-to-native-output-file
(`(,tempfile . ,target-file)
(rename-file tempfile target-file t))))))
;;;###autoload
(defun native-compile-async (paths &optional recursively load)
@ -2874,7 +2882,8 @@ LOAD can be nil t or 'late."
(dolist (path paths)
(cond ((file-directory-p path)
(dolist (file (if recursively
(directory-files-recursively path comp-valid-source-re)
(directory-files-recursively
path comp-valid-source-re)
(directory-files path t comp-valid-source-re)))
(push file files)))
((file-exists-p path) (push path files))