-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathcode.lisp
254 lines (236 loc) · 9.74 KB
/
code.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
(cl:in-package #:cluster)
(defgeneric best-candidate-descriptor (code-command))
(defclass code-command (command)
((%mnemonic :initarg :mnemonic :reader mnemonic)
(%operands :initarg :operands :reader operands)))
(defun make-code-command (mnemonic operands)
(make-instance 'code-command
:mnemonic mnemonic
:operands operands))
(defmethod best-candidate-descriptor ((item code-command))
(let* ((operands (operands item))
(candidates (candidates (mnemonic item) operands)))
(when (null candidates)
(error "No candidate instruction for command ~s" item))
(flet ((best-candidate (c1 c2)
(if (and (= (length operands) 1)
(typep (first operands) 'label))
(if (> (instruction-size c1 operands)
(instruction-size c2 operands))
c1
c2)
(if (< (instruction-size c1 operands)
(instruction-size c2 operands))
c1
c2))))
(reduce #'best-candidate candidates))))
(defmethod compute-encoding ((item code-command))
(encode-instruction (best-candidate-descriptor item)
(operands item)))
;;; When the item is a CODE-COMMAND and it has a single operand of
;;; type LABEL, then the preliminary size is the MAXIMUM of the size
;;; of each candidate instruction. When the item is a CODE-COMMAND
;;; and it has some other operands then the preliminary size is the
;;; MINIMUM of the size of each candidate instruction.
(defmethod preliminary-size ((item code-command))
(let* ((operands (operands item))
(candidates (candidates (mnemonic item) operands)))
(when (null candidates)
(error "No candidate instruction for command ~s" item))
(reduce (if (and (= (length operands) 1)
(typep (first operands) 'label))
#'max
#'min)
(mapcar (lambda (desc)
(instruction-size desc operands))
candidates))))
(defmethod encode-instruction-1 (desc (operand immediate-operand))
(let ((type (first (encoding desc)))
(length (/ (second (first (operands desc))) 8)))
(ecase type
(imm
(let* ((rex-p (rex.w desc)))
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if rex-p '(#x48) '())
,@(opcodes desc)
,@(encode-integer (value operand) length)))))))
;;; A hash table mapping items to addresses relative to the
;;; beginning of the program.
(defparameter *addresses* nil)
;;; The address (relative to the beginning of the program) of the
;;; instruction immediately following the one being encoded.
(defparameter *instruction-pointer* nil)
(defmethod encode-instruction-1 (desc (operand label))
(let ((type (first (encoding desc))))
(ecase type
(label
(let* ((rex-p (rex.w desc)))
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if rex-p '(#x48) '())
,@(opcodes desc)
,@(encode-integer (- (gethash operand *addresses*)
*instruction-pointer*)
4)))))))
(defmethod encode-instruction-1 (desc (operand gpr-operand))
(let ((type (first (encoding desc))))
(ecase type
(modrm
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (rex.w desc)
(if (>= (code-number operand) 7)
'(#b01001001)
'(#b01001000))
(if (>= (code-number operand) 7)
'(#b01000001)
'()))
,@(opcodes desc)
,(+ #b11000000
(ash (opcode-extension desc) 3)
(mod (code-number operand) 8))))
(+r
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (rex.w desc)
(if (>= (code-number operand) 7)
'(#b01001001)
'(#b01001000))
(if (>= (code-number operand) 7)
'(#b01000001)
'()))
,(+ (first (opcodes desc))
(mod (code-number operand) 8)))))))
(defmethod encode-instruction-1 (desc (operand memory-operand))
(let ((type (first (encoding desc))))
(ecase type
(modrm
(destructuring-bind (rex.xb modrm &rest rest)
(encode-memory-operand operand)
(let ((rex-low (+ (if (rex.w desc) #b1000 0) rex.xb)))
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(logior modrm (ash (opcode-extension desc) 3))
,@rest)))))))
(defmethod encode-instruction-2
(desc (operand1 gpr-operand) (operand2 immediate-operand))
(multiple-value-bind (rex.b r/m)
(floor (code-number operand1) 8)
(let* ((rex-low (+ (if (rex.w desc) #b1000 0) rex.b)))
(let ((type1 (first (encoding desc)))
(type2 (second (encoding desc)))
(length2 (/ (second (second (operands desc))) 8)))
(ecase type1
(-
(ecase type2
(imm
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,@(encode-integer (value operand2) length2)))))
(modrm
(ecase type2
(imm
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(+ (ash #b11 6)
(ash (opcode-extension desc) 3)
r/m)
,@(encode-integer (value operand2) length2)))))
(+r
(ecase type2
(imm
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,(+ (car (opcodes desc)) r/m)
,@(encode-integer (value operand2) length2))))))))))
(defmethod encode-instruction-2
(desc (operand1 gpr-operand) (operand2 gpr-operand))
(assert (or (equal (encoding desc) '(reg modrm))
(equal (encoding desc) '(modrm reg))
(equal (encoding desc) '(- modrm))
(equal (encoding desc) '(modrm -))))
(when (equal (encoding desc) '(modrm reg))
(rotatef operand1 operand2))
(when (equal (encoding desc) '(modrm -))
(rotatef operand1 operand2))
(let ((type1 (first (encoding desc))))
(multiple-value-bind (rex.b r/m)
(floor (code-number operand2) 8)
(multiple-value-bind (rex.r reg)
(floor (code-number operand1) 8)
(let ((rex-low (+ (if (rex.w desc) #b1000 0)
(ash rex.r 2)
rex.b)))
(case type1
(-
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(+ (ash #b11 6)
(ash (opcode-extension desc) 3)
r/m)))
(t
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(+ #b11000000
(ash reg 3)
r/m)))))))))
(defmethod encode-instruction-2
(desc (operand1 gpr-operand) (operand2 memory-operand))
(assert (or (equal (encoding desc) '(reg modrm))
(equal (encoding desc) '(- modrm))))
(let ((type1 (first (encoding desc))))
(destructuring-bind (rex.xb modrm &rest rest)
(encode-memory-operand operand2)
(multiple-value-bind (rex.r reg)
(floor (code-number operand1) 8)
(let ((rex-low (+ (if (rex.w desc) #b1000 0)
rex.xb
(ash rex.r 2))))
(case type1
(-
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(logior modrm (ash (opcode-extension desc) 3))
,@rest))
(t
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(logior modrm (ash reg 3))
,@rest))))))))
(defmethod encode-instruction-2
(desc (operand1 memory-operand) (operand2 immediate-operand))
(assert (equal (encoding desc) '(modrm imm)))
(destructuring-bind (rex.xb modrm &rest rest)
(encode-memory-operand operand1)
(let ((rex-low (+ (if (rex.w desc) #b1000 0) rex.xb)))
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(logior modrm (ash (opcode-extension desc) 3))
,@rest
,@(encode-integer (value operand2)
(/ (second (second (operands desc))) 8))))))
(defmethod encode-instruction-2
(desc (operand1 memory-operand) (operand2 gpr-operand))
(assert (equal (encoding desc) '(modrm reg)))
(destructuring-bind (rex.xb modrm &rest rest)
(encode-memory-operand operand1)
(multiple-value-bind (rex.r reg)
(floor (code-number operand2) 8)
(let ((rex-low (+ (if (rex.w desc) #b1000 0)
rex.xb
(ash rex.r 2))))
`(,@(if (operand-size-override desc) '(#x66) '())
,@(if (plusp rex-low) `(,(+ #x40 rex-low)) '())
,@(opcodes desc)
,(logior modrm (ash reg 3))
,@rest)))))
(defun encode-instruction (desc operands)
(ecase (length operands)
(0 (opcodes desc))
(1 (encode-instruction-1 desc (first operands)))
(2 (encode-instruction-2 desc (first operands) (second operands)))))