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

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

Yet another scheme for subprim calls. Go ahead and laugh.
Details:

  • ba/bla are new pseudo instructions, identical to b/bl except that their operands are subprim names (or addresses).
  • for each subprim name/address referenced in a ba/bla instruction, the assembler generates an:

(ldr pc (:= data-word-containing-subprim-address))

instruction and makes the ba/bla branch to that instruction.

  • this is the only use of the "constant pool" and there are no longer user-visible directives for referencing pc-relative data. (We can load 32-bit integer constants via movw/movt instructions and initialize FPRs to constants via GPRs.)
  • by default, the disassembler hides this and shows ba/bla instructions.

Compared to the scheme of a few days ago, it's about the same speed
(b/bl to LDR vs mov reg/bx reg). If a subprim's called once per function
it's a little bigger; if there's more than one call site, it can be smaller.
(And we don't have to find a temp register.) If we can map the subprims
to addresses within 32MB of the pure area, then purify can turn the PC-relative
branches/bls to the LDR instructions into direct branches/bls to the code.

Compared to the original scheme (branch/bl to mov pc, #n) we don't flush
the pipeline on every call and don't have any constraints on subprimitive
addresses (they don't have to be expressible as ARM constants.)

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