/[movitz]/ia-x86/operands.lisp
ViewVC logotype

Contents of /ia-x86/operands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Dec 20 22:42:43 2007 UTC (6 years, 4 months ago) by ffjeld
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +19 -6 lines
Minor tweaks to printing instruction objects etc. Mostly related to testing the new assembler.
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 20012000, 2002-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway
5 ;;;;
6 ;;;; Filename: operands.lisp
7 ;;;; Description: Operand representation.
8 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
9 ;;;; Created at: Wed Feb 16 14:02:57 2000
10 ;;;; Distribution: See the accompanying file COPYING.
11 ;;;;
12 ;;;; $Id: operands.lisp,v 1.7 2007/12/20 22:42:43 ffjeld Exp $
13 ;;;;
14 ;;;;------------------------------------------------------------------
15
16 (in-package #:ia-x86)
17
18 ;;; ----------------------------------------------------------------
19 ;;; Operand types
20 ;;; ----------------------------------------------------------------
21
22 ;;; Operand types are identified by symbols
23
24 (defmacro def-operand-types (&rest ot-specs)
25 (list* 'cl:eval-when '(:load-toplevel)
26 (loop for (sym . properties) in ot-specs
27 append
28 `((setf ,@(loop for (p v) in properties
29 appending `((cl:get ',sym ',p) ,v)))
30 (import ',sym :ia-x86-instr)))))
31
32 (defun operand-type-property (sym p)
33 (get sym p))
34
35 (def-operand-types
36 (immediate (immediate t))
37 (displacement (immediate nil))
38 (imm32 (immediate t)
39 (bit-size 32)
40 (signed nil))
41 (imm16 (immediate t)
42 (bit-size 16)
43 (signed nil))
44 (imm8 (immediate t)
45 (bit-size 8)
46 (signed nil))
47 (simm32 (immediate t)
48 (bit-size 32)
49 (signed t))
50 (simm16 (immediate t)
51 (bit-size 16)
52 (signed t))
53 (simm8 (immediate t)
54 (bit-size 8)
55 (signed t))
56 (imm16-8 (immediate t)
57 (bit-size 16))
58 (imm8-0 (immediate t)
59 (bit-size 8))
60 (r32 (bit-size 32))
61 (r16 (bit-size 16))
62 (r8 (bit-size 8))
63 (+r32 (bit-size 32))
64 (+r16 (bit-size 16))
65 (+r8 (bit-size 8))
66 (m (bit-size 32)) ; memory poiner
67 (m64 (bit-size 64))
68 (mm (bit-size 64)) ; mmx register
69 (mm/m64 (immediate nil))
70 (mm/m32 (immediate nil))
71 (xmm (bit-size 128)) ; simd register
72 (xmm/m128) (xmm/m64) (xmm/m32)
73 (moffs8 (immediate nil)
74 (bit-size 8)
75 (signed nil))
76 (moffs16 (immediate nil)
77 (bit-size 16)
78 (signed nil))
79 (moffs32 (immediate nil)
80 (bit-size 32)
81 (signed nil))
82 (al (immediate nil)
83 (bit-size 8))
84 (ah (immediate nil)
85 (bit-size 8))
86 (ax (immediate nil)
87 (bit-size 16))
88 (eax (immediate nil)
89 (bit-size 32))
90 (ebx (immediate nil)
91 (bit-size 32))
92 (dx (immediate nil)
93 (bit-size 16))
94 (edx (immediate nil)
95 (bit-size 32))
96 (cr0) (cr2) (cr3) (cr4)
97 (dr0) (dr1) (dr2) (dr3)
98 (dr4) (dr5) (dr6) (dr7)
99 (ptr16-16 (immediate nil))
100 (ptr16-32 (immediate nil))
101 (m16-16 (immediate nil))
102 (m16-32 (immediate nil))
103 (m32real (immediate nil))
104 (m64real (immediate nil))
105 (m80real (immediate nil))
106 (m16int (immediate nil))
107 (m32int (immediate nil))
108 (m64int (immediate nil)))
109
110 ;;; ----------------------------------------------------------------
111 ;;; Operand Class
112 ;;; ----------------------------------------------------------------
113
114 (defclass operand () ())
115
116 (defclass concrete-operand (operand) ()
117 (:documentation "Operands that correspond directly
118 to one of the x86 operand adressing modes."))
119
120 (defclass abstract-operand (operand) ()
121 (:documentation "Operands that are not concrete, for example
122 symbolic references. Abstract operands need to be resolved to concrete
123 operands at encoding-time."))
124
125 (defmethod print-object ((obj concrete-operand) stream)
126 (format stream "~A" (operand-listform obj))
127 obj)
128
129 (defmethod print-object ((obj abstract-operand) stream)
130 (format stream "~A" (operand-listform obj))
131 obj)
132
133 ;;; ----------------------------------------------------------------
134 ;;; Abstract operands
135 ;;; ----------------------------------------------------------------
136
137 (defun abstract-operand-to-offset (operand template instr env)
138 (sign-extend (mod (- (operand-resolve-to-number operand env)
139 (assemble-env-current-pc env)
140 (template-instr-and-prefix-length template instr env))
141 #x100000000)
142 4))
143
144 (defclass operand-label (abstract-operand)
145 ((label
146 :type symbol
147 :initarg label
148 :accessor operand-label)
149 (user-size
150 :initarg user-size
151 :reader operand-user-size
152 :initform nil)))
153
154 (defmethod operand-user-size ((operand t)) nil)
155
156 (defmethod operand-listform ((operand operand-label))
157 (list* 'quote
158 (operand-label operand)
159 (operand-user-size operand)))
160
161 (defmethod operand-resolve-to-number ((operand operand-label) env)
162 (assert (not (null env)) ()
163 "Resolving ~A requires an assemble-environment." operand)
164 (symtab-lookup-label (assemble-env-symtab env)
165 (operand-label operand)))
166
167 (defclass calculated-operand (abstract-operand)
168 ((sub-operands
169 :initarg :sub-operands
170 :accessor sub-operands)
171 (calculation
172 :initarg :calculation
173 :reader operand-calculation)
174 (user-size
175 :initarg user-size
176 :reader operand-user-size
177 :initform nil)))
178
179 (defmethod operand-listform ((operand calculated-operand))
180 `(quote (:funcall ,(operand-calculation operand)
181 ,@(sub-operands operand))))
182
183
184 (defmethod operand-resolve-to-number ((operand calculated-operand) env)
185 (assert (not (null env)) ()
186 "Resolving ~A requires an assemble-environment." operand)
187 (apply (operand-calculation operand)
188 (mapcar #'operand-resolve-to-number
189 (sub-operands operand)
190 (let ((x (cons env nil)))
191 (setf (cdr x) x))))) ; make circular one-list.
192
193 (defclass operand-number (abstract-operand)
194 ((number
195 :type integer
196 :initarg number
197 :reader operand-number)))
198
199 (defmethod operand-listform ((operand operand-number))
200 (list* 'quote
201 (operand-number operand)))
202
203 (defmethod operand-resolve-to-number ((operand operand-number) env)
204 (declare (ignore env))
205 (operand-number operand))
206
207 ;;; ----------------------------------------------------------------
208 ;;; Concrete operands (modelling the "real world" x86 CPU)
209 ;;; ----------------------------------------------------------------
210
211 ;;; ----------------------------------------------------------------
212 ;;; Immediate
213 ;;; ----------------------------------------------------------------
214
215 (defclass operand-immediate (concrete-operand)
216 ((value
217 :initarg value
218 :accessor operand-value)))
219
220 (defmethod operand-listform ((obj operand-immediate))
221 (operand-value obj))
222
223 (defmethod print-object ((obj operand-immediate) stream)
224 (if (and (not *print-readably*)
225 *print-pretty*)
226 (progn
227 (format stream "~A" (slot-value obj 'value))
228 obj)
229 (call-next-method obj stream)))
230
231 ;;; ----------------------------------------------------------------
232 ;;; Register
233 ;;; ----------------------------------------------------------------
234
235 (defclass operand-register (concrete-operand)
236 ((register
237 :initarg register
238 :accessor operand-register)))
239
240 (defmethod operand-listform ((obj operand-register))
241 (operand-register obj))
242
243 (defmethod print-object ((obj operand-register) stream)
244 (if (and (not *print-readably*)
245 *print-pretty*)
246 (progn (format stream "%~A" (slot-value obj 'register))
247 obj)
248 (call-next-method obj stream)))
249
250 ;;; ----------------------------------------------------------------
251 ;;; Memory operands
252 ;;; ----------------------------------------------------------------
253
254 (defclass operand-memory (concrete-operand)
255 (referenced-size))
256
257 ;;; ----------------------------------------------------------------
258 ;;; Absolute Pointer
259 ;;; ----------------------------------------------------------------
260
261 (defclass operand-direct (operand-memory)
262 ((address :accessor operand-address
263 :initarg address)
264 (segment :accessor operand-segment
265 :initform nil
266 :initarg segment)))
267
268 (defmethod operand-listform ((obj operand-direct))
269 (if (null (operand-segment obj))
270 (list (operand-address obj))
271 (list (operand-segment obj)
272 (operand-address obj))))
273
274 (defmethod print-object ((obj operand-direct) stream)
275 (if (not *print-readably*)
276 (progn
277 (format stream "[~@[~A:~]~A]"
278 (operand-segment obj)
279 (operand-address obj))
280 obj)
281 (call-next-method obj stream)))
282
283 ;;; ----------------------------------------------------------------
284 ;;; PC-Relative Pointer
285 ;;; ----------------------------------------------------------------
286
287 (defclass operand-rel-pointer (operand-memory)
288 ((offset
289 :accessor operand-offset
290 :initarg offset)))
291
292 (defmethod operand-listform ((obj operand-rel-pointer))
293 (list :pc+ (operand-offset obj)))
294
295 (defmethod print-object ((obj operand-rel-pointer) stream)
296 (if (not *print-readably*)
297 (progn
298 (format stream "%PC+~A" (slot-value obj 'offset))
299 obj)
300 (call-next-method obj stream)))
301
302 ;;; ----------------------------------------------------------------
303 ;;; Register-Relative pointer
304 ;;; ----------------------------------------------------------------
305
306 (defclass operand-indirect-register (operand-memory)
307 ((register
308 :accessor operand-register
309 :initarg register)
310 (register2
311 :initform nil
312 :accessor operand-register2
313 :initarg register2)
314 (offset
315 :accessor operand-offset
316 :initarg offset
317 :initform 0)
318 (scale
319 :type (integer 0 8) ; scale for register (not register2)
320 :initarg scale
321 :accessor operand-scale
322 :initform 1)))
323
324 (defmethod operand-listform ((obj operand-indirect-register))
325 (with-slots (offset register scale register2)
326 obj
327 (append (cond
328 ((eql 0 offset)
329 nil)
330 ((typep offset '(cons (eql +)))
331 (mapcar (lambda (x)
332 (if (symbolp x)
333 `(quote ,x)
334 x))
335 (cdr offset)))
336 (t (list offset)))
337 (if (= 1 scale)
338 (list register)
339 (list (list register scale)))
340 (when register2
341 (list register2)))))
342
343 (defmethod print-object ((obj operand-indirect-register) stream)
344 (if *print-readably*
345 (call-next-method obj stream)
346 (with-slots (offset register2 register scale) obj
347 (format stream "[~@[~A+~]~@[%~A+~]%~A~@[*~D~]]"
348 (unless (and (integerp offset) (zerop offset))
349 offset)
350 register2
351 register
352 (when (> scale 1)
353 scale))
354 obj)))
355
356 (defun resolve-indirect-register (operand env)
357 (with-slots (register register2 offset scale) operand
358 (etypecase offset
359 (integer
360 operand)
361 (symbol
362 (make-instance 'operand-indirect-register
363 'offset (symtab-lookup-label (assemble-env-symtab env) offset)
364 'register register
365 'register2 register2
366 'scale scale))
367 (list
368 (make-instance 'operand-indirect-register
369 'offset (apply (car offset)
370 (mapcar #'(lambda (o)
371 (etypecase o
372 (integer o)
373 (symbol
374 (symtab-lookup-label (assemble-env-symtab env) o))))
375 (cdr offset)))
376 'register register
377 'register2 register2
378 'scale scale)))))
379
380 (defun resolve-direct (operand env)
381 (with-slots (address segment) operand
382 (if (not (symbolp address))
383 operand
384 (make-instance 'operand-direct
385 'address (symtab-lookup-label (assemble-env-symtab env) address)
386 'segment segment))))
387
388 ;;; ----------------------------------------------------------------
389 ;;; Definition of specialized operand classes
390 ;;; ----------------------------------------------------------------
391
392 (defvar *operand-classes* (make-hash-table :test #'equal))
393 (defvar *operand-encoding-by-type* (make-hash-table :test #'eq))
394
395 (defmacro def-operand-class ((operand-encoding operand-types
396 &optional (reg-set (first operand-types)))
397 (base-operand-class) slots)
398 (let ((name (intern (format nil "~A~S~{-~S~}" ; the name isn't really important
399 (symbol-name '#:operand-)
400 operand-encoding operand-types))))
401 `(progn
402 (assert (subtypep (find-class ',base-operand-class)
403 (find-class 'operand))
404 ()
405 "Base operand-class ~A is not an OPERAND class." ',base-operand-class)
406 (defclass ,name (,base-operand-class) ,slots)
407 (defmethod operand-class-register-set ((operand-encoding (eql (find-class ',name))))
408 (values ',reg-set))
409 (defmethod operand-class-encoding ((operand-encoding (eql (find-class ',name))))
410 (values ',operand-encoding))
411 (defmethod operand-class-base-class ((operand-class (eql (find-class ',name))))
412 (values (find-class ',base-operand-class)))
413 ,@(loop for ot in operand-types
414 appending
415 `((setf (gethash (cons ',operand-encoding ',ot) *operand-classes*)
416 (find-class ',name))
417 (pushnew ',operand-encoding
418 (gethash ',ot *operand-encoding-by-type*)))))))
419
420 (eval-when (:compile-toplevel :load-toplevel :execute)
421 (defparameter +operand-types-indirect-modrm+
422 '(r/m8 r/m16 r/m32 m m64
423 mm/m64 mm/m32
424 xmm/m128 xmm/m64 xmm/m32
425 m32real m64real m80real
426 m16int m32int m64int
427 m16-16 m16-32)
428 "This set of operand-types are pointers which are encoded the same way,
429 but differ in only in what they point to."))
430
431 (defmacro def-operand-class-imodrm ((operand-encoding
432 &optional (reg-set nil))
433 (base-operand-class) slots)
434 `(def-operand-class (,operand-encoding ,+operand-types-indirect-modrm+ ,reg-set)
435 (,base-operand-class) ,slots))
436
437
438 (defun find-operand-class (operand-encoding operand-type &key (errorp t))
439 "Locate the operand class that encodes <operand-type> into <operand-encoding>."
440 (let ((oc (gethash (cons operand-encoding operand-type) *operand-classes*)))
441 (unless (or oc (not errorp))
442 (error "couldn't find operand-class for (~A ~A)." operand-encoding operand-type))
443 (values oc)))
444
445 (defun find-operand-type-encodings (operand-type)
446 (gethash operand-type *operand-encoding-by-type*))
447
448 (defmethod operand-decode (operand (encoding (eql nil)) instr-symbolic)
449 "Fallback when no operand-encoding was specified."
450 (if (operand-class-encoding (class-of operand))
451 (operand-decode operand (operand-class-encoding (class-of operand)) instr-symbolic)
452 (call-next-method operand encoding instr-symbolic)))
453
454
455 ;;; ----------------------------------------------------------------
456 ;;; Operand unification
457 ;;; ----------------------------------------------------------------
458
459 (defgeneric operand-and-encoding-unifies-p (operand encoding operand-type)
460 (:documentation "This predicate determines if an operand instance may
461 be encoded in a particular encoding and operand-type."))
462
463 (defmethod operand-and-encoding-unifies-p (operand encoding operand-type)
464 "If no specialized method exists, the operand and encoding don't unify."
465 (declare (ignore operand encoding operand-type))
466 (values nil))
467
468 (defun operand-unifies-with (operand operand-type)
469 "Return a list of all encodings this operand unifies with."
470 (loop for encoding in (find-operand-type-encodings operand-type)
471 when (operand-and-encoding-unifies-p operand encoding operand-type)
472 collect encoding))
473
474
475
476 (defgeneric operand-and-encoding-unify (operand encoding operand-type template instr env)
477 (:documentation "If OPERAND cannot be encoded in ENCODING and
478 OPERAND-TYPE, NIL is returned. Otherwise, a concretized OPERAND
479 is returned (if OPERAND is concrete, the same operand is typically
480 returned."))
481
482 (defmethod operand-and-encoding-unify (operand encoding operand-type template instr env)
483 "If no specialized method exists, the operand and encoding don't unify."
484 (declare (ignore operand encoding operand-type template instr env))
485 (values nil))
486
487 ;;; ----------------------------------------------------------------
488 ;;; General, plain operand classes
489 ;;; ----------------------------------------------------------------
490
491 ;;; Displacement
492
493 (def-operand-class (plain-displacement (displacement)) (operand-direct) ())
494
495 (defmethod operand-and-encoding-unify ((operand operand-direct)
496 (encoding (eql 'plain-displacement))
497 operand-type
498 template instr
499 env)
500 (declare (ignore operand-type instr))
501 (let ((resolved-operand (resolve-direct operand env)))
502 (with-slots (address segment)
503 resolved-operand
504 (and (null segment)
505 (<= 0 address (expt 2 (* 8 (template-instr-displacement-numo template))))
506 resolved-operand))))
507
508 (defmethod operand-decode ((operand operand-direct)
509 (encoding (eql 'plain-displacement))
510 instr-symbolic)
511 (setf (operand-address operand)
512 (slot-value instr-symbolic 'displacement))
513 (values operand))
514
515 (defmethod operand-encode ((operand operand-direct)
516 (encoding (eql 'plain-displacement))
517 operand-type
518 instr-symbolic)
519 (declare (ignore operand-type))
520 (setf (slot-value instr-symbolic 'displacement)
521 (operand-address operand))
522 (values instr-symbolic '(displacement)))
523
524 ;;; Immediate
525
526 ;;;(def-operand-class (plain-immediate (immediate)) (operand-immediate) ())
527 ;;;
528 ;;;(defmethod operand-and-encoding-unify ((operand operand-immediate)
529 ;;; (encoding (eql 'plain-immediate))
530 ;;; operand-type
531 ;;; template instr
532 ;;; env)
533 ;;; (declare (ignore operand-type instr env))
534 ;;; (with-slots (value)
535 ;;; operand
536 ;;; (and (<= 0 value (expt 2 (* 8 (template-instr-immediate-numo template))))
537 ;;; operand)))
538 ;;;
539 ;;;(defmethod operand-decode ((operand operand-immediate)
540 ;;; (encoding (eql 'plain-immediate))
541 ;;; instr-symbolic)
542 ;;; (setf (operand-value operand)
543 ;;; (slot-value instr-symbolic 'immediate))
544 ;;; (values operand))
545 ;;;
546 ;;;(defmethod operand-encode ((operand operand-immediate)
547 ;;; (encoding (eql 'plain-immediate))
548 ;;; operand-type
549 ;;; instr-symbolic)
550 ;;; (declare (ignore operand-type))
551 ;;; (setf (slot-value instr-symbolic 'immediate)
552 ;;; (operand-value operand))
553 ;;; (values instr-symbolic '(immediate)))
554
555
556 ;;; ----------------------------------------------------------------
557 ;;; Specialized operand classes
558 ;;; ----------------------------------------------------------------
559
560
561 ;;; Direct register operands encoded in the REG of MODR/M.
562
563 (def-operand-class (register-reg (r8)) (operand-register) ())
564 (def-operand-class (register-reg (r16)) (operand-register) ())
565 (def-operand-class (register-reg (r32)) (operand-register) ())
566 (def-operand-class (register-reg (sreg)) (operand-register) ())
567 (def-operand-class (register-reg (mm)) (operand-register) ()) ; MMX
568 (def-operand-class (register-reg (xmm)) (operand-register) ()) ; SIMD
569
570 (defmethod operand-and-encoding-unify ((operand operand-register)
571 (encoding (eql 'register-reg))
572 operand-type
573 template instr
574 env)
575 (declare (ignore template instr env))
576 (and (decode-set (find-register-encode-set operand-type)
577 (slot-value operand 'register)
578 :errorp nil)
579 operand))
580
581 (defmethod operand-decode ((operand operand-register)
582 (encoding (eql 'register-reg))
583 instr-symbolic)
584 (setf (operand-register operand)
585 (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
586 (slot-value instr-symbolic 'reg)))
587 (assert (not (null (operand-register operand)))
588 ((operand-register operand))
589 "Unable to decode operand value ~A from set ~A"
590 (slot-value instr-symbolic 'reg)
591 (find-register-decode-set (operand-class-register-set (class-of operand))))
592 (values operand))
593
594 (defmethod operand-encode ((operand operand-register)
595 (encoding (eql 'register-reg))
596 operand-type
597 instr-symbolic)
598 (setf (slot-value instr-symbolic 'reg)
599 (decode-set (find-register-encode-set operand-type)
600 (operand-register operand)))
601 (values instr-symbolic '(reg)))
602
603
604 ;;; Direct register operands encoded in the R/M of of MODR/M.
605
606 (def-operand-class (register-r/m (r/m8)) (operand-register) ())
607 (def-operand-class (register-r/m (r/m16)) (operand-register) ())
608 (def-operand-class (register-r/m (r/m32)) (operand-register) ())
609 (def-operand-class (register-r/m (mm/m64)) (operand-register) ()) ; MMX
610 (def-operand-class (register-r/m (xmm/m128 xmm/m64 xmm/m32)) (operand-register) ()) ; SIMD
611
612 (defmethod operand-and-encoding-unify ((operand operand-register)
613 (encoding (eql 'register-r/m))
614 operand-type
615 template instr
616 env)
617 (declare (ignore template instr env))
618 (and (decode-set (find-register-encode-set operand-type)
619 (slot-value operand 'register)
620 :errorp nil)
621 operand))
622
623 (defmethod operand-decode ((operand operand-register)
624 (encoding (eql 'register-r/m))
625 instr-symbolic)
626 (assert (= #b11 (slot-value instr-symbolic 'mod)))
627 (setf (operand-register operand)
628 (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
629 (slot-value instr-symbolic 'r/m)))
630 (values operand))
631
632 (defmethod operand-encode ((operand operand-register)
633 (encoding (eql 'register-r/m))
634 operand-type
635 instr-symbolic)
636 (with-slots (mod r/m)
637 instr-symbolic
638 (setf mod #b11
639 r/m (decode-set (find-register-encode-set operand-type)
640 (slot-value operand 'register))))
641 (values instr-symbolic '(mod r/m)))
642
643
644 ;;; Indirect register operand encoded in R/M,
645 ;;; with Mod=00 and R/M /= {#b100, #b101}
646
647 (def-operand-class-imodrm (indirect-register-mod00) (operand-indirect-register) ())
648
649 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
650 (encoding (eql 'indirect-register-mod00))
651 operand-type
652 template instr
653 env)
654 (declare (ignore template instr))
655 (let ((resolved-operand (resolve-indirect-register operand env)))
656 (with-slots (offset register register2 scale)
657 resolved-operand
658 (and (member operand-type +operand-types-indirect-modrm+)
659 (zerop offset)
660 (not register2)
661 (= 1 scale)
662 (member register '(eax ecx edx ebx esi edi))
663 resolved-operand))))
664
665 (defmethod operand-decode ((operand operand-indirect-register)
666 (encoding (eql 'indirect-register-mod00))
667 instr-symbolic)
668 (assert (= #b00 (slot-value instr-symbolic 'mod)))
669 (assert (/= #b100 #b101 (slot-value instr-symbolic 'r/m)))
670 (with-slots (register register2 offset scale)
671 operand
672 (setf register (decode-set (find-register-decode-set 'r/m32-00)
673 (slot-value instr-symbolic 'r/m))
674 register2 nil
675 offset 0
676 scale 1))
677 (values operand))
678
679 (defmethod operand-encode ((operand operand-indirect-register)
680 (encoding (eql 'indirect-register-mod00))
681 operand-type
682 instr-symbolic)
683 (declare (ignore operand-type))
684 (with-slots (mod r/m)
685 instr-symbolic
686 (setf mod #b00
687 r/m (decode-set (find-register-encode-set 'r/m32-00)
688 (slot-value operand 'register))))
689 (values instr-symbolic '(mod r/m)))
690
691
692 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
693 ;;; and neither index=#b100 nor base=#b101 in SIB.
694
695 (def-operand-class-imodrm (indirect-register-00-sib) (operand-indirect-register) ())
696
697 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
698 (encoding (eql 'indirect-register-00-sib))
699 operand-type
700 template instr
701 env)
702 (declare (ignore template instr))
703 (let ((resolved-operand (resolve-indirect-register operand env)))
704 (with-slots (register register2 offset scale)
705 resolved-operand
706 (and (member operand-type +operand-types-indirect-modrm+)
707 (zerop offset)
708 (member register '(eax ecx edx ebx ebp esi edi))
709 (member register2 '(eax ecx edx ebx esp esi edi))
710 (member scale '(1 2 4 8))
711 resolved-operand))))
712
713 (defmethod operand-decode ((operand operand-indirect-register)
714 (encoding (eql 'indirect-register-00-sib))
715 instr-symbolic)
716 (assert (= #b00 (slot-value instr-symbolic 'mod)))
717 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
718 (assert (/= #b100 (slot-value instr-symbolic 'index)))
719 (assert (/= #b101 (slot-value instr-symbolic 'base)))
720 (with-slots (register register2 offset scale)
721 operand
722 (setf register2 (decode-set (find-register-decode-set 'sib-base-00)
723 (slot-value instr-symbolic 'base))
724 register (decode-set (find-register-decode-set 'sib-index)
725 (slot-value instr-symbolic 'index))
726 scale (expt 2 (slot-value instr-symbolic 'scale))
727 offset 0))
728 (values operand))
729 (defmethod operand-encode ((operand operand-indirect-register)
730 (encoding (eql 'indirect-register-00-sib))
731 operand-type
732 instr-symbolic)
733 (declare (ignore operand-type))
734 (with-slots (mod r/m base index scale)
735 instr-symbolic
736 (setf mod #b00
737 r/m #b100
738 base (decode-set (find-register-encode-set 'sib-base-00)
739 (slot-value operand 'register2))
740 index (decode-set (find-register-encode-set 'sib-index)
741 (slot-value operand 'register))
742 scale (cdr (assoc (slot-value operand 'scale)
743 '((0 . 0) (1 . 0) (2 . 1) (4 . 2) (8 . 3))))))
744 (values instr-symbolic '(base index scale)))
745
746 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
747 ;;; and base=#b101 and index/=#b100 in SIB.
748
749 (def-operand-class-imodrm (indirect-register-00-sib-base5) (operand-indirect-register) ())
750
751 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
752 (encoding (eql 'indirect-register-00-sib-base5))
753 operand-type
754 template instr
755 env)
756 (declare (ignore template instr))
757 (assert (member operand-type +operand-types-indirect-modrm+))
758 (let ((resolved-operand (resolve-indirect-register operand env)))
759 (with-slots (register register2 scale)
760 resolved-operand
761 (and (not register2)
762 (member register '(eax ecx edx ebx ebp esi edi))
763 (member scale '(1 2 4 8))
764 resolved-operand))))
765
766 (defmethod operand-decode ((operand operand-indirect-register)
767 (encoding (eql 'indirect-register-00-sib-base5))
768 instr-symbolic)
769 (assert (= #b00 (slot-value instr-symbolic 'mod)))
770 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
771 (assert (= #b101 (slot-value instr-symbolic 'base)))
772 (assert (/= #b100 (slot-value instr-symbolic 'index)))
773 (with-slots (register register2 offset scale)
774 operand
775 (setf register (decode-set (find-register-decode-set 'sib-index)
776 (slot-value instr-symbolic 'index))
777 register2 nil
778 offset (realpart (slot-value instr-symbolic 'displacement))
779 scale (expt 2 (slot-value instr-symbolic 'scale))))
780 (values operand))
781 (defmethod operand-encode ((operand operand-indirect-register)
782 (encoding (eql 'indirect-register-00-sib-base5))
783 operand-type
784 instr-symbolic)
785 (declare (ignore operand-type))
786 (with-slots (mod r/m base index scale displacement)
787 instr-symbolic
788 (setf mod #b00
789 r/m #b100
790 base #b101
791 index (decode-set (find-register-encode-set 'sib-index)
792 (slot-value operand 'register))
793 scale (1- (integer-length (slot-value operand 'scale)))
794 displacement (realpart (slot-value operand 'offset))))
795 (values instr-symbolic '(mod r/m base index scale)))
796
797
798 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
799 ;;; and base/=#b101 and index=#b100 in SIB.
800
801 (def-operand-class-imodrm (indirect-register-00-sib-index4) (operand-indirect-register) ())
802
803 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
804 (encoding (eql 'indirect-register-00-sib-index4))
805 operand-type
806 template instr
807 env)
808 (declare (ignore template instr))
809 (assert (member operand-type +operand-types-indirect-modrm+))
810 (let ((resolved-operand (resolve-indirect-register operand env)))
811 (with-slots (register register2 offset scale)
812 resolved-operand
813 (and register
814 (zerop offset)
815 (null register2)
816 (= 1 scale)
817 (member register '(eax ecx edx ebx esp esi edi))
818 resolved-operand))))
819
820 (defmethod operand-decode ((operand operand-indirect-register)
821 (encoding (eql 'indirect-register-00-sib-index4))
822 instr-symbolic)
823 (assert (= #b00 (slot-value instr-symbolic 'mod)))
824 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
825 (assert (= #b100 (slot-value instr-symbolic 'index)))
826 (assert (/= #b101 (slot-value instr-symbolic 'base)))
827 (with-slots (register offset scale)
828 operand
829 (setf register (decode-set (find-register-decode-set 'sib-base-00)
830 (slot-value instr-symbolic 'base))
831 offset 0
832 scale 1))
833 (values operand))
834
835 (defmethod operand-encode ((operand operand-indirect-register)
836 (encoding (eql 'indirect-register-00-sib-index4))
837 operand-type
838 instr-symbolic)
839 (declare (ignore operand-type))
840 (with-slots (mod r/m index base scale)
841 instr-symbolic
842 (setf mod #b00
843 r/m #b100
844 index #b100
845 base (decode-set (find-register-encode-set 'sib-base-00)
846 (slot-value operand 'register))
847 scale 0))
848 (values instr-symbolic '(mod r/m index base scale)))
849
850
851 ;;; Indirect pointer with MOD=#b00, R/M=#b100 in ModR/M
852 ;;; and base=#b101 and index=#b100 in SIB.
853
854 (def-operand-class-imodrm (indirect-pointer-00-sib-index4-base5) (operand-direct) ())
855
856 (defmethod operand-and-encoding-unify ((operand operand-direct)
857 (encoding (eql 'indirect-pointer-00-sib-index4-base5))
858 operand-type
859 template instr
860 env)
861 (declare (ignore template instr))
862 (let ((resolved-operand (resolve-direct operand env)))
863 (assert (member operand-type +operand-types-indirect-modrm+))
864 (and (null (slot-value resolved-operand 'segment))
865 resolved-operand)))
866
867 (defmethod operand-decode ((operand operand-direct)
868 (encoding (eql 'indirect-pointer-00-sib-index4-base5))
869 instr-symbolic)
870 (assert (= #b00 (slot-value instr-symbolic 'mod)))
871 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
872 (assert (= #b101 (slot-value instr-symbolic 'base)))
873 (assert (= #b100 (slot-value instr-symbolic 'index)))
874 (setf (slot-value operand 'address)
875 (realpart (slot-value instr-symbolic 'displacement)))
876 (values operand))
877
878 (defmethod operand-encode ((operand operand-direct)
879 (encoding (eql 'indirect-pointer-00-sib-index4-base5))
880 operand-type
881 instr-symbolic)
882 (declare (ignore operand-type))
883 (with-slots (mod r/m base index scale displacement)
884 instr-symbolic
885 (setf mod #b00
886 r/m #b100
887 base #b101
888 index #b100
889 scale 0 ; don't care
890 displacement (slot-value operand 'address)))
891 (values instr-symbolic '(mod r/m base index displacement)))
892
893 ;;; Indirect pointer with MOD=#b00, R/M=#b101 in ModR/M
894
895 (def-operand-class-imodrm (indirect-pointer-00) (operand-direct) ())
896
897 (defmethod operand-and-encoding-unify ((operand operand-direct)
898 (encoding (eql 'indirect-pointer-00))
899 operand-type
900 template instr
901 env)
902 (declare (ignore template instr))
903 (assert (member operand-type +operand-types-indirect-modrm+))
904 (let ((resolved-operand (resolve-direct operand env)))
905 (and (null (slot-value resolved-operand 'segment))
906 resolved-operand)))
907
908 (defmethod operand-decode ((operand operand-direct)
909 (encoding (eql 'indirect-pointer-00))
910 instr-symbolic)
911 (assert (= #b00 (slot-value instr-symbolic 'mod)))
912 (assert (= #b101 (slot-value instr-symbolic 'r/m)))
913 (setf (slot-value operand 'address)
914 (realpart (slot-value instr-symbolic 'displacement)))
915 (values operand))
916
917 (defmethod operand-encode ((operand operand-direct)
918 (encoding (eql 'indirect-pointer-00))
919 operand-type
920 instr-symbolic)
921 (declare (ignore operand-type))
922 (with-slots (mod r/m displacement)
923 instr-symbolic
924 (setf mod #b00
925 r/m #b101
926 displacement (realpart (slot-value operand 'address))))
927 (values instr-symbolic '(mod r/m displacement)))
928
929
930 ;;; Indirect register with MOD=#b01, R/M/=#b100 in ModR/M.
931
932 (def-operand-class-imodrm (indirect-register-01) (operand-indirect-register) ())
933
934 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
935 (encoding (eql 'indirect-register-01))
936 operand-type
937 template instr
938 env)
939 (declare (ignore template instr))
940 (assert (member operand-type +operand-types-indirect-modrm+))
941 (let ((resolved-operand (resolve-indirect-register operand env)))
942 (with-slots (register register2 offset scale)
943 resolved-operand
944 (and (= 1 scale)
945 (member register '(eax ecx edx ebx ebp esi edi))
946 (not register2)
947 (<= -128 offset 127)
948 resolved-operand))))
949
950 (defmethod operand-decode ((operand operand-indirect-register)
951 (encoding (eql 'indirect-register-01))
952 instr-symbolic)
953 (assert (= #b01 (slot-value instr-symbolic 'mod)))
954 (assert (/= #b100 (slot-value instr-symbolic 'r/m)))
955 (with-slots (mod r/m displacement)
956 instr-symbolic
957 (with-slots (register offset)
958 operand
959 (setf register (decode-set (find-register-decode-set 'r/m32-01)
960 r/m)
961 offset (realpart displacement))))
962 (values operand))
963
964 (defmethod operand-encode ((operand operand-indirect-register)
965 (encoding (eql 'indirect-register-01))
966 operand-type
967 instr-symbolic)
968 (declare (ignore operand-type))
969 (with-slots (mod r/m displacement)
970 instr-symbolic
971 (setf mod #b01
972 r/m (decode-set (find-register-encode-set 'r/m32-01)
973 (slot-value operand 'register))
974 displacement (realpart (slot-value operand 'offset))))
975 (values instr-symbolic '(mod r/m displacement)))
976
977 ;;; Indirect register with MOD=#b01, R/M=#b100 in ModR/M,
978 ;;; index/=#b100 in SIB.
979
980 (def-operand-class-imodrm (indirect-register-01-sib) (operand-indirect-register) ())
981
982 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
983 (encoding (eql 'indirect-register-01-sib))
984 operand-type
985 template instr
986 env)
987 (declare (ignore template instr))
988 (assert (member operand-type +operand-types-indirect-modrm+))
989 (let ((resolved-operand (resolve-indirect-register operand env)))
990 (with-slots (register register2 offset scale)
991 resolved-operand
992 (cond
993 ((and (member register '(eax ecx edx ebx ebp esi edi))
994 (member register2 '(eax ecx edx ebx esp ebp esi edi))
995 (member scale '(1 2 4 8) :test #'=)
996 (<= -128 offset 127))
997 resolved-operand)
998 ((and (member register2 '(eax ecx edx ebx ebp esi edi))
999 (member register '(eax ecx edx ebx esp ebp esi edi))
1000 (= scale 1)
1001 (<= -128 offset 127))
1002 ;; exchange register and register2
1003 (make-instance 'operand-indirect-register
1004 'offset offset
1005 'register register2
1006 'register2 register
1007 'scale 1))
1008 (t nil)))))
1009
1010 (defmethod operand-decode ((operand operand-indirect-register)
1011 (encoding (eql 'indirect-register-01-sib))
1012 instr-symbolic)
1013 (assert (= #b01 (slot-value instr-symbolic 'mod)))
1014 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1015 (assert (/= #b100 (slot-value instr-symbolic 'index)))
1016 (with-slots (register register2 scale offset)
1017 operand
1018 (setf register (decode-set (find-register-decode-set 'sib-index)
1019 (slot-value instr-symbolic 'index))
1020 scale (expt 2 (slot-value instr-symbolic 'scale))
1021 register2 (decode-set (find-register-decode-set 'sib-base)
1022 (slot-value instr-symbolic 'base))
1023 offset (realpart (slot-value instr-symbolic 'displacement)))) ; disp8
1024 (values operand))
1025
1026
1027 (defmethod operand-encode ((operand operand-indirect-register)
1028 (encoding (eql 'indirect-register-01-sib))
1029 operand-type
1030 instr-symbolic)
1031 (declare (ignore operand-type))
1032 (with-slots (mod r/m scale index base displacement)
1033 instr-symbolic
1034 (setf mod #b01
1035 r/m #b100
1036 index (decode-set (find-register-encode-set 'sib-index)
1037 (slot-value operand 'register))
1038 scale (1- (integer-length (slot-value operand 'scale)))
1039 base (decode-set (find-register-encode-set 'sib-base)
1040 (slot-value operand 'register2))
1041 displacement (slot-value operand 'offset)))
1042 (values instr-symbolic '(mod r/m scale index base displacement)))
1043
1044
1045 ;;; Indirect register with MOD=#b01, R/M=#b100 in ModR/M,
1046 ;;; index=#b100 in SIB.
1047
1048 (def-operand-class-imodrm (indirect-register-01-sib-index4) (operand-indirect-register) ())
1049
1050 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1051 (encoding (eql 'indirect-register-01-sib-index4))
1052 operand-type
1053 template instr
1054 env)
1055 (declare (ignore template instr))
1056 (assert (member operand-type +operand-types-indirect-modrm+))
1057 (let ((resolved-operand (resolve-indirect-register operand env)))
1058 (with-slots (register register2 offset scale)
1059 resolved-operand
1060 (and (member register '(eax ecx edx ebx esp ebp esi edi))
1061 (not register2)
1062 (<= -128 offset 127)
1063 (= 1 scale)
1064 resolved-operand))))
1065
1066 (defmethod operand-decode ((operand operand-indirect-register)
1067 (encoding (eql 'indirect-register-01-sib-index4))
1068 instr-symbolic)
1069 (assert (= #b01 (slot-value instr-symbolic 'mod)))
1070 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1071 (assert (= #b100 (slot-value instr-symbolic 'index)))
1072 (with-slots (register offset scale)
1073 operand
1074 (setf register (decode-set (find-register-decode-set 'sib-base)
1075 (slot-value instr-symbolic 'base))
1076 offset (realpart (slot-value instr-symbolic 'displacement))
1077 scale 1))
1078 (values operand))
1079
1080 (defmethod operand-encode ((operand operand-indirect-register)
1081 (encoding (eql 'indirect-register-01-sib-index4))
1082 operand-type
1083 instr-symbolic)
1084 (declare (ignore operand-type))
1085 (with-slots (mod r/m index base scale displacement)
1086 instr-symbolic
1087 (setf mod #b01
1088 r/m #b100
1089 index #b100
1090 base (decode-set (find-register-encode-set 'sib-base)
1091 (slot-value operand 'register))
1092 scale 0 ; don't care
1093 displacement (slot-value operand 'offset)))
1094 (values instr-symbolic '(mod r/m index base scale displacement)))
1095
1096
1097 ;;; Indirect register with MOD=#b10, R/M/=#b100 in ModR/M.
1098
1099 (def-operand-class-imodrm (indirect-register-10) (operand-indirect-register) ())
1100
1101 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1102 (encoding (eql 'indirect-register-10))
1103 operand-type
1104 template instr
1105 env)
1106 (declare (ignore template instr))
1107 (assert (member operand-type +operand-types-indirect-modrm+))
1108 (let ((resolved-operand (resolve-indirect-register operand env)))
1109 (with-slots (register register2 offset scale)
1110 resolved-operand
1111 (and (= 1 scale)
1112 (member register '(eax ecx edx ebx ebp esi edi))
1113 (not register2)
1114 (<= #x-80000000 offset #xffffffff)
1115 resolved-operand))))
1116
1117 (defmethod operand-decode ((operand operand-indirect-register)
1118 (encoding (eql 'indirect-register-10))
1119 instr-symbolic)
1120 (assert (= #b10 (slot-value instr-symbolic 'mod)))
1121 (assert (/= #b100 (slot-value instr-symbolic 'r/m)))
1122 (with-slots (mod r/m displacement)
1123 instr-symbolic
1124 (with-slots (register offset)
1125 operand
1126 (setf register (decode-set (find-register-decode-set 'r/m32-01)
1127 r/m)
1128 offset (realpart displacement))))
1129 (values operand))
1130 (defmethod operand-encode ((operand operand-indirect-register)
1131 (encoding (eql 'indirect-register-10))
1132 operand-type
1133 instr-symbolic)
1134 (declare (ignore operand-type))
1135 (with-slots (mod r/m displacement)
1136 instr-symbolic
1137 (setf mod #b10
1138 r/m (decode-set (find-register-encode-set 'r/m32-01)
1139 (slot-value operand 'register))
1140 displacement (realpart (slot-value operand 'offset))))
1141 (values instr-symbolic '(mod r/m displacement)))
1142
1143 ;;; Indirect register with MOD=#b10, R/M=#b100 in ModR/M,
1144 ;;; index/=#b100 in SIB.
1145
1146 (def-operand-class-imodrm (indirect-register-10-sib) (operand-indirect-register) ())
1147
1148 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1149 (encoding (eql 'indirect-register-10-sib))
1150 operand-type
1151 template instr
1152 env)
1153 (declare (ignore template instr))
1154 (assert (member operand-type +operand-types-indirect-modrm+))
1155 (let ((resolved-operand (resolve-indirect-register operand env)))
1156 (with-slots (register register2 offset scale)
1157 resolved-operand
1158 (and (member register '(eax ecx edx ebx ebp esi edi))
1159 (member register2 '(eax ecx edx ebx esp ebp esi edi))
1160 (member scale '(1 2 4 8))
1161 (<= #x-80000000 offset #xffffffff)
1162 resolved-operand))))
1163
1164 (defmethod operand-decode ((operand operand-indirect-register)
1165 (encoding (eql 'indirect-register-10-sib))
1166 instr-symbolic)
1167 (assert (= #b10 (slot-value instr-symbolic 'mod)))
1168 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1169 (assert (/= #b100 (slot-value instr-symbolic 'index)))
1170 (with-slots (register register2 scale offset)
1171 operand
1172 (setf register (decode-set (find-register-decode-set 'sib-index)
1173 (slot-value instr-symbolic 'index))
1174 scale (expt 2 (slot-value instr-symbolic 'scale))
1175 register2 (decode-set (find-register-decode-set 'sib-base)
1176 (slot-value instr-symbolic 'base))
1177 offset (realpart (slot-value instr-symbolic 'displacement)))) ; disp8
1178 (values operand))
1179
1180
1181 (defmethod operand-encode ((operand operand-indirect-register)
1182 (encoding (eql 'indirect-register-10-sib))
1183 operand-type
1184 instr-symbolic)
1185 (declare (ignore operand-type))
1186 (with-slots (mod r/m scale index base displacement)
1187 instr-symbolic
1188 (setf mod #b10
1189 r/m #b100
1190 index (decode-set (find-register-encode-set 'sib-index)
1191 (slot-value operand 'register))
1192 scale (1- (integer-length (slot-value operand 'scale)))
1193 base (decode-set (find-register-encode-set 'sib-base)
1194 (slot-value operand 'register2))
1195 displacement (slot-value operand 'offset)))
1196 (values instr-symbolic '(mod r/m scale index base displacement)))
1197
1198 ;;; Indirect register with MOD=#b10, R/M=#b100 in ModR/M,
1199 ;;; index=#b100 in SIB.
1200
1201 (def-operand-class-imodrm (indirect-register-10-sib-index4) (operand-indirect-register) ())
1202
1203 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1204 (encoding (eql 'indirect-register-10-sib-index4))
1205 operand-type
1206 template instr
1207 env)
1208 (declare (ignore template instr))
1209 (assert (member operand-type +operand-types-indirect-modrm+))
1210 (let ((resolved-operand (resolve-indirect-register operand env)))
1211 (with-slots (register register2 offset scale)
1212 resolved-operand
1213 (and (member register '(eax ecx edx ebx esp ebp esi edi))
1214 (not register2)
1215 (<= #x-80000000 offset #xffffffff)
1216 (= 1 scale)
1217 resolved-operand))))
1218
1219 (defmethod operand-decode ((operand operand-indirect-register)
1220 (encoding (eql 'indirect-register-10-sib-index4))
1221 instr-symbolic)
1222 (assert (= #b10 (slot-value instr-symbolic 'mod)))
1223 (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1224 (assert (= #b100 (slot-value instr-symbolic 'index)))
1225 (with-slots (register offset scale)
1226 operand
1227 (setf register (decode-set (find-register-decode-set 'sib-base)
1228 (slot-value instr-symbolic 'base))
1229 offset (realpart (slot-value instr-symbolic 'displacement))
1230 scale 1))
1231 (values operand))
1232
1233 (defmethod operand-encode ((operand operand-indirect-register)
1234 (encoding (eql 'indirect-register-10-sib-index4))
1235 operand-type
1236 instr-symbolic)
1237 (declare (ignore operand-type))
1238 (with-slots (mod r/m index base scale displacement)
1239 instr-symbolic
1240 (setf mod #b10
1241 r/m #b100
1242 index #b100
1243 base (decode-set (find-register-encode-set 'sib-base)
1244 (slot-value operand 'register))
1245 scale 0 ; don't care
1246 displacement (slot-value operand 'offset)))
1247 (values instr-symbolic '(mod r/m index base scale displacement)))
1248
1249 ;;; Indirect 16-bit register with MOD=#b00, R/M/=#b110 in ModR/M,
1250
1251 (def-operand-class-imodrm (16bit-indirect-register-mod00) (operand-indirect-register) ())
1252
1253 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1254 (encoding (eql '16bit-indirect-register-mod00))
1255 operand-type
1256 template instr
1257 env)
1258 (declare (ignore template instr))
1259 (assert (member operand-type +operand-types-indirect-modrm+))
1260 (let ((resolved-operand (resolve-indirect-register operand env)))
1261 (with-slots (register register2 offset scale)
1262 resolved-operand
1263 (and (= offset 0)
1264 (= scale 1)
1265 (if register2
1266 (and (member register '(bx bp))
1267 (member register2 '(si di)))
1268 (member register '(si di bx)))
1269 resolved-operand))))
1270
1271 (defmethod operand-decode ((operand operand-indirect-register)
1272 (encoding (eql '16bit-indirect-register-mod00))
1273 instr-symbolic)
1274 (assert (= #b00 (slot-value instr-symbolic 'mod)))
1275 (assert (/= #b110 (slot-value instr-symbolic 'r/m)))
1276 (with-slots (register register2 offset scale)
1277 operand
1278 (destructuring-bind (r1 . r2)
1279 (decode-set (find-register-decode-set 'r/m-16bit)
1280 (slot-value instr-symbolic 'r/m))
1281 (setf register r1
1282 register2 r2
1283 offset 0
1284 scale 1)))
1285 (values operand))
1286
1287 (defmethod operand-encode ((operand operand-indirect-register)
1288 (encoding (eql '16bit-indirect-register-mod00))
1289 operand-type
1290 instr-symbolic)
1291 (declare (ignore operand-type))
1292 (with-slots (mod r/m)
1293 instr-symbolic
1294 (setf mod #b00
1295 r/m (decode-set (find-register-encode-set 'r/m-16bit)
1296 (cons (slot-value operand 'register)
1297 (slot-value operand 'register2)))))
1298 (values instr-symbolic '(mod r/m)))
1299
1300 ;;; Indirect 16bit pointer with MOD=#b00, R/M=#b110 in ModR/M.
1301
1302 (def-operand-class-imodrm (16bit-indirect-pointer) (operand-direct) ())
1303
1304 (defmethod operand-and-encoding-unify ((operand operand-direct)
1305 (encoding (eql '16bit-indirect-pointer))
1306 operand-type
1307 template instr
1308 env)
1309 (declare (ignore template instr))
1310 (assert (member operand-type +operand-types-indirect-modrm+))
1311 (let ((resolved-operand (resolve-direct operand env)))
1312 (with-slots (address segment)
1313 resolved-operand
1314 (and (null segment)
1315 (<= 0 address #xffff)
1316 resolved-operand))))
1317
1318 (defmethod operand-decode ((operand operand-direct)
1319 (encoding (eql '16bit-indirect-pointer))
1320 instr-symbolic)
1321 (assert (= #b00 (slot-value instr-symbolic 'mod)))
1322 (assert (= #b110 (slot-value instr-symbolic 'r/m)))
1323 (with-slots (address)
1324 operand
1325 (setf address (realpart (slot-value instr-symbolic 'displacement))))
1326 (values operand))
1327
1328 (defmethod operand-encode ((operand operand-direct)
1329 (encoding (eql '16bit-indirect-pointer))
1330 operand-type
1331 instr-symbolic)
1332 (declare (ignore operand-type))
1333 (with-slots (mod r/m displacement)
1334 instr-symbolic
1335 (setf mod #b00
1336 r/m #b110
1337 displacement (slot-value operand 'address)))
1338 (values instr-symbolic '(mod r/m displacement)))
1339
1340 ;;; Indirect 16-bit register with MOD=#b01 in ModR/M.
1341
1342 (def-operand-class-imodrm (16bit-indirect-register-mod01) (operand-indirect-register) ())
1343
1344 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1345 (encoding (eql '16bit-indirect-register-mod01))
1346 operand-type
1347 template instr
1348 env)
1349 (declare (ignore template instr))
1350 (assert (member operand-type +operand-types-indirect-modrm+))
1351 (let ((resolved-operand (resolve-indirect-register operand env)))
1352 (with-slots (register register2 offset scale)
1353 resolved-operand
1354 (and (= scale 1)
1355 (<= -128 offset 127)
1356 (if register2
1357 (and (member register '(bx bp))
1358 (member register2 '(si di)))
1359 (member register '(si di bp bx)))
1360 resolved-operand))))
1361
1362 (defmethod operand-decode ((operand operand-indirect-register)
1363 (encoding (eql '16bit-indirect-register-mod01))
1364 instr-symbolic)
1365 (assert (= #b01 (slot-value instr-symbolic 'mod)))
1366 (with-slots (register register2 offset scale)
1367 operand
1368 (destructuring-bind (r1 . r2)
1369 (decode-set (find-register-decode-set 'r/m-16bit)
1370 (slot-value instr-symbolic 'r/m))
1371 (setf register r1
1372 register2 r2
1373 offset (sign-extend (realpart (slot-value instr-symbolic 'displacement)) 1)
1374 scale 1)))
1375 (values operand))
1376
1377 (defmethod operand-encode ((operand operand-indirect-register)
1378 (encoding (eql '16bit-indirect-register-mod01))
1379 operand-type
1380 instr-symbolic)
1381 (declare (ignore operand-type))
1382 (with-slots (mod r/m displacement)
1383 instr-symbolic
1384 (setf mod #b01
1385 r/m (decode-set (find-register-encode-set 'r/m-16bit)
1386 (cons (slot-value operand 'register)
1387 (slot-value operand 'register2)))
1388 displacement (slot-value operand 'offset)))
1389 (values instr-symbolic '(mod r/m displacement)))
1390
1391 ;;; Indirect 16-bit register with MOD=#b10 in ModR/M.
1392
1393 (def-operand-class-imodrm (16bit-indirect-register-mod10) (operand-indirect-register) ())
1394
1395 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1396 (encoding (eql '16bit-indirect-register-mod10))
1397 operand-type
1398 template instr
1399 env)
1400 (declare (ignore template instr))
1401 (assert (member operand-type +operand-types-indirect-modrm+))
1402 (let ((resolved-operand (resolve-indirect-register operand env)))
1403 (with-slots (register register2 offset scale)
1404 resolved-operand
1405 (and (= scale 1)
1406 (<= 0 offset #xffff)
1407 (if register2
1408 (and (member register '(bx bp))
1409 (member register2 '(si di)))
1410 (member register '(si di bp bx)))
1411 resolved-operand))))
1412
1413 (defmethod operand-decode ((operand operand-indirect-register)
1414 (encoding (eql '16bit-indirect-register-mod10))
1415 instr-symbolic)
1416 (assert (= #b10 (slot-value instr-symbolic 'mod)))
1417 (with-slots (register register2 offset scale)
1418 operand
1419 (destructuring-bind (r1 . r2)
1420 (decode-set (find-register-decode-set 'r/m-16bit)
1421 (slot-value instr-symbolic 'r/m))
1422 (setf register r1
1423 register2 r2
1424 offset (realpart (slot-value instr-symbolic 'displacement))
1425 scale 1)))
1426 (values operand))
1427
1428 (defmethod operand-encode ((operand operand-indirect-register)
1429 (encoding (eql '16bit-indirect-register-mod10))
1430 operand-type
1431 instr-symbolic)
1432 (declare (ignore operand-type))
1433 (assert (<= 0 (slot-value operand 'offset) #xffff))
1434 (with-slots (mod r/m displacement)
1435 instr-symbolic
1436 (setf mod #b10
1437 r/m (decode-set (find-register-encode-set 'r/m-16bit)
1438 (cons (slot-value operand 'register)
1439 (slot-value operand 'register2)))
1440 displacement (slot-value operand 'offset)))
1441 (values instr-symbolic '(mod r/m displacement)))
1442
1443 ;;; Absolute pointer encoded in the moffs operand-type
1444
1445 (def-operand-class (abs-pointer-moffs (moffs8 moffs16 moffs32))
1446 (operand-direct) ())
1447
1448 (defmethod operand-and-encoding-unify ((operand operand-direct)
1449 (encoding (eql 'abs-pointer-moffs))
1450 operand-type
1451 template instr
1452 env)
1453 (declare (ignore template instr))
1454 (let ((resolved-operand (resolve-direct operand env)))
1455 (with-slots (address)
1456 resolved-operand
1457 (and
1458 (ecase operand-type
1459 (moffs8 (<= 0 address #xff))
1460 (moffs16 (<= 0 address #xffff))
1461 (moffs32 (<= 0 address #xffffffff)))
1462 resolved-operand))))
1463
1464 (defmethod operand-decode ((operand operand-direct)
1465 (encoding (eql 'abs-pointer-moffs))
1466 instr-symbolic)
1467 (with-slots (address)
1468 operand
1469 (setf address (realpart (slot-value instr-symbolic 'displacement))))
1470 (values operand))
1471
1472 (defmethod operand-encode ((operand operand-direct)
1473 (encoding (eql 'abs-pointer-moffs))
1474 operand-type
1475 instr-symbolic)
1476 (declare (ignore operand-type))
1477 (with-slots (displacement)
1478 instr-symbolic
1479 (setf displacement (slot-value operand 'address)))
1480 (values instr-symbolic '(displacement)))
1481
1482 ;;; Register constants (no encoding)
1483
1484 (eval-when (:compile-toplevel :load-toplevel :execute)
1485 (defparameter +constant-register-operands+
1486 '(al ah ax eax
1487 bl bh bx ebx
1488 dl dh dx edx
1489 cl ch cx ecx
1490 cs ds es fs gs ss
1491 cr0 cr2 cr3 cr4
1492 dr0 dr1 dr2 dr3 dr4 dr5 dr6 dr7)))
1493
1494 (defmacro def-many-constant-registers (cr-list)
1495 (cons 'cl:progn
1496 (loop for cr in (symbol-value cr-list)
1497 collect `(def-operand-class (register-constant (,cr)) (operand-register) ()))))
1498
1499 (def-many-constant-registers +constant-register-operands+)
1500
1501 (defmethod operand-and-encoding-unify ((operand operand-register)
1502 (encoding (eql 'register-constant))
1503 operand-type
1504 template instr
1505 env)
1506 (declare (ignore template instr env))
1507 (assert (member operand-type +constant-register-operands+))
1508 (and (eq operand-type
1509 (slot-value operand 'register))
1510 operand))
1511
1512 (defmethod operand-decode ((operand operand-register)
1513 (encoding (eql 'register-constant))
1514 instr-symbolic)
1515 (declare (ignore instr-symbolic))
1516 (with-slots (register)
1517 operand
1518 (setf register (operand-class-register-set (class-of operand))))
1519 (values operand))
1520
1521 (defmethod operand-encode ((operand operand-register)
1522 (encoding (eql 'register-constant))
1523 operand-type
1524 instr-symbolic)
1525 (declare (ignore operand-type))
1526 (values instr-symbolic '()))
1527
1528
1529 ;;; Immediate constants (no encoding)
1530
1531 (def-operand-class (register-constant (1)) (operand-immediate) ())
1532
1533 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1534 (encoding (eql 'register-constant))
1535 operand-type
1536 template instr
1537 env)
1538 (declare (ignore template instr env))
1539 (and (= operand-type
1540 (slot-value operand 'value))
1541 operand))
1542
1543 (defmethod operand-decode ((operand operand-immediate)
1544 (encoding (eql 'register-constant))
1545 instr-symbolic)
1546 (declare (ignore instr-symbolic))
1547 (with-slots (value)
1548 operand
1549 (setf value (operand-class-register-set (class-of operand))))
1550 (values operand))
1551
1552 (defmethod operand-encode ((operand operand-immediate)
1553 (encoding (eql 'register-constant))
1554 operand-type
1555 instr-symbolic)
1556 (declare (ignore operand-type))
1557 (values instr-symbolic '()))
1558
1559
1560 ;;; Register encoded in the opcode (plus-format).
1561
1562 (def-operand-class (register-plus (+r8)) (operand-register) ())
1563 (def-operand-class (register-plus (+r16)) (operand-register) ())
1564 (def-operand-class (register-plus (+r32)) (operand-register) ())
1565
1566 (defmethod operand-and-encoding-unify ((operand operand-register)
1567 (encoding (eql 'register-plus))
1568 operand-type
1569 template instr
1570 env)
1571 (declare (ignore template instr env))
1572 (with-slots (register)
1573 operand
1574 (and (ecase operand-type
1575 ((+r8) (member register '(al cl dl bl ah ch dh bh)))
1576 ((+r16) (member register '(ax cx dx bx sp bp si di)))
1577 ((+r32) (member register '(eax ecx edx ebx esp ebp esi edi))))
1578 operand)))
1579
1580 (defmethod operand-decode ((operand operand-register)
1581 (encoding (eql 'register-plus))
1582 instr-symbolic)
1583 (with-slots (register)
1584 operand
1585 (setf register
1586 (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
1587 (ldb (byte 3 0)
1588 (slot-value instr-symbolic 'opcode)))))
1589 (values operand))
1590
1591 (defmethod operand-encode ((operand operand-register)
1592 (encoding (eql 'register-plus))
1593 operand-type
1594 instr-symbolic)
1595 (with-slots (opcode)
1596 instr-symbolic
1597 (setf (ldb (byte 3 0) opcode)
1598 (decode-set (find-register-encode-set operand-type)
1599 (slot-value operand 'register))))
1600 (values instr-symbolic '(opcode)))
1601
1602
1603 ;;; Immediate values
1604
1605 (def-operand-class (immediate (imm8 simm8 imm16 simm32 imm32)) (operand-immediate) ())
1606
1607 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1608 (encoding (eql 'immediate))
1609 operand-type
1610 template instr
1611 env)
1612 (declare (ignore template instr env))
1613 (with-slots (value)
1614 operand
1615 (and (ecase operand-type
1616 (simm8 (<= #x-80 value #x7f))
1617 (imm8 (<= 0 value #xff))
1618 (imm16 (<= 0 value #xffff))
1619 (simm32 (<= #x-80000000 value #xffffffff))
1620 (imm32 (<= 0 value #xffffffff)))
1621 operand)))
1622
1623 (defmethod operand-and-encoding-unify ((operand abstract-operand)
1624 (encoding (eql 'immediate))
1625 operand-type
1626 template instr
1627 env)
1628 (operand-and-encoding-unify (make-instance 'operand-immediate
1629 'value (operand-resolve-to-number operand env))
1630 encoding operand-type
1631 template instr env))
1632
1633 (defmethod operand-decode ((operand operand-immediate)
1634 (encoding (eql 'immediate))
1635 instr-symbolic)
1636 (with-slots (value)
1637 operand
1638 (setf value (sign-extend (realpart (slot-value instr-symbolic 'immediate))
1639 (imagpart (slot-value instr-symbolic 'immediate)))))
1640 (values operand))
1641
1642 (defmethod operand-encode ((operand operand-immediate)
1643 (encoding (eql 'immediate))
1644 operand-type
1645 instr-symbolic)
1646 (declare (ignore operand-type))
1647 (unless (instr-symbolic-reg instr-symbolic)
1648 (setf (instr-symbolic-reg instr-symbolic) 0)) ; don't care)
1649 (with-slots (immediate)
1650 instr-symbolic
1651 (setf immediate (slot-value operand 'value)))
1652 (values instr-symbolic '(immediate)))
1653
1654 ;;; PC-relative addresses
1655
1656 (def-operand-class (pc-relative (rel8 rel16 rel32)) (operand-rel-pointer) ())
1657
1658 (defmethod operand-and-encoding-unify ((operand operand-rel-pointer)
1659 (encoding (eql 'pc-relative))
1660 operand-type
1661 template instr
1662 env)
1663 (declare (ignore template instr env))
1664 (with-slots (offset)
1665 operand
1666 (and (ecase operand-type
1667 ((rel8) (<= #x-80 offset #x7f))
1668 ((rel16) (<= #x-8000 offset #x7fff))
1669 ((rel32) (<= #x-80000000 offset #x7fffffff)))
1670 operand)))
1671
1672 (defmethod operand-and-encoding-unify ((operand abstract-operand)
1673 (encoding (eql 'pc-relative))
1674 operand-type
1675 template instr
1676 env)
1677 (ecase operand-type
1678 ((rel8 rel32)
1679 (operand-and-encoding-unify (make-instance 'operand-rel-pointer
1680 'offset (abstract-operand-to-offset operand
1681 template
1682 instr
1683 env))
1684 encoding operand-type
1685 template instr env))
1686 ((rel16)
1687 ;; rel16 operands cause EIP to be masked with #x0000ffff
1688 (and (<= 0 (operand-resolve-to-number operand env) #x0000ffff)
1689 (operand-and-encoding-unify (make-instance 'operand-rel-pointer
1690 'offset (abstract-operand-to-offset operand
1691 template
1692 instr
1693 env))
1694 encoding operand-type
1695 template instr env)))))
1696
1697 (defmethod operand-decode ((operand operand-rel-pointer)
1698 (encoding (eql 'pc-relative))
1699 instr-symbolic)
1700 (with-slots (offset)
1701 operand
1702 (setf offset
1703 (realpart (slot-value instr-symbolic 'displacement))))
1704 (values operand))
1705
1706 (defmethod operand-encode ((operand operand-rel-pointer)
1707 (encoding (eql 'pc-relative))
1708 operand-type
1709 instr-symbolic)
1710 (declare (ignore operand-type))
1711 (with-slots (displacement)
1712 instr-symbolic
1713 (setf displacement
1714 (slot-value operand 'offset)))
1715 (values instr-symbolic '(displacement)))
1716
1717 ;;; 32-bit Segmented addresses
1718
1719 (def-operand-class (ptr16-32 (ptr16-32)) (operand-direct) ())
1720
1721 (defmethod operand-and-encoding-unify ((operand operand-direct)
1722 (encoding (eql 'ptr16-32))
1723 operand-type
1724 template instr
1725 env)
1726 (declare (ignore template instr))
1727 (assert (eq operand-type 'ptr16-32))
1728 (let ((resolved-operand (resolve-direct operand env)))
1729 (with-slots (address segment)
1730 resolved-operand
1731 (and address
1732 (<= 0 address #xffffffff)
1733 segment
1734 (<= 0 segment #xffff)
1735 resolved-operand))))
1736
1737 (defmethod operand-decode ((operand operand-direct)
1738 (encoding (eql 'ptr16-32))
1739 instr-symbolic)
1740 (with-slots (address segment)
1741 operand
1742 (setf
1743 address (ldb (byte 32 0) (realpart (instr-symbolic-displacement instr-symbolic)))
1744 segment (ldb (byte 16 32) (realpart (instr-symbolic-displacement instr-symbolic)))))
1745 (values operand))
1746
1747 (defmethod operand-encode ((operand operand-direct)
1748 (encoding (eql 'ptr16-32))
1749 operand-type
1750 instr-symbolic)
1751 (declare (ignore operand-type))
1752 (with-slots (displacement)
1753 instr-symbolic
1754 (setf
1755 (ldb (byte 32 0) displacement) (slot-value operand 'address)
1756 (ldb (byte 16 32) displacement) (slot-value operand 'segment)))
1757 (values instr-symbolic '(displacement)))
1758
1759 ;;; 16-bit Segmented addresses
1760
1761 (def-operand-class (ptr16-16 (ptr16-16)) (operand-direct) ())
1762
1763 (defmethod operand-and-encoding-unify ((operand operand-direct)
1764 (encoding (eql 'ptr16-16))
1765 operand-type
1766 template instr
1767 env)
1768 (declare (ignore template instr))
1769 (assert (eq operand-type 'ptr16-16))
1770 (let ((resolved-operand (resolve-direct operand env)))
1771 (with-slots (address segment)
1772 resolved-operand
1773 (and address
1774 (<= 0 address #xffff)
1775 segment
1776 (<= 0 segment #xffff)
1777 resolved-operand))))
1778
1779 (defmethod operand-decode ((operand operand-direct)
1780 (encoding (eql 'ptr16-16))
1781 instr-symbolic)
1782 (with-slots (address segment)
1783 operand
1784 (setf
1785 address (ldb (byte 16 0) (realpart (instr-symbolic-displacement instr-symbolic)))
1786 segment (ldb (byte 16 16) (realpart (instr-symbolic-displacement instr-symbolic)))))
1787 (values operand))
1788
1789 (defmethod operand-encode ((operand operand-direct)
1790 (encoding (eql 'ptr16-16))
1791 operand-type
1792 instr-symbolic)
1793 (declare (ignore operand-type))
1794 (with-slots (displacement)
1795 instr-symbolic
1796 (setf displacement 0
1797 (ldb (byte 16 0) displacement) (slot-value operand 'address)
1798 (ldb (byte 16 16) displacement) (slot-value operand 'segment)))
1799 (values instr-symbolic '(displacement)))
1800
1801 ;;; Two immediate operands (for ENTER)
1802
1803 (def-operand-class (imm16-8 (imm16-8)) (operand-immediate) ())
1804
1805 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1806 (encoding (eql 'imm16-8))
1807 operand-type
1808 template instr
1809 env)
1810 (declare (ignore template instr env))
1811 (assert (eq operand-type 'imm16-8))
1812 (with-slots (value)
1813 operand
1814 (and (<= 0 value #xffff)
1815 operand)))
1816
1817 (defmethod operand-decode ((operand operand-immediate)
1818 (encoding (eql 'imm16-8))
1819 instr-symbolic)
1820 (with-slots (value)
1821 operand
1822 (setf value (ldb (byte 16 0)
1823 (realpart (slot-value instr-symbolic 'immediate)))))
1824 (values operand))
1825
1826 (defmethod operand-encode ((operand operand-immediate)
1827 (encoding (eql 'imm16-8))
1828 operand-type
1829 instr-symbolic)
1830 (assert (eq operand-type 'imm16-8)
1831 (operand-type))
1832 (unless (instr-symbolic-immediate instr-symbolic)
1833 (setf (slot-value instr-symbolic 'immediate) 0))
1834 (with-slots (immediate)
1835 instr-symbolic
1836 (setf (ldb (byte 16 0) immediate)
1837 (slot-value operand 'value)))
1838 (values instr-symbolic '(immediate)))
1839
1840
1841 ;;; Two immediate operands (for ENTER)
1842
1843 (def-operand-class (imm8-0 (imm8-0)) (operand-immediate) ())
1844
1845 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1846 (encoding (eql 'imm8-0))
1847 operand-type
1848 template instr
1849 env)
1850 (declare (ignore template instr env))
1851 (assert (eq operand-type 'imm8-0))
1852 (with-slots (value)
1853 operand
1854 (and (<= 0 value #x7f)
1855 operand)))
1856
1857 (defmethod operand-decode ((operand operand-immediate)
1858 (encoding (eql 'imm8-0))
1859 instr-symbolic)
1860 (with-slots (value)
1861 operand
1862 (setf value (ldb (byte 8 16)
1863 (realpart (slot-value instr-symbolic 'immediate)))))
1864 (values operand))
1865
1866 (defmethod operand-encode ((operand operand-immediate)
1867 (encoding (eql 'imm8-0))
1868 operand-type
1869 instr-symbolic)
1870 (assert (eq operand-type 'imm8-0)
1871 (operand-type))
1872 (unless (instr-symbolic-immediate instr-symbolic)
1873 (setf (slot-value instr-symbolic 'immediate) 0))
1874 (with-slots (immediate)
1875 instr-symbolic
1876 (setf (ldb (byte 8 16) immediate)
1877 (slot-value operand 'value)))
1878 (values instr-symbolic '(immediate)))
1879
1880
1881

  ViewVC Help
Powered by ViewVC 1.1.5