From: Mattias Engdegård Date: Tue, 31 Jan 2023 10:15:13 +0000 (+0100) Subject: Clean up LAP peephole logging X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f6955482c2933706229044c04d88b807b63a7095;p=emacs.git 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. --- 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 "" 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,