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

Last change on this file since 14034 was 14034, checked in by gb, 10 years ago

movw, movt, & support for them.

File size: 19.4 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(defun extract-arm-rs-operand (opcodes i)
65  (let* ((opcode (adi-opcode (svref opcodes i))))
66    (arm-gpr-name (ldb (byte 4 8) opcode))))
67
68(defun extract-arm-fpaddr-operand (opcodes i)
69  (let* ((opcode (adi-opcode (svref opcodes i)))
70         (offset (ash (ldb (byte 8 0) opcode) 2)))
71    (unless (logbitp 23 opcode)
72      (setq offset (- offset)))
73    `(:@ ,(arm-gpr-name (ldb (byte 4 16) opcode)) (:$ ,offset))))
74
75(defun extract-arm-@rn-operand (opcodes i)
76  (let* ((opcode (adi-opcode (svref opcodes i))))
77    `(:@ ,(arm-gpr-name (ldb (byte 4 16) opcode)))))
78         
79 
80
81(defparameter *arm-shift-ops* #(:lsl :lsr :asr :ror))
82
83
84(defun extract-arm-shifter-operand (opcodes i)
85  (let* ((opcode (adi-opcode (svref opcodes i))))
86    (if (logbitp 25 opcode)
87      (let* ((count (ash (ldb (byte 4 8) opcode) 1)))
88        `(:$ ,(arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count)))))
89      (let* ((rn (arm-gpr-name (ldb (byte 4 0) opcode)))
90             (register-shifted (logbitp 4 opcode)))
91        (if register-shifted
92          `(,(svref *arm-shift-ops* (ldb (byte 2 5) opcode))
93            ,rn
94            ,(arm-gpr-name (ldb (byte 4 8) opcode)))
95          (let* ((shift-type (ldb (byte 2 5) opcode))
96                 (shift-count (ldb (byte 5 7) opcode)))
97            (if (and (eql shift-type 0)
98                     (eql shift-count 0))
99              rn
100              (if (and (eql shift-type 3)
101                       (eql shift-count 0))
102                `(:rrx ,rn)
103                `(,(svref *arm-shift-ops* shift-type)
104                  ,rn
105                  (:$ ,shift-count))))))))))
106
107             
108
109(defun extract-arm-m12-operand (opcodes i)
110  (let* ((opcode (adi-opcode (svref opcodes i))))
111    (let* ((immediate (not (logbitp 25 opcode)))
112           (disp (ldb (byte 12 0) opcode))
113           (p (logbitp 24 opcode))
114           (u (logbitp 23 opcode))
115           (w (logbitp 21 opcode))
116           (rnval (ldb (byte 4 16) opcode))
117           (rn (arm-gpr-name rnval)))
118      (cond (immediate
119              (unless u (setq disp (- disp)))
120              (if (and u
121                       p
122                       (not w)
123                       (eql arm::fn rnval)
124                       (eql (mod (- disp arm::misc-data-offset) 4) 0))
125                `(:@ ,rn (:constant ,(ash (- disp arm::misc-data-offset) -2)))
126                (if (and p (not w) (eql arm::pc rnval) (not (logtest 3 disp)))
127                  (let* ((target (+ i 2 (ash disp -2))))
128                    (when (< target (uvsize opcodes))
129                      (setf (adi-labeled (uvref opcodes target)) t))
130                    `(:= (:label ,target)))
131                  (if p
132                    (if w
133                      `(:@! ,rn (:$ ,disp))
134                      `(:@ ,rn (:$ ,disp)))
135                    `(:@+ ,rn (:$ ,disp))))))
136            (t
137             (let* ((shift-op (ldb (byte 2 5) opcode))
138                    (shift-count (ldb (byte 5 7) opcode))
139                    (rm (arm-gpr-name (ldb (byte 4 0) opcode)))
140                    (memop
141                     (if p
142                       (if w
143                         (if u :+@! :-@!)
144                         (if u :+@ :-@))
145                       (if u :@+ :@-))))
146               (if (and (zerop shift-count) (zerop shift-op))
147                 `(,memop ,rn ,rm)
148                 (if (and (eql 3 shift-op) (zerop shift-count))
149                   `(,memop ,rn (:rrx ,rm))
150                   `(,memop ,rn (,(svref *arm-shift-ops* shift-op)
151                                 ,rm
152                                 (:$ ,shift-count)))))))))))
153
154
155(defun extract-arm-reglist-operand (opcodes i)
156  (let* ((opcode (adi-opcode (svref opcodes i))))
157    (let* ((mask (ldb (byte 16 0) opcode))
158           (regs ()))
159      (declare (type (unsigned-byte 16) i))
160      (do* ((i 15 (1- i)))
161           ((< i 0) `(:reglist ,regs))
162        (declare ((signed-byte 4) i))
163        (when (logbitp i mask)
164          (push i regs))))))
165
166(defun extract-arm-rnw-operand (opcodes i)
167  (let* ((opcode (adi-opcode (svref opcodes i))))
168    (let* ((regname (arm-gpr-name (ldb (byte 4 16) opcode))))
169      (if (logbitp 21 opcode)
170        `(:! ,regname)
171        regname))))
172
173(defun extract-arm-uuoa-operand (opcodes i)
174  (let* ((opcode (adi-opcode (svref opcodes i))))
175    (arm-gpr-name (ldb (byte 4 8) opcode))))
176
177(defun extract-arm-uuo-unary-operand (opcodes i)
178  (let* ((opcode (adi-opcode (svref opcodes i))))
179    `(:$ ,(ldb (byte 8 12) opcode))))
180
181(defun extract-arm-uuob-operand (opcodes i)
182  (let* ((opcode (adi-opcode (svref opcodes i))))
183    (arm-gpr-name (ldb (byte 4 12) opcode))))
184
185(defun extract-arm-uuoc-operand (opcodes i)
186  (let* ((opcode (adi-opcode (svref opcodes i))))
187    (arm-gpr-name (ldb (byte 4 16) opcode))))
188
189(defun extract-arm-fpux-operand (opcodes i)
190  (let* ((opcode (adi-opcode (svref opcodes i))))
191    (case (ldb (byte 4 16) opcode)
192      (0 :fpsid)
193      (1 :fpscr)
194      (8 :fpexc)
195      (t (list :fpu (ldb (byte 4 16) opcode))))))
196
197(defun extract-arm-imm16-operand (opcodes i)
198  (let* ((opcode (adi-opcode (svref opcodes i))))
199    `(:$
200      ,(dpb (ldb (byte 4 16) opcode)
201         (byte 4 12)
202         (ldb (byte 12 0) opcode)))))
203
204(defun extract-arm-rm-operand (opcodes i)
205  (let* ((opcode (adi-opcode (svref opcodes i))))
206    (arm-gpr-name (ldb (byte 4 0) opcode))))
207
208(defun extract-arm-b-operand (opcodes i)
209  (let* ((opcode (adi-opcode (svref opcodes i)))
210         (b-field (ldb (byte 24 0) opcode)))
211    (when (logbitp 23 b-field)
212      (setq b-field (- b-field (ash 1 24))))
213    (let* ((target (+ i 2 b-field)))
214      (when (and (>= target 0)
215                 (< target (length opcodes)))
216        (setf (adi-labeled (svref opcodes target)) t))
217      `(:label ,target))))
218
219(defun extract-arm-subprim-operand (opcodes i)
220  (let* ((opcode (adi-opcode (svref opcodes i)))
221         (count (ash (ldb (byte 4 8) opcode) 1))
222         (spaddr (arm::arm-rotate-left (ldb (byte 8 0) opcode) (logand 31 (- 32 count))))
223         (name (arm::arm-subprimitive-name spaddr)))
224    (if name
225      `(:spname ,name)
226      `(:$ ,spaddr))))
227
228(defun extract-arm-m8-operand (opcodes i)
229  (let* ((opcode (adi-opcode (svref opcodes i))))
230    (let* ((immediate (logbitp 22 opcode))
231           (disp (dpb (ldb (byte 4 8) opcode)
232                      (byte 4 4)
233                      (ldb (byte 4 0) opcode)))
234           (p (logbitp 24 opcode))
235           (u (logbitp 23 opcode))
236           (w (logbitp 21 opcode))
237           (rnval (ldb (byte 4 16) opcode))
238           (rn (arm-gpr-name rnval)))
239      (cond (immediate
240             (unless u (setq disp (- disp)))
241             (if p
242               (if w
243                 `(:@! ,rn (:$ ,disp))
244                 `(:@ ,rn (:$ ,disp)))
245               `(:@+ ,rn (:$ ,disp))))
246            (t
247             (let* ((rm (arm-gpr-name (ldb (byte 4 0) opcode))))
248               `(,(if p
249                      (if w
250                        (if u :+@! :-@!)
251                        (if u :+@ :-@))
252                      (if u :@+ :@-)) ,rn ,rm)))))))
253
254(defun extract-arm-dd-operand (opcodes i)
255  (let* ((opcode (adi-opcode (svref opcodes i))))
256    (arm-fprd-name (ldb (byte 4 12) opcode))))
257
258(defun extract-arm-dm-operand (opcodes i)
259  (let* ((opcode (adi-opcode (svref opcodes i))))
260    (arm-fprd-name (ldb (byte 4 0) opcode))))
261
262(defun extract-arm-sd-operand (opcodes i)
263  (let* ((opcode (adi-opcode (svref opcodes i))))
264    (arm-fprs-name (logior (ash (ldb (byte 4 12) opcode) 1)
265                           (ldb (byte 1 22) opcode)))))
266
267(defun extract-arm-sm-operand (opcodes i)
268  (let* ((opcode (adi-opcode (svref opcodes i))))
269    (arm-fprs-name (logior (ash (ldb (byte 4 0) opcode) 1)
270                           (ldb (byte 1 5) opcode)))))
271
272(defun extract-arm-dn-operand (opcodes i)
273  (let* ((opcode (adi-opcode (svref opcodes i))))
274    (arm-fprd-name (ldb (byte 4 16) opcode))))
275
276(defun extract-arm-sn-operand (opcodes i)
277  (let* ((opcode (adi-opcode (svref opcodes i))))
278    (arm-fprs-name (logior (ash (ldb (byte 4 16) opcode) 1)
279                           (ldb (byte 1 7) opcode)))))
280
281
282(defparameter *arm-operand-extract-functions*
283  #(extract-arm-rd-operand
284    extract-arm-rn-operand
285    extract-arm-shifter-operand
286    extract-arm-m12-operand
287    extract-arm-reglist-operand
288    extract-arm-rnw-operand
289    extract-arm-uuoa-operand
290    extract-arm-uuo-unary-operand
291    extract-arm-uuob-operand
292    extract-arm-rm-operand
293    extract-arm-b-operand
294    extract-arm-subprim-operand
295    extract-arm-m8-operand
296    extract-arm-dd-operand
297    extract-arm-dm-operand
298    extract-arm-sd-operand
299    extract-arm-sm-operand
300    extract-arm-dn-operand
301    extract-arm-sn-operand
302    extract-arm-rd-operand                  ;rde
303    extract-arm-rs-operand
304    extract-arm-fpaddr-operand
305    extract-arm-@rn-operand
306    extract-arm-uuoc-operand
307    extract-arm-fpux-operand
308    extract-arm-imm16-operand
309    ))
310
311(defun make-adi-vector (code-vector)
312  (let* ((n (uvsize code-vector))
313         (v (make-array n)))
314    (declare (fixnum n) (simple-vector v))
315    (dotimes (i n v)
316      (setf (svref v i)
317            (make-arm-disassembled-instruction :opcode (uvref code-vector i))))))
318
319(defun process-adi-vector (adi-vector)
320  (let* ((n (length adi-vector))
321         (skip 0)
322         (data 0))
323    (dotimes (i n adi-vector)
324      (let* ((adi (svref adi-vector i))
325             (opcode (adi-opcode adi)))
326        (cond ((> skip 0)
327               (decf skip)
328               (if (= skip 0)
329                 (setq data opcode)))
330              ((> data 0)
331               (decf data)
332               (setf (adi-mnemonic adi) ":word"
333                     (adi-operands adi) (list opcode)))
334              ((= opcode 0)
335               (setq skip 2))
336              (t
337               (let* ((template (find-arm-instruction-template opcode)))
338                 (if (null template)
339                   (setf (adi-mnemonic adi) :???
340                         (adi-operands adi) (list opcode))
341                   (collect ((operands))
342                     (setf (adi-mnemonic adi)
343                           (arm::arm-instruction-template-name template))
344                     (unless (logtest (arm::encode-arm-instruction-flag :non-conditional) (arm::arm-instruction-template-flags template))
345                       (let* ((cond (ldb (byte 4 28) opcode))
346                              (cond-name (if (< cond 14) (arm::lookup-arm-condition-value cond))))
347                         (when cond-name
348                           (if (logtest (arm::encode-arm-instruction-flag :prefer-separate-cond) (arm::arm-instruction-template-flags template))
349                             (operands `(:? ,cond-name))
350                             (setf (adi-condition-name adi) cond-name)))))
351                     
352                     (dolist (type (arm::arm-instruction-template-operand-types template))
353                       (operands (funcall (svref *arm-operand-extract-functions* type) adi-vector i)))
354                     (setf (adi-operands adi) (operands)))))))))))
355
356(defparameter *arm-gpr-names*
357  #("imm0" "imm1" "nargs" "rcontext" "arg_z" "arg_y" "arg_x" "temp0"
358    "temp1" "temp2" "vsp" "fn" "allocptr" "sp" "lr" "pc"))
359
360(defun disassemble-arm-xfunction (xfunction &optional (stream *debug-io*))
361  (let* ((adi-vector (process-adi-vector (make-adi-vector (uvref xfunction 1))))
362         (functionp (typep xfunction 'function)) ;not cross-compiling
363         (previous-source-note nil))
364    (labels ((format-spname (name stream)
365               (let* ((string (string name))
366                      (n (length string))
367                      (copy (make-string n)))
368                 (declare (dynamic-extent copy))
369                 (dotimes (i n (format stream "~a" copy))
370                   (let* ((ch (char string i)))
371                     (setf (schar copy i)
372                           (if (< i 3)
373                             ch
374                             (char-downcase ch))))))))
375      (do* ((j (1- (length adi-vector)) (1- j)))
376           ((< j 0))
377        (let* ((info (svref adi-vector j))
378               (name (adi-mnemonic info)))
379          (when name
380            (unless (equal name ":word")
381              (unless (equal name "ba")
382                (return))
383              (unless (eq (adi-labeled info) t)
384                (return))
385              (setf (adi-labeled info)
386                    (concatenate 'string "L"
387                                 (with-output-to-string (s)
388                                                        (format-spname (cadr (car (adi-operands info))) s))))))))
389      (when functionp
390        (let ((source-note (function-source-note xfunction)))
391          (when source-note
392            ;; Fetch text from file if don't already have it
393            (ensure-source-note-text source-note)
394            (if (source-note-filename source-note)
395              (format t ";; Source: ~S:~D-~D"
396                      (source-note-filename source-note)
397                      (source-note-start-pos source-note)
398                      (source-note-end-pos source-note))
399              (let* ((source-text (source-note-text source-note)))
400                (when source-text
401                  (format t ";;; ~A" (string-sans-most-whitespace source-text 100))))))))
402      (dotimes (i (length adi-vector))
403        (when functionp
404          (let ((source-note (find-source-note-at-pc xfunction (* i 4))))
405            (unless (eql (source-note-file-range source-note)
406                         (source-note-file-range previous-source-note))
407              (setf previous-source-note source-note)
408              (let* ((source-text (source-note-text source-note))
409                     (text (if source-text
410                             (string-sans-most-whitespace source-text 100)
411                             "#<no source text>")))
412                (format stream "~&~%;;; ~A" text)))))
413        (let* ((info (svref adi-vector i))
414               (labeled (adi-labeled info)))
415          (when labeled
416            (if (eq t labeled)
417              (format stream "~&L~d~&" (ash i 2))
418              (format stream "~&~a~&" labeled)))
419          (let* ((name (adi-mnemonic info)))
420            (when name
421              (let* ((condition-name (or (adi-condition-name info) "")))
422                (format stream "~&  (~a~a" name condition-name))
423              (labels ((format-operand (operand)
424                         (write-char #\space stream)
425                         (if (atom operand)
426                           (if (and (typep operand 'integer)
427                                    (> (abs operand) 100))
428                             (format stream "#x~x" operand)
429                             (format stream "~d" operand))
430                           (ecase (car operand)
431                             (:= (format stream "(:=")
432                                 (format-operand (cadr operand))
433                                 (write-char #\) stream))
434                             (:label
435                              (let* ((target (if (< (cadr operand) (length adi-vector))
436                                               (svref adi-vector (cadr operand))))
437                                     (target-labeled (and target (adi-labeled target)))
438                                     (target-label (and (not (eq target-labeled t))
439                                                        target-labeled)))
440                                (if target-label
441                                  (format stream "~a" target-label)
442                                  (format stream "L~d" (ash (cadr operand) 2)))))
443                             (:constant (format stream "~s" (list 'quote (uvref xfunction (cadr operand)))))
444                             ((:lsl :lsr :asr :ror :rrx)
445                              (format stream "(:~a" (string-downcase (car operand)))
446                              (dolist (sub (cdr operand))
447                                (format-operand sub))
448                              (write-char #\) stream))
449                             (:spname
450                              (format-spname (cadr operand) stream))
451                             (:$
452                              (if (eql (cadr operand) arm::nil-value)
453                                (format stream "'nil")
454                                (progn
455                                  (format stream "(:$")
456                                  (format-operand (cadr operand))
457                                  (write-char #\) stream))))
458                             (:? (format stream "(:? ~a)" (cadr operand)))
459                             (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand))))
460                             (:single (format stream "s~d" (cadr operand)))
461                             (:double (format stream "d~d" (cadr operand)))
462                             (:reglist (format stream "~a"
463                                               (mapcar (lambda (r)
464                                                         (svref *arm-gpr-names* r))
465                                                       (cadr operand))))
466                             ((:@ :@! :+@ :+@! :-@ :-@! :@+ :@-)
467                              (format stream "(~s" (car operand))
468                              (dolist (sub (cdr operand))
469                                (format-operand sub))
470                              (write-char #\) stream))
471                             (:!
472                              (format stream "(:!")
473                              (format-operand (cadr operand))
474                              (write-char #\) stream))))))
475                (dolist (op (adi-operands info))
476                  (format-operand op))
477                (write-char #\) stream)))))))))
478
479                             
480                       
481             
482(defun arm-xdisassemble (function)
483  (disassemble-arm-xfunction function *standard-output*))
Note: See TracBrowser for help on using the repository browser.