-
Notifications
You must be signed in to change notification settings - Fork 11
/
byte-pretty.el
164 lines (156 loc) · 6 KB
/
byte-pretty.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
(defun byte-pretty-op-arg-len (bytes off)
(let* ((opcode (aref bytes off))
(arg nil)
(len 1))
(cond ((< opcode byte-pophandler)
(let ((tem (logand opcode 7)))
(setq opcode (- opcode tem))
(cond ((= tem 6)
(list opcode 0 2))
((= tem 7)
(list opcode 0 3))
(t
(list opcode tem 1)))))
((>= opcode byte-constant)
(list byte-constant (- opcode byte-constant) 1))
((or (and (>= opcode byte-constant2)
(<= opcode byte-goto-if-not-nil-else-pop))
(memq opcode (list byte-stack-set2 byte-pushcatch
byte-pushconditioncase)))
(list opcode nil 3))
((and (>= opcode byte-listN)
(<= opcode byte-discardN))
(list opcode nil 2))
(t (list opcode nil 1)))))
(defun byte-pretty-name-arg-len (bytes off)
(let* ((tem (byte-pretty-op-arg-len bytes off))
(opcode (car tem))
(arg (cadr tem))
(len (caddr tem))
(type (cond ((memq opcode (mapcar #'symbol-value byte-goto-ops)) 'pc)
((memq opcode (mapcar #'symbol-value byte-constref-ops)) 'cv)
(t 'stack-or-count)))
(name (substring (symbol-name (aref byte-code-vector opcode)) 5)))
(and arg (setq name (concat name "[" (format "%S" arg) "]")))
(cond ((= len 3)
(setq arg (+ (aref bytes (1+ off))
(lsh (aref bytes (+ 2 off)) 8)))
(setq name (concat name " " (format "[%S]" arg))))
((= len 2)
(setq arg (aref bytes (1+ off)))
(setq name (concat name " " (format "[%S]" arg))))
(t t))
(list name (cons type arg) len)))
(defun byte-pretty-arg (arg constvec)
(cond ((eq (car arg) 'cv)
(format " %S" (aref constvec (cdr arg))))
(t "")))
(defun byte-pretty-disassemble (bytes &optional constvec)
(let ((beg 0)
(end (length bytes))
res)
(while (< beg end)
(let* ((tem (byte-pretty-name-arg-len bytes beg))
(name (car tem))
(arg (byte-pretty-arg (cadr tem) constvec))
(len (caddr tem)))
(push (cons beg (cons name arg)) res)
(setq beg (+ beg len))))
(nreverse res)))
(defun byte--pretty-bytes (bytes)
(mapconcat (lambda (x) (format "%3d" x)) bytes " "))
(defun byte-pretty-compile-decompile-texinfo (form &optional optimize)
"Compile FORM, then disassemble it, producing output suitable
for texinfo input."
(let* ((byte-optimize optimize)
(v (byte-compile form))
(constvec (aref v 2))
(bytes (aref v 1))
(bytecode (byte-pretty-disassemble bytes constvec))
(rbc (reverse bytecode))
(pc (length bytes))
(str "@end verbatim\n")
(width (max 2 (ceiling (log pc 10))))
(pc-width (format "%%%dd " width))
(str-width (format "%%%ds " width))
)
(if (> (length constvec) 0)
(setq str (concat (format "\nConstants Vector: %S\n" constvec) str)))
(while (> pc 0)
(let* ((op (cdar rbc))
(npc (caar rbc))
(lstr ""))
(while (< (1+ npc) pc)
(setq str (concat " "
(byte--pretty-bytes (substring bytes (1- pc) pc))
"\n"
str))
(setq pc (1- pc)))
(setq str (concat lstr
(format pc-width npc)
(byte--pretty-bytes (substring bytes npc (1+ npc)))
" "
(car op)
(cdr op)
"\n"
str))
(setq rbc (cdr rbc))
(setq pc npc)))
(setq str (format "@verbatim\n%s Byte Instruction\n%s"
(format str-width "PC") str))
str))
(defun byte-collect-comments (beg end)
(let ((res nil))
(goto-char beg)
(while (search-forward-regexp "^ *\\([0-9]+\\).*?\\( *;;.*\\)$" end t)
(push (cons (read (match-string 1)) (match-string 2))
res))
(goto-char end)
res))
(defun byte-insert-comments (beg end comments)
(setq end (copy-marker end))
(goto-char beg)
(while (search-forward-regexp "^ *\\([0-9]+\\) +[0-9].*$" end t)
(let ((comment (alist-get (read (match-string 1)) comments)))
(when comment
(insert comment))))
(goto-char end))
(defun byte-recalc-examples (beg end)
"Recalculate the examples in elisp-bytecode.texi"
(interactive "r")
(save-excursion
(unless (use-region-p)
(setq beg (point-min))
(setq end (point-max)))
(goto-char beg)
(while (search-forward-regexp "@code{\\([^}]*\\)} generates:$" end t)
(let* ((code (read (match-string 1)))
(form nil)
(warnings t)
(comments nil)
(alist nil)
(lexical nil)
(optimize t))
(forward-char 1)
(when (looking-at "^@c \\((.*)\\)$")
(setq alist (read (match-string 1)))
(setq lexical (alist-get 'lexical alist lexical))
(setq optimize (alist-get 'optimize alist optimize))
(setq warnings (alist-get 'warnings alist warnings))
(forward-line 1))
(setq form (cond ((eq (car-safe code) 'defun)
(with-no-warnings (eval code lexical)))
(t
`(lambda () ,code))))
(let ((p0 (point)))
(when (looking-at-p "^@verbatim$")
(let ((p1 (search-forward-regexp "@end verbatim\n*")))
(setq comments (byte-collect-comments p0 p1))
(delete-region p0 p1))))
(let* ((p0 (point))
(byte-compile-warnings nil)
(pretty (with-no-warnings (byte-pretty-compile-decompile-texinfo form optimize))))
(insert pretty)
(byte-insert-comments p0 (point) comments)))
(when (not (looking-at-p "\n\n"))
(insert "\n")))))