[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master f6955482c29 1/2: Clean up LAP peephole logging
|
From: |
Mattias Engdegård |
|
Subject: |
master f6955482c29 1/2: Clean up LAP peephole logging |
|
Date: |
Thu, 2 Feb 2023 08:47:36 -0500 (EST) |
branch: master
commit f6955482c2933706229044c04d88b807b63a7095
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>
Clean up LAP peephole logging
Make `byte-compile-log-lap` more robust and produce nicer output.
This is of interest for Elisp compiler maintainers only.
* lisp/emacs-lisp/byte-opt.el (bytecomp--log-lap-arg): New.
(byte-compile-log-lap-1): Extract argument conversion and rewrite
in a more modern way, fixing bugs. In particular, tags are now
displayed as "X:" where X is the tag number, and that tag number
is shown as argument to goto-like ops.
(byte-optimize-lapcode): Clean up and simplify logging, producing
useful information when `byte-optimize-log` is `byte` as intended.
---
lisp/emacs-lisp/byte-opt.el | 83 ++++++++++++++++++++++-----------------------
1 file changed, 41 insertions(+), 42 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 4d39e28fc8e..9eb48f5fe0b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -72,34 +72,40 @@
(require 'macroexp)
(eval-when-compile (require 'subr-x))
+(defun bytecomp--log-lap-arg (arg)
+ ;; Convert an argument that may be a LAP operation to something printable.
+ (cond
+ ;; Symbols are just stripped of their -byte prefix if any.
+ ((symbolp arg)
+ (intern (string-remove-prefix "byte-" (symbol-name arg))))
+ ;; Conses are assumed to be LAP ops or tags.
+ ((and (consp arg) (symbolp (car arg)))
+ (let* ((head (car arg))
+ (tail (cdr arg))
+ (op (intern (string-remove-prefix "byte-" (symbol-name head)))))
+ (cond
+ ((eq head 'TAG)
+ (format "%d:" (car tail)))
+ ((memq head byte-goto-ops)
+ (format "(%s %d)" op (cadr tail)))
+ ((memq head byte-constref-ops)
+ (format "(%s %s)"
+ (if (eq op 'constant) 'const op)
+ (if (numberp tail)
+ (format "<V%d>" tail) ; closure var reference
+ (format "%S" (car tail))))) ; actual constant
+ ;; Ops with an immediate argument.
+ ((memq op '( stack-ref stack-set call unbind
+ listN concatN insertN discardN discardN-preserve-tos))
+ (format "(%s %S)" op tail))
+ ;; Without immediate, print just the symbol.
+ (t op))))
+ ;; Anything else is printed as-is.
+ (t arg)))
+
(defun byte-compile-log-lap-1 (format &rest args)
(byte-compile-log-1
- (apply #'format-message format
- (let (c a)
- (mapcar (lambda (arg)
- (if (not (consp arg))
- (if (and (symbolp arg)
- (string-match "^byte-" (symbol-name arg)))
- (intern (substring (symbol-name arg) 5))
- arg)
- (if (integerp (setq c (car arg)))
- (error "Non-symbolic byte-op %s" c))
- (if (eq c 'TAG)
- (setq c arg)
- (setq a (cond ((memq c byte-goto-ops)
- (car (cdr (cdr arg))))
- ((memq c byte-constref-ops)
- (car (cdr arg)))
- (t (cdr arg))))
- (setq c (symbol-name c))
- (if (string-match "^byte-." c)
- (setq c (intern (substring c 5)))))
- (if (eq c 'constant) (setq c 'const))
- (if (and (eq (cdr arg) 0)
- (not (memq c '(unbind call const))))
- c
- (format "(%s %s)" c a))))
- args)))))
+ (apply #'format-message format (mapcar #'bytecomp--log-lap-arg args))))
(defmacro byte-compile-log-lap (format-string &rest args)
`(and (memq byte-optimize-log '(t byte))
@@ -2073,10 +2079,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(setcar lap0 (setq tmp 'byte-discard))
(setcdr lap0 0))
((error "Depth conflict at tag %d" (nth 2 lap0))))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
- (nth 1 lap1) (nth 1 lap1)
- tmp (nth 1 lap1)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 lap1 tmp lap1)
(setq keep-going t))
;;
;; varset-X varref-X --> dup varset-X
@@ -2165,7 +2169,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(eq (cdr lap0) lap2)) ; TAG X
(let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
'byte-goto-if-not-nil 'byte-goto-if-nil)))
- (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
lap0 lap1 lap2
(cons inverse (cdr lap1)) lap2)
(setq lap (delq lap0 lap))
@@ -2238,9 +2242,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
;;
((and (eq (car lap0) 'TAG)
(eq (car lap1) 'TAG))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " adjacent tags %d and %d merged"
- (nth 1 lap1) (nth 1 lap0)))
+ (byte-compile-log-lap " adjacent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0))
(setq tmp3 lap)
(while (setq tmp2 (rassq lap0 tmp3))
(setcdr tmp2 lap1)
@@ -2262,8 +2265,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(cl-loop for table in byte-compile-jump-tables
when (member lap0 (hash-table-values table))
return nil finally return t))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
+ (byte-compile-log-lap " unused tag %d removed" (nth 1 lap0))
(setq lap (delq lap0 lap)
keep-going t))
;;
@@ -2459,12 +2461,10 @@ If FOR-EFFECT is non-nil, the return value is assumed
to be of no importance."
(memq (car (car tmp))
'(byte-goto byte-goto-if-nil byte-goto-if-not-nil
byte-goto-if-nil-else-pop)))
- ;; (byte-compile-log-lap " %s %s, %s %s --> moved
conditional"
- ;; lap0 lap1 (cdr lap0) (car tmp))
(let ((newtag (byte-compile-make-tag)))
(byte-compile-log-lap
- "%s %s: ... %s: %s\t-->\t%s ... %s:"
- lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+ " %s %s ... %s %s\t-->\t%s ... %s"
+ lap0 lap1 (cdr lap0) (car tmp)
(cons (cdr (assq (car (car tmp))
'((byte-goto-if-nil . byte-goto-if-not-nil)
(byte-goto-if-not-nil . byte-goto-if-nil)
@@ -2474,8 +2474,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
byte-goto-if-nil-else-pop))))
newtag)
- (nth 1 newtag)
- )
+ newtag)
(setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
(if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
;; We can handle this case but not the -if-not-nil case,