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

Last change on this file since 13741 was 13741, checked in by gb, 9 years ago

Keep moving forward. Can -almost- compile simple functions.

File size: 15.1 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(defun arm-fprd-name (regno)
32  `(:double ,regno))
33
34(defun arm-fprs-name (regno)
35  `(:single ,regno))
36
37
38
39(defun find-arm-instruction-template (opcode)
40  (dotimes (i (length arm::*arm-instruction-table*))
41    (let* ((template (svref arm::*arm-instruction-table* i))
42           (value (arm::arm-instruction-template-val template))
43           (masks  (arm::arm-instruction-template-mask-list template)))
44      (if
45        (if (atom masks)
46          (= (logand opcode masks) value)
47          (dolist (mask masks)
48            (if (atom mask)
49              (if (= (logand opcode mask) value)
50                (return t))
51              (if (= (logand opcode (cdr mask)) (car mask))
52                (return t)))))
53        (return template)))))
54
55
56(defun extract-arm-rd-operand (opcodes i)
57  (let* ((opcode (adi-opcode (svref opcodes i))))
58    (arm-gpr-name (ldb (byte 4 12) opcode))))
59
60(defun extract-arm-rn-operand (opcodes i)
61  (let* ((opcode (adi-opcode (svref opcodes i))))
62    (arm-gpr-name (ldb (byte 4 16) opcode))))
63
64(defparameter *arm-shift-ops* #(:lsl :lsr :asr :ror))
65
66
67(defun extract-arm-shifter-operand (opcodes i)
68  (let* ((opcode (adi-opcode (svref opcodes i))))
69    (if (logbitp 25 opcode)
70      (let* ((count (ash (ldb (byte 4 8) opcode) 1)))
71        `(:$ ,(arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count)))))
72      (let* ((rn (arm-gpr-name (ldb (byte 4 0) opcode)))
73             (register-shifted (logbitp 4 opcode)))
74        (if register-shifted
75          `(,(svref *arm-shift-ops* (ldb (byte 2 5) opcode))
76            ,rn
77            ,(arm-gpr-name (ldb (byte 4 8) opcode)))
78          (let* ((shift-type (ldb (byte 2 5) opcode))
79                 (shift-count (ldb (byte 5 7) opcode)))
80            (if (and (eql shift-type 0)
81                     (eql shift-count 0))
82              rn
83              (if (and (eql shift-type 3)
84                       (eql shift-count 0))
85                `(:rrx ,rn)
86                `(,(svref *arm-shift-ops* shift-type)
87                  ,rn
88                  (:$ ,shift-count))))))))))
89
90             
91
92(defun extract-arm-m12-operand (opcodes i)
93  (let* ((opcode (adi-opcode (svref opcodes i))))
94    (let* ((immediate (not (logbitp 25 opcode)))
95           (disp (ldb (byte 12 0) opcode))
96           (p (logbitp 24 opcode))
97           (u (logbitp 23 opcode))
98           (w (logbitp 21 opcode))
99           (rnval (ldb (byte 4 16) opcode))
100           (rn (arm-gpr-name rnval)))
101      (cond (immediate
102              (unless u (setq disp (- disp)))
103              (if (and u
104                       p
105                       (not w)
106                       (eql arm::fn rnval)
107                       (eql (mod (- disp arm::misc-data-offset) 4) 0))
108                `(:@ ,rn (:constant ,(ash (- disp arm::misc-data-offset) -2)))
109                (if (and p (not w) (eql arm::pc rnval) (not (logtest 3 disp)))
110                  (let* ((target (+ i 2 (ash disp -2))))
111                    (when (< target (uvsize opcodes))
112                      (setf (adi-labeled (uvref opcodes target)) t))
113                    `(:= (:label ,target)))
114                  (if p
115                    (if w
116                      `(:@! ,rn (:$ ,disp))
117                      `(:@ ,rn (:$ ,disp)))
118                    `(:@+ ,rn (:$ ,disp))))))
119            (t
120             (let* ((shift-op (ldb (byte 2 5) opcode))
121                    (shift-count (ldb (byte 5 7) opcode))
122                    (rm (arm-gpr-name (ldb (byte 4 0) opcode)))
123                    (memop
124                     (if p
125                       (if w
126                         (if u :+@! :-@!)
127                         (if u :+@ :-@))
128                       (if u :@+ :@-))))
129               (if (and (zerop shift-count) (zerop shift-op))
130                 `(,memop ,rn ,rm)
131                 (if (and (eql 3 shift-op) (zerop shift-count))
132                   `(,memop ,rn (:rrx ,rm))
133                   `(,memop ,rn (,(svref *arm-shift-ops* shift-op)
134                                 ,rm
135                                 (:$ ,shift-count)))))))))))
136
137
138(defun extract-arm-reglist-operand (opcodes i)
139  (let* ((opcode (adi-opcode (svref opcodes i))))
140    (let* ((mask (ldb (byte 16 0) opcode))
141           (regs ()))
142      (declare (type (unsigned-byte 16) i))
143      (do* ((i 15 (1- i)))
144           ((< i 0) `(:reglist ,regs))
145        (declare ((signed-byte 4) i))
146        (when (logbitp i mask)
147          (push i regs))))))
148
149(defun extract-arm-rnw-operand (opcodes i)
150  (let* ((opcode (adi-opcode (svref opcodes i))))
151    (let* ((regname (arm-gpr-name (ldb (byte 4 16) opcode))))
152      (if (logbitp 21 opcode)
153        `(:! ,regname)
154        regname))))
155
156(defun extract-arm-uuoa-operand (opcodes i)
157  (let* ((opcode (adi-opcode (svref opcodes i))))
158    (arm-gpr-name (ldb (byte 4 8) opcode))))
159
160(defun extract-arm-uuo-unary-operand (opcodes i)
161  (let* ((opcode (adi-opcode (svref opcodes i))))
162    `(:$ ,(ldb (byte 8 12) opcode))))
163
164(defun extract-arm-uuob-operand (opcodes i)
165  (let* ((opcode (adi-opcode (svref opcodes i))))
166    (arm-gpr-name (ldb (byte 4 12) opcode))))
167
168(defun extract-arm-rm-operand (opcodes i)
169  (let* ((opcode (adi-opcode (svref opcodes i))))
170    (arm-gpr-name (ldb (byte 4 0) opcode))))
171
172(defun extract-arm-b-operand (opcodes i)
173  (let* ((opcode (adi-opcode (svref opcodes i)))
174         (b-field (ldb (byte 24 0) opcode)))
175    (when (logbitp 23 b-field)
176      (setq b-field (- b-field (ash 1 24))))
177    (let* ((target (+ i 2 b-field)))
178      (when (and (>= target 0)
179                 (< target (length opcodes)))
180        (setf (adi-labeled (svref opcodes target)) t))
181      `(:label ,target))))
182
183(defun extract-arm-subprim-operand (opcodes i)
184  (let* ((opcode (adi-opcode (svref opcodes i)))
185         (count (ash (ldb (byte 4 8) opcode) 1))
186         (spaddr (arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count))))
187         (name (arm::arm-subprimitive-name spaddr)))
188    (if name
189      `(:spname ,name)
190      `(:$ ,spaddr))))
191
192(defun extract-arm-m8-operand (opcodes i)
193  (let* ((opcode (adi-opcode (svref opcodes i))))
194    (let* ((immediate (not (logbitp 25 opcode)))
195           (disp (dpb (ldb (byte 4 8) opcode)
196                      (byte 4 4)
197                      (ldb (byte 4 0) opcode)))
198           (p (logbitp 24 opcode))
199           (u (logbitp 23 opcode))
200           (w (logbitp 21 opcode))
201           (rnval (ldb (byte 4 16) opcode))
202           (rn (arm-gpr-name rnval)))
203      (cond (immediate
204             (unless u (setq disp (- disp)))
205             (if p
206               (if w
207                 `(:@! ,rn (:$ ,disp))
208                 `(:@ ,rn (:$ ,disp)))
209               `(:@+ ,rn (:$ ,disp))))
210            (t
211             (let* ((rm (arm-gpr-name (ldb (byte 4 0) opcode))))
212               `(,(if p
213                      (if w
214                        (if u :+@! :-@!)
215                        (if u :+@ :-@))
216                      (if u :@+ :@-)) ,rn ,rm)))))))
217
218(defun extract-arm-dd-operand (opcodes i)
219  (let* ((opcode (adi-opcode (svref opcodes i))))
220    (arm-fprd-name (ldb (byte 4 12) opcode))))
221
222(defun extract-arm-dm-operand (opcodes i)
223  (let* ((opcode (adi-opcode (svref opcodes i))))
224    (arm-fprd-name (ldb (byte 4 0) opcode))))
225
226(defun extract-arm-sd-operand (opcodes i)
227  (let* ((opcode (adi-opcode (svref opcodes i))))
228    (arm-fprs-name (logior (ash (ldb (byte 4 12) opcode) 1)
229                           (ldb (byte 1 22) opcode)))))
230
231(defun extract-arm-sm-operand (opcodes i)
232  (let* ((opcode (adi-opcode (svref opcodes i))))
233    (arm-fprs-name (logior (ash (ldb (byte 4 0) opcode) 1)
234                           (ldb (byte 1 5) opcode)))))
235
236(defun extract-arm-dn-operand (opcodes i)
237  (let* ((opcode (adi-opcode (svref opcodes i))))
238    (arm-fprd-name (ldb (byte 4 16) opcode))))
239
240(defun extract-arm-sn-operand (opcodes i)
241  (let* ((opcode (adi-opcode (svref opcodes i))))
242    (arm-fprd-name (logior (ash (ldb (byte 4 16) opcode) 1)
243                           (ldb (byte 1 7) opcode)))))
244
245
246(defparameter *arm-operand-extract-functions*
247  #(extract-arm-rd-operand
248    extract-arm-rn-operand
249    extract-arm-shifter-operand
250    extract-arm-m12-operand
251    extract-arm-reglist-operand
252    extract-arm-rnw-operand
253    extract-arm-uuoa-operand
254    extract-arm-uuo-unary-operand
255    extract-arm-uuob-operand
256    extract-arm-rm-operand
257    extract-arm-b-operand
258    extract-arm-subprim-operand
259    extract-arm-m8-operand
260    extract-arm-dd-operand
261    extract-arm-dm-operand
262    extract-arm-sd-operand
263    extract-arm-sm-operand
264    extract-arm-dn-operand
265    extract-arm-sn-operand
266    ))
267
268(defun make-adi-vector (code-vector)
269  (let* ((n (uvsize code-vector))
270         (v (make-array n)))
271    (declare (fixnum n) (simple-vector v))
272    (dotimes (i n v)
273      (setf (svref v i)
274            (make-arm-disassembled-instruction :opcode (uvref code-vector i))))))
275
276(defun process-adi-vector (adi-vector)
277  (let* ((n (length adi-vector))
278         (skip 0)
279         (data 0))
280    (dotimes (i n adi-vector)
281      (let* ((adi (svref adi-vector i))
282             (opcode (adi-opcode adi)))
283        (cond ((> skip 0)
284               (decf skip)
285               (if (= skip 0)
286                 (setq data opcode)))
287              ((> data 0)
288               (decf data)
289               (setf (adi-mnemonic adi) ":word"
290                     (adi-operands adi) (list opcode)))
291              ((= opcode 0)
292               (setq skip 2))
293              (t
294               (let* ((template (find-arm-instruction-template opcode)))
295                 (if (null template)
296                   (setf (adi-mnemonic adi) :???
297                         (adi-operands adi) (list opcode))
298                   (collect ((operands))
299                     (setf (adi-mnemonic adi)
300                           (arm::arm-instruction-template-name template))
301                     (unless (logtest (arm::encode-arm-instruction-flag :non-conditional) (arm::arm-instruction-template-flags template))
302                       (let* ((cond (ldb (byte 4 28) opcode))
303                              (cond-name (if (< cond 14) (arm::lookup-arm-condition-value cond))))
304                         (when cond-name
305                           (if (logtest (arm::encode-arm-instruction-flag :prefer-separate-cond) (arm::arm-instruction-template-flags template))
306                             (operands `(:? ,cond-name))
307                             (setf (adi-condition-name adi) cond-name)))))
308                     
309                     (dolist (type (arm::arm-instruction-template-operand-types template))
310                       (operands (funcall (svref *arm-operand-extract-functions* type) adi-vector i)))
311                     (setf (adi-operands adi) (operands)))))))))))
312
313(defparameter *arm-gpr-names*
314  #("imm0" "imm1" "nargs" "rcontext" "arg_z" "arg_y" "arg_x" "temp0"
315    "temp1" "temp2" "vsp" "fn" "allocptr" "sp" "lr" "pc"))
316
317(defun disassemble-arm-xfunction (xfunction &optional (stream *debug-io*))
318  (let* ((adi-vector (process-adi-vector (make-adi-vector (uvref xfunction 1)))))
319    (dotimes (i (length adi-vector))
320      (let* ((info (svref adi-vector i)))
321        (when (adi-labeled info)
322          (format stream "~&L~d~&" (ash i 2)))
323        (let* ((name (adi-mnemonic info)))
324          (when name
325            (let* ((condition-name (or (adi-condition-name info) "")))
326                (format stream "~&  (~a~a" name condition-name))
327            (labels ((format-operand (operand)
328                       (write-char #\space stream)
329                       (if (atom operand)
330                         (if (and (typep operand 'integer)
331                                  (> (abs operand) 100))
332                           (format stream "#x~x" operand)
333                           (format stream "~d" operand))
334                         (ecase (car operand)
335                           (:= (format stream "(:=")
336                               (format-operand (cadr operand))
337                               (write-char #\) stream))
338                           (:label (format stream "L~d" (ash (cadr operand) 2)))
339                           (:constant (format stream "~s" (list 'quote (uvref xfunction (cadr operand)))))
340                           ((:lsl :lsr :asr :ror :rrx)
341                            (format stream "(:~a" (string-downcase (car operand)))
342                            (dolist (sub (cdr operand))
343                              (format-operand sub))
344                            (write-char #\) stream))
345                           (:spname
346                            (let* ((string (string (cadr operand)))
347                                   (n (length string))
348                                   (copy (make-string n)))
349                              (declare (dynamic-extent copy))
350                              (dotimes (i n (format stream "~a" copy))
351                                (let* ((ch (char string i)))
352                                  (setf (schar copy i)
353                                        (if (< i 3)
354                                          ch
355                                          (char-downcase ch)))))))
356                           (:$ (format stream "(:$")
357                               (format-operand (cadr operand))
358                               (write-char #\) stream))
359                           (:? (format stream "(:? ~a)" (cadr operand)))
360                           (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand))))
361                           (:single (format stream "s~d" (cadr operand)))
362                           (:double (format stream "d~d" (cadr operand)))
363                           (:reglist (format stream "~a"
364                                             (mapcar (lambda (r)
365                                                       (svref *arm-gpr-names* r))
366                                                     (cadr operand))))
367                           ((:@ :@! :+@ :+@! :-@ :-@! :@+ :@-)
368                            (format stream "(~s" (car operand))
369                            (dolist (sub (cdr operand))
370                              (format-operand sub))
371                            (write-char #\) stream))
372                           (:!
373                            (format stream "(:!")
374                            (format-operand (cadr operand))
375                            (write-char #\) stream))))))
376              (dolist (op (adi-operands info))
377                (format-operand op))
378              (write-char #\) stream))))))))
379
380                             
381                       
382             
383       
Note: See TracBrowser for help on using the repository browser.