From 50daa712e6740a60bf73840f43b7c4a7d782523f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Tue, 17 Mar 2020 15:09:10 +0100
Subject: [PATCH] Add regexp bytecode disassembler

This is mainly intended as a regexp engine maintenance and debugging
aid.  See discussion at
https://lists.gnu.org/archive/html/emacs-devel/2020-03/msg00461.html .

* lisp/emacs-lisp/regexp-disasm.el: New file.
* src/search.c (Finternal__regexp_bytecode): New function.
(syms_of_search): Define it as Lisp function.
* src/regex-emacs.c:
* src/syntax.h: Add comments to keep definitions in sync with
regexp-disasm.el.
---
 lisp/emacs-lisp/regexp-disasm.el | 317 +++++++++++++++++++++++++++++++
 src/regex-emacs.c                |   7 +-
 src/search.c                     |  17 ++
 src/syntax.h                     |   2 +
 4 files changed, 341 insertions(+), 2 deletions(-)
 create mode 100644 lisp/emacs-lisp/regexp-disasm.el

diff --git a/lisp/emacs-lisp/regexp-disasm.el b/lisp/emacs-lisp/regexp-disasm.el
new file mode 100644
index 0000000000..4c467141e8
--- /dev/null
+++ b/lisp/emacs-lisp/regexp-disasm.el
@@ -0,0 +1,317 @@
+;;; regexp-disasm -- disassemble regexp bytecode  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Decode compiled Emacs regexp bytecode, and pretty-print it.
+;; Effective use of this code requires some knowledge of the internals
+;; of the regexp engine.  See re_opcode_t in regex-emacs.c.
+
+(defconst regexp-disasm--classes
+  [word lower punct space upper multibyte alpha alnum graph print blank]
+  "Vector of character classes, corresponding to BIT_* in regex-emacs.c.
+The vector index corresponds to the bit number.")
+
+(defconst regexp-disasm--syntax-codes
+  [whitespace punctuation word symbol
+   open-parenthesis close-parenthesis expression-prefix string-quote
+   paired-delimiter escape character-quote comment-start comment-end
+   inherit comment-delimiter string-delimiter]
+  "Vector of syntax codes, corresponding to enum syntaxcode in syntax.h.
+The vector index is the enum value; the symbol names are from `rx'.")
+
+(defun regexp-disasm--decode-multibyte (bytes)
+  "Decode BYTES from the internal string format to the string it represents."
+  ;; Each raw byte in the 80..ff range is internally represented as the
+  ;; two bytes 1100000x 10xxxxxx, which are decoded as separate raw bytes
+  ;; by utf-8-emacs, so we have to post-process the results.
+  (let* ((s (decode-coding-string bytes 'utf-8-emacs))
+         (len (length s))
+         (i 0)
+         (start 0)
+         (parts nil))
+    (while (< i (1- len))
+      (if (and (<= #x3fffc0 (aref s i) #x3fffc1)
+               (<= #x3fff80 (aref s (1+ i)) #x3fffbf))
+          ;; A pair of chars representing a raw byte.
+          (progn
+            (when (> i start)
+              (push (substring s start i) parts))
+            (push (string (+ #x3fff80
+                             (ash (logand (aref s i) 1) 6)
+                             (logand (aref s (1+ i)) #x3f)))
+                  parts)
+            (setq start (+ i 2))
+            (setq i start))
+        (setq i (1+ i))))
+    (when (> len start)
+      (push (substring s start) parts))
+    (apply #'concat (nreverse parts))))
+
+;;;###autoload
+(defun regexp-disasm (regexp &optional case-table)
+  "Disassemble the bytecode for REGEXP; return list of instructions.
+CASE-TABLE, if non-nil, is a translation table for case-folding.
+Instructions take the form (ADDRESS . INSTR) where ADDRESS is the
+byte offset and INSTR an S-expression representing the instruction."
+  (let* ((bc (internal--regexp-bytecode regexp case-table))
+         (read-u16 (lambda (ofs) (+ (aref bc ofs)
+                                    (ash (aref bc (1+ ofs)) 8))))
+         (read-u24 (lambda (ofs) (+ (aref bc ofs)
+                                    (ash (aref bc (+ ofs 1)) 8)
+                                    (ash (aref bc (+ ofs 2)) 16))))
+         (read-s16 (lambda (ofs) (let ((x (funcall read-u16 ofs)))
+                                   (- x (ash (logand x #x8000) 1)))))
+         (len (length bc))
+         (i 0)
+         (entries nil))
+    (while (< i len)
+      ;; This code depends on the exact details of the regexp bytecode
+      ;; representation; see re_opcode_t in regex-emacs.c.
+      (let* ((opcode (aref bc i))
+             (entry-and-size
+               (pcase opcode
+                 (0 '(no-op . 1))
+                 (1 '(succeed . 1))
+                 (2 (let* ((nbytes (aref bc (1+ i)))
+                           (raw (substring bc (+ i 2) (+ i 2 nbytes)))
+                           ;; Exact strings are multibyte-coded iff the
+                           ;; original regexp is.
+                           (str (if (multibyte-string-p regexp)
+                                    (regexp-disasm--decode-multibyte raw)
+                                  raw)))
+                      (cons (list 'exact str) (+ 2 nbytes))))
+                 (3 '(not-newline . 1))        ; `anychar' is a misnomer
+                 ((or 4 5)              ; `charset', `charset-not'
+                  (let* ((negated (= opcode 5))
+                         (bitmap-len-raw (aref bc (1+ i)))
+                         (bitmap-len (logand bitmap-len-raw #x7f))
+                         (have-range-table (/= (logand bitmap-len-raw #x80) 0))
+                         (npairs (if have-range-table
+                                     (funcall read-u16 (+ i 2 bitmap-len 2))
+                                   0))
+                         (bitmap-pairs nil)
+                         (classes nil)
+                         (pairs nil))
+
+                    ;; Convert the bitmap to ranges.
+                    (let ((first nil))
+                      (dotimes (j (* bitmap-len 8))
+                        (if (/= (logand (aref bc (+ i 2 (ash j -3)))
+                                        (ash 1 (logand j 7)))
+                                0)
+                            (unless first
+                              (setq first j))
+                          (when first
+                            (push (cons first (1- j)) bitmap-pairs)
+                            (setq first nil))))
+                      (when first
+                        (push (cons first (1- (* bitmap-len 8))) bitmap-pairs)))
+
+                    (when have-range-table
+                      ;; Convert class bits to list of classes.
+                      (let ((class-bits (funcall read-u16 (+ i 2 bitmap-len))))
+                        (dotimes (j (length regexp-disasm--classes))
+                          (when (/= (logand class-bits (ash 1 j)) 0)
+                            (push (aref regexp-disasm--classes j) classes))))
+
+                      ;; Read range table.
+                      (dotimes (j npairs)
+                        (let* ((ofs (+ i 2 bitmap-len 4 (* j 6)))
+                               (from (funcall read-u24 ofs))
+                               (to   (funcall read-u24 (+ ofs 3))))
+                          (push (cons from to) pairs))))
+
+                    (cons (list (if negated 'charset-not 'charset)
+                                (nreverse bitmap-pairs)
+                                (nreverse classes)
+                                (nreverse pairs))
+                          (+ 2 bitmap-len
+                             (if have-range-table 4 0) (* npairs 6)))))
+                 (6 (cons (list 'start-memory (aref bc (1+ i)))
+                          2))
+                 (7 (cons (list 'stop-memory (aref bc (1+ i)))
+                          2))
+                 (8 (cons (list 'duplicate (aref bc (1+ i)))
+                          2))
+                 (9 '(begline . 1))
+                 (10 '(endline . 1))
+                 (11 '(begbuf . 1))
+                 (12 '(endbuf . 1))
+                 (13 (cons (list 'jump
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (14 (cons (list 'on-failure-jump
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (15 (cons (list 'on-failure-keep-string-jump
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (16 (cons (list 'on-failure-jump-loop
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (17 (cons (list 'on-failure-jump-nastyloop
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (18 (cons (list 'on-failure-jump-smart
+                                 (+ (funcall read-s16 (1+ i)) i 3))
+                           3))
+                 (19 (cons (list 'succeed-n
+                                 (+ (funcall read-s16 (1+ i)) i 3)
+                                 (funcall read-u16 (+ i 3)))
+                           5))
+                 (20 (cons (list 'jump-n
+                                 (+ (funcall read-s16 (1+ i)) i 3)
+                                 (funcall read-u16 (+ i 3)))
+                           5))
+                 (21 (cons (list 'set-number-at
+                                 (+ (funcall read-s16 (1+ i)) i 3)
+                                 (funcall read-u16 (+ i 3)))
+                           5))
+                 (22 '(wordbeg . 1))
+                 (23 '(wordend . 1))
+                 (24 '(wordbound . 1))
+                 (25 '(notwordbound . 1))
+                 (26 '(symbeg . 1))
+                 (27 '(symend . 1))
+                 ;; Use symbolic names for syntax classes.
+                 (28 (cons (list 'syntaxspec
+                                 (aref regexp-disasm--syntax-codes
+                                       (aref bc (1+ i))))
+                           2))
+                 (29 (cons (list 'notsyntaxspec
+                                 (aref regexp-disasm--syntax-codes
+                                       (aref bc (1+ i))))
+                           2))
+                 (30 '(at-dot . 1))
+                 ;; Use the category code char for categories.
+                 (31 (cons (list 'categoryspec (aref bc (1+ i)))
+                           2))
+                 (32 (cons (list 'notcategoryspec (aref bc (1+ i)))
+                           2))
+                 (_ (error "bad opcode at offset %d: 0x%02x" i opcode))))
+             (entry (car entry-and-size))
+             (size (cdr entry-and-size)))
+        (push (cons i entry) entries)
+        (setq i (+ i size))))
+    (nreverse entries)))
+
+;;;###autoload
+(defun regexp-disassemble (regexp &optional case-table)
+  "Print the disassembled bytecode for REGEXP.
+If CASE-TABLE is non-nil, use it as translation table for case-folding.
+
+Cached bytecode is returned if available.  Since a compiled regexp can
+be modified when it is used in matching, the exact output of this function
+may vary, but it should be operationally equivalent."
+  (interactive "XRegexp (evaluated): ")
+  (let* ((instructions (regexp-disasm regexp case-table))
+         (control-chars '((?\b . ?b)
+                          (?\t . ?t)
+                          (?\n . ?n)
+                          (?\v . ?v)
+                          (?\f . ?f)
+                          (?\r . ?r)
+                          (?\e . ?e)))
+         (quote-byte (lambda (c)
+                       (let ((esc (assq c control-chars)))
+                         (cond (esc (string ?\\ (cdr esc)))
+                               ((or (<= c 31) (<= #x7f c #xff))
+                                (format "\\%03o" c))
+                               (t (string c))))))
+         (quote-string-char (lambda (c)
+                              (let ((esc (assq c control-chars)))
+                                (cond (esc (string ?\\ (cdr esc)))
+                                      ((memq c '(?\\ ?\"))
+                                       (string ?\\ c))
+                                      ((or (<= c 31) (= c 127)
+                                           (>= c #x3fff80))
+                                       (format "\\%03o" (logand c #xff)))
+                                      (t (string c))))))
+         (quote-string (lambda (s)
+                         (concat "\""
+                                 (mapconcat quote-string-char
+                                            ;; Make multibyte, to distinguish
+                                            ;; raw chars from U+0080..00ff.
+                                            (string-to-multibyte s)
+                                            "")
+                                 "\"")))
+         (quote-range (lambda (range quote-char)
+                        (if (eq (car range) (cdr range))
+                            (funcall quote-char (car range))
+                          (format "%s-%s"
+                                  (funcall quote-char (car range))
+                                  (funcall quote-char (cdr range))))))
+         (quote-range-uni
+          (lambda (range) (funcall quote-range range quote-byte)))
+         (quote-range-multi
+          (lambda (range) (funcall quote-range range #'string))))
+    (with-output-to-temp-buffer "*Regexp-disassemble*"
+      (with-current-buffer standard-output
+        (insert (format "Disassembly of regexp %s\n\n"
+                        (funcall quote-string regexp)))
+        (dolist (instr instructions)
+          (let* ((addr (car instr))
+                 (op (cdr instr))
+                 (line
+                  (pcase op
+                    ((pred symbolp) (symbol-name op))
+                    (`(exact ,s) (format "exact %s" (funcall quote-string s)))
+                    (`(,(or 'charset 'charset-not)
+                       ,bitmap-pairs ,classes ,pairs)
+                     ;; FIXME: Maybe use a less ambiguous charset syntax.
+                     ;; Avoid ranges when endpoints are adjacent.
+                     ;; What to do about metachars like `]' and `-'?
+                     (concat (format "%s [%s]"
+                                     (car op)
+                                     (mapconcat quote-range-uni
+                                                bitmap-pairs ""))
+                             (and classes
+                                  (concat " [:"
+                                          (mapconcat
+                                           #'symbol-name classes ",")
+                                          ":]"))
+                             (and pairs
+                                  (concat " ["
+                                          (mapconcat quote-range-multi pairs "")
+                                          "]"))))
+                    (`(,(or 'start-memory 'stop-memory 'duplicate) ,n)
+                     (format "%s group %d" (car op) n))
+                    (`(,(or 'jump 'on-failure-jump 'on-failure-keep-string-jump
+                            'on-failure-jump-loop 'on-failure-jump-nastyloop
+                            'on-failure-jump-smart)
+                       ,dest)
+                     (format "%s to %d" (car op) dest))
+                    (`(,(or 'succeed-n 'jump-n) ,dest ,val)
+                     (format "%s to %d, value %d" (car op) dest val))
+                    (`(set-number-at ,dest ,val)
+                     ;; We adjust the destination address so that it
+                     ;; refers to the instruction, not to the offset
+                     ;; of the number.
+                     (format "%s instr %d to value %d" (car op) (- dest 3) val))
+                    (`(,(or 'syntaxspec 'notsyntaxspec) ,syn)
+                     (format "%s %s" (car op) syn))
+                    (`(,(or 'categoryspec 'notcategoryspec) ,ch)
+                     (format "%s '%c'" (car op) ch))
+                    (_ (error "unrecognised opcode: %S at %S" op addr)))))
+            (insert (format "%5d  %s\n" addr line))))))))
+
+(provide 'regexp-disasm)
+
+;;; regexp-disasm.el ends here
diff --git a/src/regex-emacs.c b/src/regex-emacs.c
index 0ae004e463..f12b1f9246 100644
--- a/src/regex-emacs.c
+++ b/src/regex-emacs.c
@@ -196,7 +196,9 @@ #define BYTEWIDTH 8 /* In bits.  */
 /* These are the command codes that appear in compiled regular
    expressions.  Some opcodes are followed by argument bytes.  A
    command code can specify any interpretation whatsoever for its
-   arguments.  Zero bytes may appear in the compiled regular expression.  */
+   arguments.  Zero bytes may appear in the compiled regular expression.
+
+   Any changes here should be reflected in regexp-disasm.el as well.  */
 
 typedef enum
 {
@@ -1342,7 +1344,8 @@ #define RANGE_TABLE_WORK_ELT(work_area, i) ((work_area).table[i])
 
 /* Bits used to implement the multibyte-part of the various character classes
    such as [:alnum:] in a charset's range table.  The code currently assumes
-   that only the low 16 bits are used.  */
+   that only the low 16 bits are used.
+   Keep this table in sync with regexp-disasm--classes.  */
 #define BIT_WORD	0x1
 #define BIT_LOWER	0x2
 #define BIT_PUNCT	0x4
diff --git a/src/search.c b/src/search.c
index 818bb4af24..a5804a17b6 100644
--- a/src/search.c
+++ b/src/search.c
@@ -3106,6 +3106,22 @@ record_unwind_save_match_data (void)
 			 Fmatch_data (Qnil, Qnil, Qnil));
 }
 
+DEFUN ("internal--regexp-bytecode", Finternal__regexp_bytecode,
+       Sinternal__regexp_bytecode, 2, 2, 0,
+       doc: /* Return the compiled bytecode of REGEXP.
+If CASE_TABLE is non-nil, use it as translation table for ignoring case.
+The bytecode is returned as a string; its format is implementation-dependent.
+Cached bytecode may be returned if available.  */)
+  (Lisp_Object regexp, Lisp_Object case_table)
+{
+  CHECK_STRING (regexp);
+  struct regexp_cache *cache_entry =
+    compile_pattern (regexp, NULL, case_table, false, true);
+  struct re_pattern_buffer *pb = &cache_entry->buf;
+  return make_unibyte_string (pb->buffer, pb->used);
+}
+
+
 /* Quote a string to deactivate reg-expr chars */
 
 DEFUN ("regexp-quote", Fregexp_quote, Sregexp_quote, 1, 1, 0,
@@ -3400,6 +3416,7 @@ syms_of_search (void)
   defsubr (&Smatch_end);
   defsubr (&Smatch_data);
   defsubr (&Sset_match_data);
+  defsubr (&Sinternal__regexp_bytecode);
   defsubr (&Sregexp_quote);
   defsubr (&Snewline_cache_check);
 
diff --git a/src/syntax.h b/src/syntax.h
index a2ec3301ba..4817e4c288 100644
--- a/src/syntax.h
+++ b/src/syntax.h
@@ -37,6 +37,8 @@ #define Vstandard_syntax_table BVAR (&buffer_defaults, syntax_table)
    (CODE+FLAGS . MATCHING-CHAR).  MATCHING-CHAR can be nil if the char
    is not a kind of parenthesis.
 
+   Keep this table in sync with regexp-disasm--syntax-codes.
+
    The low 8 bits of CODE+FLAGS is a code, as follows:  */
 
 enum syntaxcode
-- 
2.21.1 (Apple Git-122.3)

