source: branches/arm/compiler/ARM/arm-disassemble.lisp @ 13735

Last change on this file since 13735 was 13735, checked in by gb, 11 years ago

downcase shift ops.

File size: 13.7 KB
Line 
1;;;-*- Mode: Lisp; Package: (ARM :use CL) -*-
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL.
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License   known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict  the preamble takes precedence.
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(eval-when (:compile-toplevel :load-toplevel :execute)
18(require "ARM-ASM")
19)
20
21(defstruct (arm-disassembled-instruction (:conc-name adi-))
22  (opcode 0 :type (unsigned-byte 32))
23  (labeled nil)
24  (mnemonic nil)
25  (condition-name nil)
26  (operands nil))
27
28(defun arm-gpr-name (regno)
29  `(:gpr ,regno))
30
31
32
33(defun find-arm-instruction-template (opcode)
34  (dotimes (i (length arm::*arm-instruction-table*))
35    (let* ((template (svref arm::*arm-instruction-table* i))
36           (value (arm::arm-instruction-template-val template))
37           (masks  (arm::arm-instruction-template-mask-list template)))
38      (if
39        (if (atom masks)
40          (= (logand opcode masks) value)
41          (dolist (mask masks)
42            (if (atom mask)
43              (if (= (logand opcode mask) value)
44                (return t))
45              (if (= (logand opcode (cdr mask)) (car mask))
46                (return t)))))
47        (return template)))))
48
49
50(defun extract-arm-rd-operand (opcodes i)
51  (let* ((opcode (adi-opcode (svref opcodes i))))
52    (arm-gpr-name (ldb (byte 4 12) opcode))))
53
54(defun extract-arm-rn-operand (opcodes i)
55  (let* ((opcode (adi-opcode (svref opcodes i))))
56    (arm-gpr-name (ldb (byte 4 16) opcode))))
57
58(defparameter *arm-shift-ops* #(:lsl :lsr :asr :ror))
59
60
61(defun extract-arm-shifter-operand (opcodes i)
62  (let* ((opcode (adi-opcode (svref opcodes i))))
63    (if (logbitp 25 opcode)
64      (let* ((count (ash (ldb (byte 4 8) opcode) 1)))
65        `(:$ ,(arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count)))))
66      (let* ((rn (arm-gpr-name (ldb (byte 4 0) opcode)))
67             (register-shifted (logbitp 4 opcode)))
68        (if register-shifted
69          `(,(svref *arm-shift-ops* (ldb (byte 2 5) opcode))
70            ,rn
71            ,(arm-gpr-name (ldb (byte 4 8) opcode)))
72          (let* ((shift-type (ldb (byte 2 5) opcode))
73                 (shift-count (ldb (byte 5 7) opcode)))
74            (if (and (eql shift-type 0)
75                     (eql shift-count 0))
76              rn
77              (if (and (eql shift-type 3)
78                       (eql shift-count 0))
79                `(:rrx ,rn)
80                `(,(svref *arm-shift-ops* shift-type)
81                  ,rn
82                  (:$ ,shift-count))))))))))
83
84             
85
86(defun extract-arm-m12-operand (opcodes i)
87  (let* ((opcode (adi-opcode (svref opcodes i))))
88    (let* ((immediate (not (logbitp 25 opcode)))
89           (disp (ldb (byte 12 0) opcode))
90           (p (logbitp 24 opcode))
91           (u (logbitp 23 opcode))
92           (w (logbitp 21 opcode))
93           (rnval (ldb (byte 4 16) opcode))
94           (rn (arm-gpr-name rnval)))
95      (cond (immediate
96              (unless u (setq disp (- disp)))
97              (if (and u
98                       p
99                       (not w)
100                       (eql arm::fn rnval)
101                       (eql (mod (- disp arm::misc-data-offset) 4) 0))
102                `(:@ ,rn (:constant ,(ash (- disp arm::misc-data-offset) -2)))
103                (if (and p (not w) (eql arm::pc rnval) (not (logtest 3 disp)))
104                  (let* ((target (+ i 2 (ash disp -2))))
105                    (when (< target (uvsize opcodes))
106                      (setf (adi-labeled (uvref opcodes target)) t))
107                    `(:= (:label ,target)))
108                  (if p
109                    (if w
110                      `(:@! ,rn (:$ ,disp))
111                      `(:@ ,rn (:$ ,disp)))
112                    `(:@+ ,rn (:$ ,disp))))))
113            (t
114             (let* ((shift-op (ldb (byte 2 5) opcode))
115                    (shift-count (ldb (byte 5 7) opcode))
116                    (rm (arm-gpr-name (ldb (byte 4 0) opcode)))
117                    (memop
118                     (if p
119                       (if w
120                         (if u :+@! :-@!)
121                         (if u :+@ :-@))
122                       (if u :@+ :@-))))
123               (if (and (zerop shift-count) (zerop shift-op))
124                 `(,memop ,rn ,rm)
125                 (if (and (eql 3 shift-op) (zerop shift-count))
126                   `(,memop ,rn (:rrx ,rm))
127                   `(,memop ,rn (,(svref *arm-shift-ops* shift-op)
128                                 ,rm
129                                 (:$ ,shift-count)))))))))))
130
131
132(defun extract-arm-reglist-operand (opcodes i)
133  (let* ((opcode (adi-opcode (svref opcodes i))))
134    (let* ((mask (ldb (byte 16 0) opcode))
135           (regs ()))
136      (declare (type (unsigned-byte 16) i))
137      (do* ((i 15 (1- i)))
138           ((< i 0) `(:reglist ,regs))
139        (declare ((signed-byte 4) i))
140        (when (logbitp i mask)
141          (push i regs))))))
142
143(defun extract-arm-rnw-operand (opcodes i)
144  (let* ((opcode (adi-opcode (svref opcodes i))))
145    (let* ((regname (arm-gpr-name (ldb (byte 4 16) opcode))))
146      (if (logbitp 21 opcode)
147        `(:! ,regname)
148        regname))))
149
150(defun extract-arm-uuoa-operand (opcodes i)
151  (let* ((opcode (adi-opcode (svref opcodes i))))
152    (arm-gpr-name (ldb (byte 4 8) opcode))))
153
154(defun extract-arm-uuo-unary-operand (opcodes i)
155  (let* ((opcode (adi-opcode (svref opcodes i))))
156    `(:$ ,(ldb (byte 8 12) opcode))))
157
158(defun extract-arm-uuob-operand (opcodes i)
159  (let* ((opcode (adi-opcode (svref opcodes i))))
160    (arm-gpr-name (ldb (byte 4 12) opcode))))
161
162(defun extract-arm-rm-operand (opcodes i)
163  (let* ((opcode (adi-opcode (svref opcodes i))))
164    (arm-gpr-name (ldb (byte 4 0) opcode))))
165
166(defun extract-arm-b-operand (opcodes i)
167  (let* ((opcode (adi-opcode (svref opcodes i)))
168         (b-field (ldb (byte 24 0) opcode)))
169    (when (logbitp 23 b-field)
170      (setq b-field (- b-field (ash 1 24))))
171    (let* ((target (+ i 2 b-field)))
172      (when (and (>= target 0)
173                 (< target (length opcodes)))
174        (setf (adi-labeled (svref opcodes target)) t))
175      `(:label ,target))))
176
177(defun extract-arm-subprim-operand (opcodes i)
178  (let* ((opcode (adi-opcode (svref opcodes i)))
179         (count (ash (ldb (byte 4 8) opcode) 1))
180         (spaddr (arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count))))
181         (name (arm::arm-subprimitive-name spaddr)))
182    (if name
183      `(:spname ,name)
184      `(:$ ,spaddr))))
185
186(defun extract-arm-m8-operand (opcodes i)
187  (let* ((opcode (adi-opcode (svref opcodes i))))
188    (let* ((immediate (not (logbitp 25 opcode)))
189           (disp (dpb (ldb (byte 4 8) opcode)
190                      (byte 4 4)
191                      (ldb (byte 4 0) opcode)))
192           (p (logbitp 24 opcode))
193           (u (logbitp 23 opcode))
194           (w (logbitp 21 opcode))
195           (rnval (ldb (byte 4 16) opcode))
196           (rn (arm-gpr-name rnval)))
197      (cond (immediate
198             (unless u (setq disp (- disp)))
199             (if p
200               (if w
201                 `(:@! ,rn (:$ ,disp))
202                 `(:@ ,rn (:$ ,disp)))
203               `(:@+ ,rn (:$ ,disp))))
204            (t
205             (let* ((rm (arm-gpr-name (ldb (byte 4 0) opcode))))
206               `(,(if p
207                      (if w
208                        (if u :+@! :-@!)
209                        (if u :+@ :-@))
210                      (if u :@+ :@-)) ,rn ,rm)))))))
211
212(defparameter *arm-operand-extract-functions*
213  #(extract-arm-rd-operand
214    extract-arm-rn-operand
215    extract-arm-shifter-operand
216    extract-arm-m12-operand
217    extract-arm-reglist-operand
218    extract-arm-rnw-operand
219    extract-arm-uuoa-operand
220    extract-arm-uuo-unary-operand
221    extract-arm-uuob-operand
222    extract-arm-rm-operand
223    extract-arm-b-operand
224    extract-arm-subprim-operand
225    extract-arm-m8-operand
226    ))
227
228(defun make-adi-vector (code-vector)
229  (let* ((n (uvsize code-vector))
230         (v (make-array n)))
231    (declare (fixnum n) (simple-vector v))
232    (dotimes (i n v)
233      (setf (svref v i)
234            (make-arm-disassembled-instruction :opcode (uvref code-vector i))))))
235
236(defun process-adi-vector (adi-vector)
237  (let* ((n (length adi-vector))
238         (skip 0)
239         (data 0))
240    (dotimes (i n adi-vector)
241      (let* ((adi (svref adi-vector i))
242             (opcode (adi-opcode adi)))
243        (cond ((> skip 0)
244               (decf skip)
245               (if (= skip 0)
246                 (setq data opcode)))
247              ((> data 0)
248               (decf data)
249               (setf (adi-mnemonic adi) ":word"
250                     (adi-operands adi) (list opcode)))
251              ((= opcode 0)
252               (setq skip 2))
253              (t
254               (let* ((template (find-arm-instruction-template opcode)))
255                 (if (null template)
256                   (setf (adi-mnemonic adi) :???
257                         (adi-operands adi) (list opcode))
258                   (collect ((operands))
259                     (setf (adi-mnemonic adi)
260                           (arm::arm-instruction-template-name template))
261                     (unless (logtest (arm::encode-arm-instruction-flag :non-conditional) (arm::arm-instruction-template-flags template))
262                       (let* ((cond (ldb (byte 4 28) opcode))
263                              (cond-name (if (< cond 14) (arm::lookup-arm-condition-value cond))))
264                         (when cond-name
265                           (if (logtest (arm::encode-arm-instruction-flag :prefer-separate-cond) (arm::arm-instruction-template-flags template))
266                             (operands `(:? ,cond-name))
267                             (setf (adi-condition-name adi) cond-name)))))
268                     
269                     (dolist (type (arm::arm-instruction-template-operand-types template))
270                       (operands (funcall (svref *arm-operand-extract-functions* type) adi-vector i)))
271                     (setf (adi-operands adi) (operands)))))))))))
272
273(defparameter *arm-gpr-names*
274  #("imm0" "imm1" "nargs" "rcontext" "arg_z" "arg_y" "arg_x" "temp0"
275    "temp1" "temp2" "vsp" "fn" "allocptr" "sp" "lr" "pc"))
276
277(defun disassemble-arm-xfunction (xfunction &optional (stream *debug-io*))
278  (let* ((adi-vector (process-adi-vector (make-adi-vector (uvref xfunction 1)))))
279    (dotimes (i (length adi-vector))
280      (let* ((info (svref adi-vector i)))
281        (when (adi-labeled info)
282          (format stream "~&L~d~&" (ash i 2)))
283        (let* ((name (adi-mnemonic info)))
284          (when name
285            (let* ((condition-name (or (adi-condition-name info) "")))
286                (format stream "~&  (~a~a" name condition-name))
287            (labels ((format-operand (operand)
288                       (write-char #\space stream)
289                       (if (atom operand)
290                         (if (and (typep operand 'integer)
291                                  (> (abs operand) 100))
292                           (format stream "#x~x" operand)
293                           (format stream "~d" operand))
294                         (ecase (car operand)
295                           (:= (format stream "(:=")
296                               (format-operand (cadr operand))
297                               (write-char #\) stream))
298                           (:label (format stream "L~d" (ash (cadr operand) 2)))
299                           (:constant (format stream "~s" (list 'quote (uvref xfunction (cadr operand)))))
300                           ((:lsl :lsr :asr :ror :rrx)
301                            (format stream "(:~a" (string-downcase (car operand)))
302                            (dolist (sub (cdr operand))
303                              (format-operand sub))
304                            (write-char #\) stream))
305                           (:spname
306                            (let* ((string (string (cadr operand)))
307                                   (n (length string))
308                                   (copy (make-string n)))
309                              (declare (dynamic-extent copy))
310                              (dotimes (i n (format stream "~a" copy))
311                                (let* ((ch (char string i)))
312                                  (setf (schar copy i)
313                                        (if (< i 3)
314                                          ch
315                                          (char-downcase ch)))))))
316                           (:$ (format stream "(:$")
317                               (format-operand (cadr operand))
318                               (write-char #\) stream))
319                           (:? (format stream "(:? ~a)" (cadr operand)))
320                           (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand))))
321                           (:reglist (format stream "~a"
322                                             (mapcar (lambda (r)
323                                                       (svref *arm-gpr-names* r))
324                                                     (cadr operand))))
325                           ((:@ :@! :+@ :+@! :-@ :-@! :@+ :@-)
326                            (format stream "(~s" (car operand))
327                            (dolist (sub (cdr operand))
328                              (format-operand sub))
329                            (write-char #\) stream))
330                           (:!
331                            (format stream "(:!")
332                            (format-operand (cadr operand))
333                            (write-char #\) stream))))))
334              (dolist (op (adi-operands info))
335                (format-operand op))
336              (write-char #\) stream))))))))
337
338                             
339                       
340             
341       
Note: See TracBrowser for help on using the repository browser.