-
Notifications
You must be signed in to change notification settings - Fork 18
/
asm.lisp
317 lines (281 loc) · 10.2 KB
/
asm.lisp
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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 2007 Frode V. Fjeld
;;;;
;;;; Description: Assembly syntax etc.
;;;; Author: Frode Vatvedt Fjeld <[email protected]>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm.lisp,v 1.18 2008-03-14 11:07:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
(defpackage asm
(:use :common-lisp)
(:export #:symbol-reference-p
#:symbol-reference
#:symbol-reference-symbol
#:immediate-p
#:immediate-operand
#:indirect-operand-p
#:indirect-operand
#:indirect-operand-offset
#:instruction-operands
#:instruction-operator
#:register-operand
#:resolve-operand
#:unresolved-symbol
#:retry-symbol-resolve
#:pc-relative-operand
#:assemble-proglist
#:disassemble-proglist
#:*pc*
#:*symtab*
#:*instruction-compute-extra-prefix-map*
#:*position-independent-p*
#:*sub-program-instructions*))
(in-package asm)
(defvar *pc* nil "Current program counter.")
(defvar *symtab* nil "Current symbol table.")
(defvar *instruction-compute-extra-prefix-map* nil)
(defvar *position-independent-p* t)
(defvar *sub-program-instructions* '(:jmp :ret :iretd)
"Instruction operators after which to insert sub-programs.")
(defvar *anonymous-sub-program-identities* nil)
(defun quotep (x)
"Is x a symbol (in any package) named 'quote'?"
;; This is required because of Movitz package-fiddling.
(and (symbolp x)
(string= x 'quote)))
(deftype simple-symbol-reference ()
'(cons (satisfies quotep) (cons symbol null)))
(deftype sub-program-operand ()
'(cons (satisfies quotep)
(cons
(cons (eql :sub-program))
null)))
(deftype funcall-operand ()
'(cons (satisfies quotep)
(cons
(cons (eql :funcall))
null)))
(deftype symbol-reference ()
'(or simple-symbol-reference sub-program-operand))
(defun sub-program-operand-p (expr)
(typep expr 'sub-program-operand))
(defun sub-program-label (operand)
(let ((x (cadadr operand)))
(if (not (eq '() x))
(car x)
(cdr (or (assoc operand *anonymous-sub-program-identities*)
(car (push (cons operand (gensym "sub-program-"))
*anonymous-sub-program-identities*)))))))
(defun sub-program-program (operand)
(cddadr operand))
(defun symbol-reference-symbol (expr)
(etypecase expr
(simple-symbol-reference
(second expr))
(sub-program-operand
(sub-program-label expr))))
(defun funcall-operand-operator (operand)
(cadadr operand))
(defun funcall-operand-operands (operand)
(cddadr operand))
(deftype immediate-operand ()
'(or integer symbol-reference funcall-operand))
(defun immediate-p (expr)
(typep expr 'immediate-operand))
(deftype register-operand ()
'keyword)
(defun register-p (operand)
(typep operand 'register-operand))
(deftype indirect-operand ()
'(and cons (not (cons (satisfies quotep)))))
(defun indirect-operand-p (operand)
(typep operand 'indirect-operand))
(defun indirect-operand-offset (operand)
(check-type operand indirect-operand)
(reduce #'+ operand
:key (lambda (x)
(if (integerp x) x 0))))
(deftype pc-relative-operand ()
'(cons (eql :pc+)))
(defun pc-relative-operand-p (operand)
(typep operand 'pc-relative-operand))
(defun pc-relative-operand-offset (operand)
(check-type operand pc-relative-operand)
(second operand))
(define-condition unresolved-symbol ()
((symbol
:initarg :symbol
:reader unresolved-symbol))
(:report (lambda (c s)
(format s "Unresolved symbol ~S." (unresolved-symbol c)))))
(defun resolve-operand (operand)
(typecase operand
(integer
operand)
(symbol-reference
(let ((s (symbol-reference-symbol operand)))
(loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
(return (cdr (or (assoc s *symtab*)
(error 'unresolved-symbol
:symbol s))))))))
(funcall-operand
(apply (funcall-operand-operator operand)
(mapcar #'resolve-operand
(funcall-operand-operands operand))))
(t operand)))
;;;;;;;;;;;;
(defun assemble-proglist (proglist &key ((:symtab incoming-symtab) *symtab*) corrections (start-pc 0) (cpu-package '#:asm-x86))
"Encode a proglist, using instruction-encoder in symbol assemble-instruction from cpu-package."
(let ((encoder (find-symbol (string '#:assemble-instruction) cpu-package))
(*pc* start-pc)
(*symtab* (append incoming-symtab corrections))
(*anonymous-sub-program-identities* *anonymous-sub-program-identities*)
(assumptions nil)
(new-corrections nil)
(sub-programs nil))
(flet ((process-instruction (instruction)
(etypecase instruction
((or symbol integer) ; a label?
(let ((previous-definition (assoc instruction *symtab*)))
(cond
((null previous-definition)
(push (cons instruction *pc*)
*symtab*))
((assoc instruction new-corrections)
(break "prev-def ~S in new-corrections?? new: ~S, old: ~S"
instruction
*pc*
(cdr (assoc instruction new-corrections))))
((member previous-definition assumptions)
(setf (cdr previous-definition) *pc*)
(setf assumptions (delete previous-definition assumptions))
(push previous-definition new-corrections))
((member previous-definition corrections)
(cond
((> *pc* (cdr previous-definition))
;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
(setf (cdr previous-definition) *pc*)
(push previous-definition new-corrections))
((< *pc* (cdr previous-definition))
;; (break "Definition for ~S shrunk from ~S to ~S."
;; instruction
;; (cdr previous-definition)
;; *pc*)
(setf (cdr previous-definition) *pc*)
(push previous-definition new-corrections))))
(t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
instruction
(cdr previous-definition)
*pc*))))
nil)
(cons ; a bona fide instruction?
(let ((code (funcall encoder instruction)))
(incf *pc* (length code))
code)))))
(handler-bind
((unresolved-symbol (lambda (c)
(let ((a (cons (unresolved-symbol c) *pc*)))
;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
(push a assumptions)
(push a *symtab*)
(invoke-restart 'retry-symbol-resolve)))))
(let ((code (loop for instruction in proglist
for operands = (when (consp instruction)
instruction)
for operator = (when (consp instruction)
(let ((x (pop operands)))
(if (not (listp x)) x (pop operands))))
append (process-instruction instruction)
do (loop for operand in operands
do (when (sub-program-operand-p operand)
(push (cons (sub-program-label operand)
(sub-program-program operand))
sub-programs)))
when (and (not (null sub-programs))
(member operator *sub-program-instructions*))
append (loop for sub-program in (nreverse sub-programs)
append (mapcan #'process-instruction sub-program)
finally (setf sub-programs nil)))))
(cond
((not (null assumptions))
(error "Undefined symbol~P: ~{~S~^, ~}"
(length assumptions)
(mapcar #'car assumptions)))
((not (null new-corrections))
(assemble-proglist proglist
:symtab incoming-symtab
:start-pc start-pc
:cpu-package cpu-package
:corrections (nconc new-corrections corrections)))
(t (values code *symtab*))))))))
(defun instruction-operator (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cadr instruction)
(car instruction)))
(defun instruction-operands (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cddr instruction)
(cdr instruction)))
(defun instruction-modifiers (instruction)
(if (listp (car instruction))
(car instruction)
nil))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels)
"Return a proglist (i.e. a list of instructions), or a list of (cons instruction data) if collect-data is true,
data being the octets corresponding to that instruction. Labels will be included in the proglist if collect-labels is true.
Secondarily, return the symtab."
(let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
cpu-package))
(proglist0 (loop while code
collect pc
collect (multiple-value-bind (instruction new-code)
(funcall instruction-disassembler
code)
(when (eq code new-code)
(loop-finish))
(let* ((data (loop until (eq code new-code)
do (incf pc)
collect (pop code)))
(operands (instruction-operands instruction)))
(cons data
(if (notany #'pc-relative-operand-p operands)
instruction
(nconc (loop until (eq instruction operands)
collect (pop instruction))
(loop for operand in operands
collect (if (not (pc-relative-operand-p operand))
operand
(let* ((location (+ pc (pc-relative-operand-offset operand)))
(entry (or (rassoc location symtab)
(car (push (cons (gensym) location)
symtab)))))
`(quote ,(car entry)))))))))))))
(values (loop for (pc data-instruction) on proglist0 by #'cddr
for instruction = (cdr data-instruction)
for label = (when collect-labels
(rassoc pc symtab))
when label
collect (if (not collect-data)
(car label)
(cons nil (car label)))
collect (if (not collect-data)
instruction
data-instruction))
symtab)))
(defun disassemble-proglist* (code &key (cpu-package '#:asm-x86) (pc 0))
"Print a human-readable disassembly of code."
(multiple-value-bind (proglist symtab)
(disassemble-proglist code
:cpu-package cpu-package
:collect-data t)
(format t "~&~:{~4X: ~20<~{ ~2,'0X~}~;~> ~A~%~}"
(loop with pc = pc
for (data . instruction) in proglist
when (let ((x (find pc symtab :key #'cdr)))
(when x (list pc (list (format nil " ~A" (car x))) "")))
collect it
collect (list pc data instruction)
do (incf pc (length data))))))