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-ARCH") |
---|
19 | ) |
---|
20 | |
---|
21 | (in-package "ARM") |
---|
22 | |
---|
23 | (defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1) |
---|
24 | ("hs" . 2) ("cs" . 2) ("lo" . 3) ("cc" . 3) |
---|
25 | ("mi" . 4) ("pl" . 5) |
---|
26 | ("vs" . 6) ("vc" . 7) |
---|
27 | ("hi" . 8) ("ls" . 9) |
---|
28 | ("ge" . 10) ("lt" . 11) |
---|
29 | ("gt" . 12) ("le" . 13) |
---|
30 | ("al" . 14))) |
---|
31 | |
---|
32 | |
---|
33 | |
---|
34 | (defun lookup-arm-condition-name (name) |
---|
35 | (cdr (assoc name *arm-condition-names* :test #'string-equal))) |
---|
36 | |
---|
37 | (defun lookup-arm-condition-value (val) |
---|
38 | (car (rassoc val *arm-condition-names* :test #'eq))) |
---|
39 | |
---|
40 | (defun need-arm-condition-name (name) |
---|
41 | (or (lookup-arm-condition-name name) |
---|
42 | (error "Unknown ARM condition name ~s." name))) |
---|
43 | |
---|
44 | (defvar *arm-constants* ()) |
---|
45 | (defvar *lap-labels* ()) |
---|
46 | (defvar *called-subprim-jmp-labels* ()) |
---|
47 | (defvar *last-constant-pool-origin* ()) |
---|
48 | |
---|
49 | |
---|
50 | |
---|
51 | (defun arm-subprimitive-address (x) |
---|
52 | (if (and x (or (symbolp x) (stringp x))) |
---|
53 | (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'ccl::subprimitive-info-name))) |
---|
54 | (when info |
---|
55 | (ccl::subprimitive-info-offset info))))) |
---|
56 | |
---|
57 | (defun arm-subprimitive-name (addr) |
---|
58 | (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-info-offset))) |
---|
59 | (when info |
---|
60 | (string (ccl::subprimitive-info-name info))))) |
---|
61 | |
---|
62 | |
---|
63 | (defun arm-constant-index (form) |
---|
64 | (let* ((idx (or (assoc form *arm-constants* :test 'equal) |
---|
65 | (let* ((n (length *arm-constants*))) |
---|
66 | (push (cons form n) *arm-constants*) |
---|
67 | n)))) |
---|
68 | (+ (ash (+ idx 2) arm::word-shift) ; skip entrypoint, codevector |
---|
69 | arm::misc-data-offset))) |
---|
70 | |
---|
71 | |
---|
72 | |
---|
73 | (defun need-constant (form) |
---|
74 | (if (ccl::quoted-form-p form) |
---|
75 | (let* ((quoted (ccl::nx-unquote form))) |
---|
76 | (if (null quoted) |
---|
77 | arm::canonical-nil-value |
---|
78 | (if (typep quoted '(signed-byte 30)) |
---|
79 | (ash quoted arm::fixnumshift) |
---|
80 | (arm-constant-index quoted)))) |
---|
81 | (progn |
---|
82 | (unless (and (consp form) (eq (keywordize (car form)) :$)) |
---|
83 | (error "Invalid constant syntax in ~s" form)) |
---|
84 | (destructuring-bind (val) (cdr form) |
---|
85 | (eval val))))) |
---|
86 | |
---|
87 | |
---|
88 | (defstruct arm-instruction-template |
---|
89 | name |
---|
90 | ordinal ;if we need this |
---|
91 | val |
---|
92 | (flags 0) |
---|
93 | operand-types |
---|
94 | mask-list) |
---|
95 | |
---|
96 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
97 | |
---|
98 | (defparameter *arm-operand-types* |
---|
99 | #(:rd ; destination register in bits 12:15 |
---|
100 | :rn ; unshifted source/base reg in 16:19 |
---|
101 | :shifter ; composite operand for ALU ops |
---|
102 | :mem12 ; 12-bit address for LDR/STR/LDRB/STB |
---|
103 | :reglist |
---|
104 | :rnw ; rn, with optional writeback. |
---|
105 | :uuoA ; GPR in UUO bits 8:11 |
---|
106 | :uuo-unary ; constant in UUO bits 12:15 |
---|
107 | :uuoB ; GPR in UUO bits 12:15 |
---|
108 | :rm |
---|
109 | :b |
---|
110 | :subprim |
---|
111 | :mem8 |
---|
112 | :dd |
---|
113 | :dm |
---|
114 | :sd |
---|
115 | :sm |
---|
116 | :dn |
---|
117 | :sn |
---|
118 | :rde |
---|
119 | :rs |
---|
120 | :fpaddr |
---|
121 | :@rn |
---|
122 | :uuoC |
---|
123 | :fpux |
---|
124 | :imm16 |
---|
125 | )) |
---|
126 | |
---|
127 | (defun %encode-arm-operand-type (name) |
---|
128 | (or (position name *arm-operand-types* :test #'eq) |
---|
129 | (error "Unknown ARM operand type name ~s." name))) |
---|
130 | |
---|
131 | (defmacro encode-arm-operand-type (name) |
---|
132 | (%encode-arm-operand-type name)) |
---|
133 | |
---|
134 | (ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-") |
---|
135 | non-conditional ;doesn't use standard condition field |
---|
136 | prefer-separate-cond |
---|
137 | ) |
---|
138 | |
---|
139 | (defparameter *arm-instruction-flag-names* |
---|
140 | `((:non-conditional . ,arm-instruction-flag-non-conditional) |
---|
141 | (:prefer-separate-cond . ,arm-instruction-flag-prefer-separate-cond) |
---|
142 | )) |
---|
143 | |
---|
144 | (defun %encode-arm-instruction-flag (name) |
---|
145 | (flet ((encode-one-instruction-type (name) |
---|
146 | (ash 1 (or (cdr (assoc name *arm-instruction-flag-names* :test #'eq)) |
---|
147 | (error "Unknown ARM instruction type: ~s" name))))) |
---|
148 | (if name |
---|
149 | (if (atom name) |
---|
150 | (encode-one-instruction-type name) |
---|
151 | (let* ((mask 0)) |
---|
152 | (dolist (n name mask) |
---|
153 | (setq mask (logior mask (encode-one-instruction-type n)))))) |
---|
154 | 0))) |
---|
155 | ) |
---|
156 | |
---|
157 | (defmacro encode-arm-instruction-flag (name) |
---|
158 | (%encode-arm-instruction-flag name)) |
---|
159 | |
---|
160 | (defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp)) |
---|
161 | |
---|
162 | |
---|
163 | |
---|
164 | (defun %define-arm-instruction (name value mask-list flags operand-types) |
---|
165 | (make-arm-instruction-template :name name |
---|
166 | :val value |
---|
167 | :ordinal nil |
---|
168 | :mask-list mask-list |
---|
169 | :flags (or flags 0) |
---|
170 | :operand-types operand-types)) |
---|
171 | |
---|
172 | (defmacro define-arm-instruction (name operand-type-names value mask-list flag-names) |
---|
173 | `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'%encode-arm-operand-type operand-type-names) )) |
---|
174 | |
---|
175 | |
---|
176 | |
---|
177 | (defparameter *arm-instruction-table* |
---|
178 | (vector |
---|
179 | |
---|
180 | (define-arm-instruction clrex () |
---|
181 | #xf57ff01f |
---|
182 | #xffffffff |
---|
183 | (:non-conditional)) |
---|
184 | |
---|
185 | ;;; UUOs. |
---|
186 | |
---|
187 | ;;; Nullary UUOs |
---|
188 | (define-arm-instruction uuo-alloc-trap () |
---|
189 | #x07f000f0 |
---|
190 | #x0fffffff |
---|
191 | (:prefer-separate-cond)) |
---|
192 | (define-arm-instruction uuo-error-wrong-nargs () |
---|
193 | #x07f001f8 |
---|
194 | #x0fffffff |
---|
195 | (:prefer-separate-cond)) |
---|
196 | (define-arm-instruction uuo-gc-trap () |
---|
197 | #x07f002f0 |
---|
198 | #x0fffffff |
---|
199 | (:prefer-separate-cond)) |
---|
200 | (define-arm-instruction uuo-debug-trap () |
---|
201 | #x07f003f0 |
---|
202 | #x0fffffff |
---|
203 | (:prefer-separate-cond)) |
---|
204 | (define-arm-instruction uuo-interrupt-now () |
---|
205 | #x07f004f0 |
---|
206 | #x0fffffff |
---|
207 | (:prefer-separate-cond)) |
---|
208 | (define-arm-instruction uuo-suspend-now () |
---|
209 | #x07f005f0 |
---|
210 | #x0fffffff |
---|
211 | (:prefer-separate-cond)) |
---|
212 | ;;; Misc format |
---|
213 | (define-arm-instruction uuo-error-reg-not-lisptag (:uuoA :uuo-unary) |
---|
214 | #x07f000f2 |
---|
215 | #x0ff000ff |
---|
216 | (:prefer-separate-cond)) |
---|
217 | (define-arm-instruction uuo-error-reg-not-fulltag (:uuoA :uuo-unary) |
---|
218 | #x07f000f3 |
---|
219 | #x0ff000ff |
---|
220 | (:prefer-separate-cond)) |
---|
221 | (define-arm-instruction uuo-error-reg-not-xtype (:uuoA :uuo-unary) |
---|
222 | #x07f000f4 |
---|
223 | #x0ff000ff |
---|
224 | (:prefer-separate-cond)) |
---|
225 | (define-arm-instruction uuo-cerror-reg-not-lisptag (:uuoA :uuo-unary) |
---|
226 | #x07f000fa |
---|
227 | #x0ff000ff |
---|
228 | (:prefer-separate-cond)) |
---|
229 | (define-arm-instruction uuo-cerror-reg-not-fulltag (:uuoA :uuo-unary) |
---|
230 | #x07f000fb |
---|
231 | #x0ff000ff |
---|
232 | (:prefer-separate-cond)) |
---|
233 | (define-arm-instruction uuo-cerror-reg-not-xtype (:uuoA :uuo-unary) |
---|
234 | #x07f000fc |
---|
235 | #x0ff000ff |
---|
236 | (:prefer-separate-cond)) |
---|
237 | |
---|
238 | ;;; Unary UUOs |
---|
239 | (define-arm-instruction uuo-error-unbound (:uuoA) |
---|
240 | #x07f000f9 |
---|
241 | #x0ffff0ff |
---|
242 | (:prefer-separate-cond)) |
---|
243 | (define-arm-instruction uuo-cerror-unbound (:uuoA) |
---|
244 | #x07f010f9 |
---|
245 | #x0ffff0ff |
---|
246 | (:prefer-separate-cond)) |
---|
247 | (define-arm-instruction uuo-error-not-callable (:uuoA) |
---|
248 | #x07f020f9 |
---|
249 | #x0ffff0ff |
---|
250 | (:prefer-separate-cond)) |
---|
251 | (define-arm-instruction uuo-tlb-too-small (:uuoA) |
---|
252 | #x07f030f1 |
---|
253 | #x0ffff0ff |
---|
254 | (:prefer-separate-cond)) |
---|
255 | (define-arm-instruction uuo-error-no-throw-tag (:uuoA) |
---|
256 | #x07f040f9 |
---|
257 | #x0ffff0ff |
---|
258 | (:prefer-separate-cond)) |
---|
259 | (define-arm-instruction uuo-error-udf-call (:uuoA) |
---|
260 | #x07f050f9 |
---|
261 | #x0ffff0ff |
---|
262 | (:prefer-separate-cond)) |
---|
263 | (define-arm-instruction uuo-error-udf (:uuoA) |
---|
264 | #x07f060f9 |
---|
265 | #x0ffff0ff |
---|
266 | (:prefer-separate-cond)) |
---|
267 | |
---|
268 | ;;; Binary UUOs |
---|
269 | (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB) |
---|
270 | #x07f000ff |
---|
271 | #x0fff00ff |
---|
272 | (:prefer-separate-cond)) |
---|
273 | (define-arm-instruction uuo-error-array-bounds (:uuoA :uuoB) |
---|
274 | #x07f100ff |
---|
275 | #x0fff00ff |
---|
276 | (:prefer-separate-cond)) |
---|
277 | (define-arm-instruction uuo-error-integer-divide-by-zero (:uuoA :uuoB) |
---|
278 | #x07f200ff |
---|
279 | #x0fff00ff |
---|
280 | (:prefer-separate-cond)) |
---|
281 | (define-arm-instruction uuo-error-slot-unbound (:uuoA :uuoB :uuoC) |
---|
282 | #x07f000fe |
---|
283 | #x0ff000ff |
---|
284 | (:prefer-separate-cond)) |
---|
285 | (define-arm-instruction uuo-eep-unresolved (:uuoA :uuoB) |
---|
286 | #x07f400ff |
---|
287 | #x0fff00ff |
---|
288 | (:prefer-separate-cond)) |
---|
289 | (define-arm-instruction uuo-fpu-exception (:uuoA :uuoB) |
---|
290 | #x07f500ff |
---|
291 | #x0fff00ff |
---|
292 | (:prefer-separate-cond)) |
---|
293 | (define-arm-instruction uuo-error-array-rank (:uuoA :uuoB) |
---|
294 | #x07f600ff |
---|
295 | #x0fff00ff |
---|
296 | (:prefer-separate-cond)) |
---|
297 | (define-arm-instruction uuo-error-array-flags (:uuoA :uuoB) |
---|
298 | #x07f700ff |
---|
299 | #x0fff00ff |
---|
300 | (:prefer-separate-cond)) |
---|
301 | ;; Kernel services. |
---|
302 | (define-arm-instruction uuo-kernel-service (:uuo-unary) |
---|
303 | #x07f000fd |
---|
304 | #x0fff00ff |
---|
305 | (:prefer-separate-cond)) |
---|
306 | |
---|
307 | ;; movw, movt require ARMv6T2 or later |
---|
308 | (define-arm-instruction movw (:rd :imm16) |
---|
309 | #x03000000 |
---|
310 | #x0ff00000 |
---|
311 | ()) |
---|
312 | (define-arm-instruction movt (:rd :imm16) |
---|
313 | #x03400000 |
---|
314 | #x0ff00000 |
---|
315 | ()) |
---|
316 | |
---|
317 | (define-arm-instruction and (:rd :rn :shifter) |
---|
318 | #x00000000 |
---|
319 | ((#x02000000 . #x0ff00000) |
---|
320 | (#x00000000 . #x0ff00010) |
---|
321 | (#x00000010 . #x0ff00090)) |
---|
322 | ()) |
---|
323 | (define-arm-instruction ands (:rd :rn :shifter) |
---|
324 | #x00100000 |
---|
325 | ((#x02100000 . #x0ff00000) |
---|
326 | (#x00100000 . #x0ff00010) |
---|
327 | (#x00100010 . #x0ff00090)) |
---|
328 | ()) |
---|
329 | (define-arm-instruction eor (:rd :rn :shifter) |
---|
330 | #x00200000 |
---|
331 | ((#x02200000 . #x0ff00000) |
---|
332 | (#x00200000 . #x0ff00010) |
---|
333 | (#x00200010 . #x0ff00090)) |
---|
334 | ()) |
---|
335 | (define-arm-instruction eors (:rd :rn :shifter) |
---|
336 | #x00300000 |
---|
337 | ((#x02300000 . #x0ff00000) |
---|
338 | (#x00300000 . #x0ff00010) |
---|
339 | (#x00300010 . #x0ff00090)) |
---|
340 | ()) |
---|
341 | (define-arm-instruction sub (:rd :rn :shifter) |
---|
342 | #x00400000 |
---|
343 | ((#x02400000 . #x0ff00000) |
---|
344 | (#x00400000 . #x0ff00010) |
---|
345 | (#x00400010 . #x0ff00090)) |
---|
346 | ()) |
---|
347 | (define-arm-instruction subs (:rd :rn :shifter) |
---|
348 | #x00500000 |
---|
349 | ((#x02500000 . #x0ff00000) |
---|
350 | (#x00500000 . #x0ff00010) |
---|
351 | (#x00500010 . #x0ff00090)) |
---|
352 | ()) |
---|
353 | (define-arm-instruction rsb (:rd :rn :shifter) |
---|
354 | #x00600000 |
---|
355 | ((#x02600000 . #x0ff00000) |
---|
356 | (#x00600000 . #x0ff00010) |
---|
357 | (#x00600010 . #x0ff00090)) |
---|
358 | ()) |
---|
359 | (define-arm-instruction rsbs (:rd :rn :shifter) |
---|
360 | #x00700000 |
---|
361 | ((#x02700000 . #x0ff00000) |
---|
362 | (#x00700000 . #x0ff00010) |
---|
363 | (#x00700010 . #x0ff00090)) |
---|
364 | ()) |
---|
365 | (define-arm-instruction add (:rd :rn :shifter) |
---|
366 | #x00800000 |
---|
367 | ((#x02800000 . #x0ff00000) |
---|
368 | (#x00800000 . #x0ff00010) |
---|
369 | (#x00800010 . #x0ff00090)) |
---|
370 | ()) |
---|
371 | (define-arm-instruction adds (:rd :rn :shifter) |
---|
372 | #x00900000 |
---|
373 | ((#x02900000 . #x0ff00000) |
---|
374 | (#x00900000 . #x0ff00010) |
---|
375 | (#x00900010 . #x0ff00090)) |
---|
376 | ()) |
---|
377 | |
---|
378 | (define-arm-instruction adc (:rd :rn :shifter) |
---|
379 | #x00a00000 |
---|
380 | ((#x02a00000 . #x0ff00000) |
---|
381 | (#x00a00000 . #x0ff00010) |
---|
382 | (#x00a00010 . #x0ff00090)) |
---|
383 | ()) |
---|
384 | (define-arm-instruction adcs (:rd :rn :shifter) |
---|
385 | #x00b00000 |
---|
386 | ((#x02b00000 . #x0ff00000) |
---|
387 | (#x00b00000 . #x0ff00010) |
---|
388 | (#x00b00010 . #x0ff00090)) |
---|
389 | ()) |
---|
390 | (define-arm-instruction sbc (:rd :rn :shifter) |
---|
391 | #x00c00000 |
---|
392 | ((#x02c00000 . #x0ff00000) |
---|
393 | (#x00c00000 . #x0ff00010) |
---|
394 | (#x00c00010 . #x0ff00090)) |
---|
395 | ()) |
---|
396 | (define-arm-instruction sbcs (:rd :rn :shifter) |
---|
397 | #x00d00000 |
---|
398 | ((#x02d00000 . #x0ff00000) |
---|
399 | (#x00d00000 . #x0ff00010) |
---|
400 | (#x00d00010 . #x0ff00090)) |
---|
401 | ()) |
---|
402 | (define-arm-instruction rsc (:rd :rn :shifter) |
---|
403 | #x00e00000 |
---|
404 | ((#x02e00000 . #x0ff00000) |
---|
405 | (#x00e00000 . #x0ff00010) |
---|
406 | (#x00e00010 . #x0ff00090)) |
---|
407 | ()) |
---|
408 | (define-arm-instruction rscs (:rd :rn :shifter) |
---|
409 | #x00e00000 |
---|
410 | ((#x02e00000 . #x0ff00000) |
---|
411 | (#x00e00000 . #x0ff00010) |
---|
412 | (#x00e00010 . #x0ff00090)) |
---|
413 | ()) |
---|
414 | (define-arm-instruction tst (:rn :shifter) |
---|
415 | #x01100000 |
---|
416 | ((#x03100000 . #x0ff00000) |
---|
417 | (#x01100000 . #x0ff00010) |
---|
418 | (#x01100010 . #x0ff00090)) |
---|
419 | ()) |
---|
420 | (define-arm-instruction tsts (:rn :shifter) |
---|
421 | #x01100000 |
---|
422 | ((#x03100000 . #x0ff00000) |
---|
423 | (#x01100000 . #x0ff00010) |
---|
424 | (#x01100010 . #x0ff00090)) |
---|
425 | ()) |
---|
426 | (define-arm-instruction orr (:rd :rn :shifter) |
---|
427 | #x01800000 |
---|
428 | ((#x03800000 . #x0ff00000) |
---|
429 | (#x01800000 . #x0ff00010) |
---|
430 | (#x01800010 . #x0ff00090)) |
---|
431 | ()) |
---|
432 | (define-arm-instruction orrs (:rd :rn :shifter) |
---|
433 | #x01900000 |
---|
434 | ((#x03900000 . #x0ff00000) |
---|
435 | (#x01900000 . #x0ff00010) |
---|
436 | (#x01900010 . #x0ff00090)) |
---|
437 | ()) |
---|
438 | (define-arm-instruction bic (:rd :rn :shifter) |
---|
439 | #x01c00000 |
---|
440 | ((#x03c00000 . #x0ff00000) |
---|
441 | (#x01c00000 . #x0ff00010) |
---|
442 | (#x01c00010 . #x0ff00090)) |
---|
443 | ()) |
---|
444 | (define-arm-instruction bics (:rd :rn :shifter) |
---|
445 | #x01d00000 |
---|
446 | ((#x03d00000 . #x0ff00000) |
---|
447 | (#x01d00000 . #x0ff00010) |
---|
448 | (#x01d00010 . #x0ff00090)) |
---|
449 | ()) |
---|
450 | (define-arm-instruction cmp (:rn :shifter) |
---|
451 | #x01500000 |
---|
452 | ((#x03500000 . #x0ff00000) |
---|
453 | (#x01500000 . #x0ff00010) |
---|
454 | (#x01500010 . #x0ff00090)) |
---|
455 | ()) |
---|
456 | (define-arm-instruction cmps (:rn :shifter) |
---|
457 | #x01500000 |
---|
458 | ((#x03500000 . #x0ff00000) |
---|
459 | (#x01500000 . #x0ff00010) |
---|
460 | (#x01500010 . #x0ff00090)) |
---|
461 | ()) |
---|
462 | (define-arm-instruction cmn (:rd :shifter) |
---|
463 | #x01700000 |
---|
464 | ((#x03700000 . #x0ff00000) |
---|
465 | (#x01700000 . #x0ff00010) |
---|
466 | (#x01700010 . #x0ff00090)) |
---|
467 | ()) |
---|
468 | |
---|
469 | (define-arm-instruction cmns (:rd :shifter) |
---|
470 | #x01700000 |
---|
471 | ((#x03700000 . #x0ff00000) |
---|
472 | (#x01700000 . #x0ff00010) |
---|
473 | (#x01700010 . #x0ff00090)) |
---|
474 | ()) |
---|
475 | |
---|
476 | |
---|
477 | ;; (ba subprim-name) -> (mov pc ($ subprim-address)) |
---|
478 | (define-arm-instruction ba (:subprim) |
---|
479 | #x03a0f000 |
---|
480 | #x0ffff000 |
---|
481 | ()) |
---|
482 | |
---|
483 | (define-arm-instruction mov (:rd :shifter) |
---|
484 | #x01a00000 |
---|
485 | ((#x03a00000 . #x0ff00000) |
---|
486 | (#x01a00000 . #x0ff00010) |
---|
487 | (#x01a00010 . #x0ff00090)) |
---|
488 | ()) |
---|
489 | (define-arm-instruction movs (:rd :shifter) |
---|
490 | #x01b00000 |
---|
491 | ((#x03b00000 . #x0ff00000) |
---|
492 | (#x01b00000 . #x0ff00010) |
---|
493 | (#x01b00010 . #x0ff00090)) |
---|
494 | ()) |
---|
495 | (define-arm-instruction mvn (:rd :shifter) |
---|
496 | #x01e00000 |
---|
497 | ((#x03e00000 . #x0ff00000) |
---|
498 | (#x01e00000 . #x0ff00010) |
---|
499 | (#x01e00010 . #x0ff00090)) |
---|
500 | ()) |
---|
501 | (define-arm-instruction mvns (:rd :shifter) |
---|
502 | #x01f00000 |
---|
503 | ((#x03f00000 . #x0ff00000) |
---|
504 | (#x01f00000 . #x0ff00010) |
---|
505 | (#x01f00010 . #x0ff00090)) |
---|
506 | ()) |
---|
507 | |
---|
508 | (define-arm-instruction ldr (:rd :mem12) |
---|
509 | #x04100000 |
---|
510 | #x0c500000 |
---|
511 | ()) |
---|
512 | (define-arm-instruction ldrb (:rd :mem12) |
---|
513 | #x04500000 |
---|
514 | #x0c500000 |
---|
515 | ()) |
---|
516 | (define-arm-instruction str (:rd :mem12) |
---|
517 | #x04000000 |
---|
518 | #x0c500000 |
---|
519 | ()) |
---|
520 | (define-arm-instruction strb (:rd :mem12) |
---|
521 | #x04400000 |
---|
522 | #x0c500000 |
---|
523 | ()) |
---|
524 | (define-arm-instruction ldrh (:rd :mem8) |
---|
525 | #x001000b0 |
---|
526 | #x0e3000f0 |
---|
527 | ()) |
---|
528 | (define-arm-instruction strh (:rd :mem8) |
---|
529 | #x000000b0 |
---|
530 | #x0e3000f0 |
---|
531 | ()) |
---|
532 | (define-arm-instruction ldrsh (:rd :mem8) |
---|
533 | #x001000f0 |
---|
534 | #x0e3000f0 |
---|
535 | ()) |
---|
536 | (define-arm-instruction ldrsb (:rd :mem8) |
---|
537 | #x001000d0 |
---|
538 | #x0e3000f0 |
---|
539 | ()) |
---|
540 | (define-arm-instruction ldrd (:rde :mem8) |
---|
541 | #x000000d0 |
---|
542 | #x0e1000f0 |
---|
543 | ()) |
---|
544 | (define-arm-instruction strd (:rde :mem8) |
---|
545 | #x000000f0 |
---|
546 | #x0e1000f0 |
---|
547 | ()) |
---|
548 | |
---|
549 | (define-arm-instruction mul (:rn :rm :rs) |
---|
550 | #x00000090 |
---|
551 | #x0ff000f0 |
---|
552 | ()) |
---|
553 | (define-arm-instruction muls (:rn :rm :rs) |
---|
554 | #x00100090 |
---|
555 | #x0ff000f0 |
---|
556 | ()) |
---|
557 | |
---|
558 | (define-arm-instruction stm (:rnw :reglist) |
---|
559 | #x08800000 |
---|
560 | #x0fd00000 |
---|
561 | ()) |
---|
562 | (define-arm-instruction stmia (:rnw :reglist) |
---|
563 | #x08800000 |
---|
564 | #x0fd00000 |
---|
565 | ()) |
---|
566 | (define-arm-instruction stmea (:rnw :reglist) |
---|
567 | #x08800000 |
---|
568 | #x0fd00000 |
---|
569 | ()) |
---|
570 | (define-arm-instruction ldmia (:rnw :reglist) |
---|
571 | #x08900000 |
---|
572 | #x0fd00000 |
---|
573 | ()) |
---|
574 | (define-arm-instruction ldm (:rnw :reglist) |
---|
575 | #x08900000 |
---|
576 | #x0fd00000 |
---|
577 | ()) |
---|
578 | (define-arm-instruction ldmfd (:rnw :reglist) |
---|
579 | #x08900000 |
---|
580 | #x0fd00000 |
---|
581 | ()) |
---|
582 | (define-arm-instruction stmdb (:rnw :reglist) |
---|
583 | #x09000000 |
---|
584 | #x0fd00000 |
---|
585 | ()) |
---|
586 | (define-arm-instruction stmfb (:rnw :reglist) |
---|
587 | #x09000000 |
---|
588 | #x0fd00000 |
---|
589 | ()) |
---|
590 | (define-arm-instruction stmfd (:rnw :reglist) |
---|
591 | #x09000000 |
---|
592 | #x0ff00000 |
---|
593 | ()) |
---|
594 | (define-arm-instruction ldmdb (:rnw :reglist) |
---|
595 | #x09100000 |
---|
596 | #x0fd00000 |
---|
597 | ()) |
---|
598 | (define-arm-instruction ldmea (:rnw :reglist) |
---|
599 | #x09100000 |
---|
600 | #x0fd00000 |
---|
601 | ()) |
---|
602 | |
---|
603 | (define-arm-instruction b (:b) |
---|
604 | #x0a000000 |
---|
605 | #x0f000000 |
---|
606 | ()) |
---|
607 | (define-arm-instruction bl (:b) |
---|
608 | #x0b000000 |
---|
609 | #x0f000000 |
---|
610 | ()) |
---|
611 | (define-arm-instruction bx (:rm) |
---|
612 | #x012fff10 |
---|
613 | #x0ffffff0 |
---|
614 | ()) |
---|
615 | (define-arm-instruction blx (:rm) |
---|
616 | #x012fff30 |
---|
617 | #x0ffffff0 |
---|
618 | ()) |
---|
619 | |
---|
620 | ;;; VFP instructions |
---|
621 | (define-arm-instruction fabsd (:dd :dm) |
---|
622 | #x0eb00bc0 |
---|
623 | #x0fff0ff0 |
---|
624 | ()) |
---|
625 | (define-arm-instruction fabss (:sd :sm) |
---|
626 | #x0eb00ac0 |
---|
627 | #x0fbf0fb0 |
---|
628 | ()) |
---|
629 | (define-arm-instruction fnegd (:dd :dm) |
---|
630 | #x0ed10b40 |
---|
631 | #x0fff0ff0 |
---|
632 | ()) |
---|
633 | (define-arm-instruction fnegs (:sd :sm) |
---|
634 | #x0ed10a40 |
---|
635 | #x0bff0fb0 |
---|
636 | ()) |
---|
637 | (define-arm-instruction fsqrtd (:dd :dm) |
---|
638 | #x0eb10bc0 |
---|
639 | #x0fff0ff0 |
---|
640 | ()) |
---|
641 | (define-arm-instruction fsqrts (:sd :sm) |
---|
642 | #x0eb10ac0 |
---|
643 | #x0bff0fb0 |
---|
644 | ()) |
---|
645 | (define-arm-instruction faddd (:dd :dn :dm) |
---|
646 | #x0e300b00 |
---|
647 | #x0ff00ff0 |
---|
648 | ()) |
---|
649 | (define-arm-instruction fadds (:sd :sn :sm) |
---|
650 | #x0e300a00 |
---|
651 | #x0f300f50 |
---|
652 | ()) |
---|
653 | (define-arm-instruction fmsr (:sn :rd) |
---|
654 | #x0e000a10 |
---|
655 | #x0ff00f90 |
---|
656 | ()) |
---|
657 | (define-arm-instruction fmrs (:rd :sn) |
---|
658 | #x0e100a10 |
---|
659 | #x0ff00f90 |
---|
660 | ()) |
---|
661 | (define-arm-instruction fmrrd (:rd :rn :dm) |
---|
662 | #x0c500b10 |
---|
663 | #x0ff00ff0 |
---|
664 | ()) |
---|
665 | (define-arm-instruction fmdrr (:dm :rd :rn) |
---|
666 | #x0c400b10 |
---|
667 | #x0ff00ff0 |
---|
668 | ()) |
---|
669 | (define-arm-instruction fsitod (:dd :sm) |
---|
670 | #x0eb80bc0 |
---|
671 | #x0fff0fc0 |
---|
672 | ()) |
---|
673 | (define-arm-instruction fsitos (:sd :sm) |
---|
674 | #x0eb80ac0 |
---|
675 | #x0fff0fc0 |
---|
676 | ()) |
---|
677 | (define-arm-instruction fcmped (:dd :dm) |
---|
678 | #x0eb40bc0 |
---|
679 | #x0fff0fc0 |
---|
680 | ()) |
---|
681 | (define-arm-instruction fcmpes (:sd :sm) |
---|
682 | #x0eb40ac0 |
---|
683 | #x0fff0fc0 |
---|
684 | ()) |
---|
685 | (define-arm-instruction fmstat () |
---|
686 | #x0ef1fa10 |
---|
687 | #x0fffffff |
---|
688 | ()) |
---|
689 | (define-arm-instruction fsubd (:dd :dn :dm) |
---|
690 | #x0e300b40 |
---|
691 | #x0ff00fc0 |
---|
692 | ()) |
---|
693 | (define-arm-instruction fsubs (:sd :sn :sm) |
---|
694 | #x0e300a40 |
---|
695 | #x0ff00fc0 |
---|
696 | ()) |
---|
697 | (define-arm-instruction fmuld (:dd :dn :dm) |
---|
698 | #x0e200b00 |
---|
699 | #x0ff00ff0 |
---|
700 | ()) |
---|
701 | (define-arm-instruction fmuls (:sd :sn :sm) |
---|
702 | #x0e200a00 |
---|
703 | #x0ff00f50 |
---|
704 | ()) |
---|
705 | (define-arm-instruction fdivd (:dd :dn :dm) |
---|
706 | #x0e800b00 |
---|
707 | #x0ff00ff0 |
---|
708 | ()) |
---|
709 | (define-arm-instruction fdivs (:sd :sn :sm) |
---|
710 | #x0e800a00 |
---|
711 | #x0ff00f50 |
---|
712 | ()) |
---|
713 | (define-arm-instruction fcpyd (:dd :dm) |
---|
714 | #x0eb00b40 |
---|
715 | #x0fb00ff0 |
---|
716 | ()) |
---|
717 | (define-arm-instruction fcpys (:sd :sm) |
---|
718 | #x0eb00a40 |
---|
719 | #x0fb00fc0 |
---|
720 | ()) |
---|
721 | (define-arm-instruction fcvtsd (:sd :dm) |
---|
722 | #x0eb70bc0 |
---|
723 | #x0fbf0ff0 |
---|
724 | ()) |
---|
725 | (define-arm-instruction fcvtds (:dd :sm) |
---|
726 | #x0eb70ac0 |
---|
727 | #x0ff70ac0 |
---|
728 | ()) |
---|
729 | (define-arm-instruction fmxr (:fpux :rd) |
---|
730 | #x0ee00a10 |
---|
731 | #x0ff00fff |
---|
732 | ()) |
---|
733 | (define-arm-instruction fmrx (:rd :fpux) |
---|
734 | #x0ef00a10 |
---|
735 | #x0ff00fff |
---|
736 | ()) |
---|
737 | (define-arm-instruction smull (:rd :rn :rm :rs) |
---|
738 | #x00c00090 |
---|
739 | #x0ff000f0 |
---|
740 | ()) |
---|
741 | (define-arm-instruction smulls (:rd :rn :rm :rs) |
---|
742 | #x00d00090 |
---|
743 | #x0ff000f0 |
---|
744 | ()) |
---|
745 | (define-arm-instruction umull (:rd :rn :rm :rs) |
---|
746 | #x00800090 |
---|
747 | #x0ff000f0 |
---|
748 | ()) |
---|
749 | (define-arm-instruction umulls (:rd :rn :rm :rs) |
---|
750 | #x00900090 |
---|
751 | #x0ff000f0 |
---|
752 | ()) |
---|
753 | |
---|
754 | (define-arm-instruction fstd (:dd :fpaddr) |
---|
755 | #x0d000b00 |
---|
756 | #x0f700f00 |
---|
757 | ()) |
---|
758 | (define-arm-instruction fsts (:sd :fpaddr) |
---|
759 | #x0d000a00 |
---|
760 | #x0f300f00 |
---|
761 | ()) |
---|
762 | (define-arm-instruction fldd (:dd :fpaddr) |
---|
763 | #x0d100b00 |
---|
764 | #x0f700f00 |
---|
765 | ()) |
---|
766 | (define-arm-instruction flds (:sd :fpaddr) |
---|
767 | #x0d100a00 |
---|
768 | #x0f300f00 |
---|
769 | ()) |
---|
770 | (define-arm-instruction ftosid (:sd :dm) |
---|
771 | #x0ebd0b40 |
---|
772 | #x0fbf0fc0 |
---|
773 | ()) |
---|
774 | (define-arm-instruction ftosizd (:sd :dm) |
---|
775 | #x0ebd0bc0 |
---|
776 | #x0fbf0fc0 |
---|
777 | ()) |
---|
778 | (define-arm-instruction ftosis (:sd :sm) |
---|
779 | #x0ebd0a40 |
---|
780 | #x0fbf0fc0 |
---|
781 | ()) |
---|
782 | (define-arm-instruction ftosizs (:sd :sm) |
---|
783 | #x0ebd0ac0 |
---|
784 | #x0fbf0fc0 |
---|
785 | ()) |
---|
786 | (define-arm-instruction ldrex (:rd :@rn) |
---|
787 | #x01900f9f |
---|
788 | #x0ff00fff |
---|
789 | ()) |
---|
790 | (define-arm-instruction strex (:rd :rm :@rn) |
---|
791 | #x01800f90 |
---|
792 | #x0ff00ff0 |
---|
793 | ()) |
---|
794 | (define-arm-instruction clz (:rd :rm) |
---|
795 | #x016f0f10 |
---|
796 | #x0fff0ff0 |
---|
797 | ()) |
---|
798 | )) |
---|
799 | |
---|
800 | (dotimes (i (length *arm-instruction-table*)) |
---|
801 | (let* ((template (svref *arm-instruction-table* i)) |
---|
802 | (name (arm-instruction-template-name template))) |
---|
803 | (setf (arm-instruction-template-ordinal template) i |
---|
804 | (gethash name *arm-instruction-ordinals*) i))) |
---|
805 | |
---|
806 | |
---|
807 | |
---|
808 | |
---|
809 | |
---|
810 | (defun lookup-arm-instruction (name) |
---|
811 | ;; return (values instruction template & condition value), or (NIL NIL) |
---|
812 | (let* ((cond-value #xe) ;always |
---|
813 | (string (string name)) |
---|
814 | (len (length string)) |
---|
815 | (ordinal (gethash string *arm-instruction-ordinals*)) |
---|
816 | (template (if ordinal (aref *arm-instruction-table* ordinal)))) |
---|
817 | (if template |
---|
818 | (if (logtest (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) |
---|
819 | (let* ((cond (ldb (byte 4 28) (arm-instruction-template-val template)))) |
---|
820 | (values template cond cond)) |
---|
821 | (values template cond-value nil)) |
---|
822 | (if (> len 2) |
---|
823 | (let* ((cond-name (make-string 2))) |
---|
824 | (declare (dynamic-extent cond-name)) |
---|
825 | (setf (schar cond-name 0) |
---|
826 | (schar string (- len 2)) |
---|
827 | (schar cond-name 1) |
---|
828 | (schar string (- len 1))) |
---|
829 | (if (setq cond-value (lookup-arm-condition-name cond-name)) |
---|
830 | (let* ((prefix-len (- len 2)) |
---|
831 | (prefix (make-string prefix-len))) |
---|
832 | (declare (dynamic-extent prefix) |
---|
833 | (fixnum prefix-len)) |
---|
834 | (dotimes (i prefix-len) |
---|
835 | (setf (schar prefix i) (schar string i))) |
---|
836 | (if (setq template |
---|
837 | (progn |
---|
838 | (setq ordinal (gethash prefix *arm-instruction-ordinals*)) |
---|
839 | (when ordinal |
---|
840 | (svref *arm-instruction-table* ordinal)))) |
---|
841 | (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) |
---|
842 | (values nil nil nil) |
---|
843 | (values template cond-value t)) |
---|
844 | (values nil nil nil))) |
---|
845 | (values nil nil nil))) |
---|
846 | (values nil nil nil))))) |
---|
847 | |
---|
848 | (defun keywordize (name) |
---|
849 | (if (typep name 'keyword) |
---|
850 | name |
---|
851 | (intern (string-upcase (string name)) "KEYWORD"))) |
---|
852 | |
---|
853 | (defun arm-rotate-left (u32 nbits) |
---|
854 | (assert (and (evenp nbits) |
---|
855 | (>= nbits 0) |
---|
856 | (< nbits 32))) |
---|
857 | (let* ((r (- 32 nbits)) |
---|
858 | (mask (1- (ash 1 nbits)))) |
---|
859 | (logand #xffffffff |
---|
860 | (logior (ash u32 nbits) |
---|
861 | (logand mask |
---|
862 | (ash u32 (- r))))))) |
---|
863 | |
---|
864 | ;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated |
---|
865 | ;;; by an even number of bits if u32 can be encoded that way, nil |
---|
866 | ;;; otherwise. |
---|
867 | (defun encode-arm-immediate (u32) |
---|
868 | (do* ((u32 (logand #xffffffff u32)) |
---|
869 | (rot 0 (+ rot 2))) |
---|
870 | ((= rot 32) (values nil nil)) |
---|
871 | (let* ((a (arm-rotate-left u32 rot))) |
---|
872 | (when (<= a #xff) |
---|
873 | (return (logior (ash rot 7) a)))))) |
---|
874 | |
---|
875 | |
---|
876 | (eval-when (:execute :load-toplevel) |
---|
877 | (defstruct (instruction-element (:include ccl::dll-node)) |
---|
878 | address |
---|
879 | (size 0)) |
---|
880 | |
---|
881 | ;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value) |
---|
882 | ;;; pairs, where the byte-spec is encoded as a fixnum. If the BYTE-SIZE |
---|
883 | ;;; of the byte-spec is non-zero, the value is to be inserted in the |
---|
884 | ;;; instruction by DPB; if the BYTE-SIZE is zero, the BYTE-POSITION of |
---|
885 | |
---|
886 | ;;; the byte-spec is used to select a function which affects arbitrary |
---|
887 | ;;; bitfields in the instruction. (E.g., a negative constant in an ADD |
---|
888 | ;;; instruction might turn the instruction into a SUB.) |
---|
889 | ;;; The relationship between logical operands and field-values isn't |
---|
890 | ;;; necessarily 1:1. |
---|
891 | ;;; For vinsn expansion, the field values with constant values can |
---|
892 | ;;; be applied at vinsn-definition time. |
---|
893 | |
---|
894 | (defstruct (lap-instruction (:include instruction-element (size 4)) |
---|
895 | (:constructor %make-lap-instruction (source))) |
---|
896 | source ; for LAP, maybe vinsn-template |
---|
897 | (opcode 0) |
---|
898 | vinsn-info ;tbd |
---|
899 | ) |
---|
900 | |
---|
901 | |
---|
902 | (defstruct (lap-label (:include instruction-element) |
---|
903 | (:constructor %%make-lap-label (name))) |
---|
904 | name |
---|
905 | refs)) |
---|
906 | |
---|
907 | (ccl::def-standard-initial-binding *lap-label-freelist* (ccl::make-dll-node-freelist)) |
---|
908 | (ccl::def-standard-initial-binding *lap-instruction-freelist* (ccl::make-dll-node-freelist)) |
---|
909 | |
---|
910 | |
---|
911 | (eval-when (:compile-toplevel :execute) |
---|
912 | (declaim (inline set-field-value))) |
---|
913 | |
---|
914 | (defun set-field-value (instruction bytespec value) |
---|
915 | (setf (lap-instruction-opcode instruction) |
---|
916 | (dpb value bytespec (lap-instruction-opcode instruction)))) |
---|
917 | |
---|
918 | |
---|
919 | (defun need-arm-gpr (form) |
---|
920 | (or (get-arm-gpr form) |
---|
921 | (error "Expected an ARM general-purpose register, got ~s" form))) |
---|
922 | |
---|
923 | (defun need-arm-sfpr (form) |
---|
924 | (or (get-arm-sfpr form) |
---|
925 | (error "Expected an ARM single FP register, got ~s" form))) |
---|
926 | |
---|
927 | (defun need-arm-dfpr (form) |
---|
928 | (or (get-arm-dfpr form) |
---|
929 | (error "Expected an ARM double FP register, got ~s" form))) |
---|
930 | |
---|
931 | (defun encode-arm-shift-type (op) |
---|
932 | (case op |
---|
933 | (:lsl 0) |
---|
934 | (:lsr 1) |
---|
935 | (:asr 2) |
---|
936 | (:ror 3))) |
---|
937 | |
---|
938 | |
---|
939 | (defconstant opcode-and 0) |
---|
940 | (defconstant opcode-eor 1) |
---|
941 | (defconstant opcode-sub 2) |
---|
942 | (defconstant opcode-rsb 3) |
---|
943 | (defconstant opcode-add 4) |
---|
944 | (defconstant opcode-adc 5) |
---|
945 | (defconstant opcode-sbc 6) |
---|
946 | (defconstant opcode-rsc 7) |
---|
947 | (defconstant opcode-tst 8) |
---|
948 | (defconstant opcode-teq 9) |
---|
949 | (defconstant opcode-cmp 10) |
---|
950 | (defconstant opcode-cmn 11) |
---|
951 | (defconstant opcode-orr 12) |
---|
952 | (defconstant opcode-mov 13) |
---|
953 | (defconstant opcode-bic 14) |
---|
954 | (defconstant opcode-mvn 15) |
---|
955 | |
---|
956 | (defparameter *equivalent-complemented-opcodes* |
---|
957 | (vector opcode-bic ;and->bic |
---|
958 | nil ;eor-> |
---|
959 | nil ;sub-> |
---|
960 | nil ;rsb-> |
---|
961 | nil ;add-> |
---|
962 | opcode-sbc ;adc->sbc |
---|
963 | opcode-adc ;sbc->adc |
---|
964 | nil ;rsc-> |
---|
965 | nil ;tst-> |
---|
966 | nil ;teq-> |
---|
967 | nil ;cmp-> |
---|
968 | nil ;cmn-> |
---|
969 | nil ;orr-> |
---|
970 | opcode-mvn ;mov->mvn |
---|
971 | opcode-and ;bic->and |
---|
972 | opcode-mov ;mvn->mov |
---|
973 | )) |
---|
974 | |
---|
975 | (defparameter *equivalent-negated-opcodes* |
---|
976 | (vector nil ;and-> |
---|
977 | nil ;eor-> |
---|
978 | opcode-add ;sub->add |
---|
979 | nil ;rsb-> |
---|
980 | opcode-sub ;add->sub |
---|
981 | nil ;adc-> |
---|
982 | nil ;sbc-> |
---|
983 | nil ;rsc-> |
---|
984 | nil ;tst-> |
---|
985 | nil ;teq-> |
---|
986 | opcode-cmn ;cmp->cmn |
---|
987 | opcode-cmp ;cmn->cmp |
---|
988 | nil ;orr-> |
---|
989 | nil ;mov-> |
---|
990 | nil ;bic-> |
---|
991 | nil ;mvn-> |
---|
992 | )) |
---|
993 | |
---|
994 | |
---|
995 | |
---|
996 | (defun parse-rd-operand (form instruction) |
---|
997 | (set-field-value instruction (byte 4 12) (need-arm-gpr form))) |
---|
998 | |
---|
999 | (defun parse-rn-operand (form instruction) |
---|
1000 | (set-field-value instruction (byte 4 16) (need-arm-gpr form))) |
---|
1001 | |
---|
1002 | (defun parse-shifter-operand (form instruction) |
---|
1003 | (if (atom form) |
---|
1004 | ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0. |
---|
1005 | (set-field-value instruction (byte 12 0) (need-arm-gpr form)) |
---|
1006 | (if (ccl::quoted-form-p form) |
---|
1007 | (insert-shifter-constant (need-constant form) instruction) |
---|
1008 | (let* ((op (keywordize (car form)))) |
---|
1009 | (ecase op |
---|
1010 | (:$ (destructuring-bind (value) (cdr form) |
---|
1011 | (insert-shifter-constant (eval value) instruction))) |
---|
1012 | (:rrx (destructuring-bind (reg) (cdr form) |
---|
1013 | (set-field-value instruction (byte 12 0) |
---|
1014 | (logior (need-arm-gpr reg) |
---|
1015 | (ash (encode-arm-shift-type :ror) 5))))) |
---|
1016 | ((:lsl :lsr :asr :ror) |
---|
1017 | (destructuring-bind (reg count) (cdr form) |
---|
1018 | (if (atom count) |
---|
1019 | (set-field-value instruction (byte 12 0) |
---|
1020 | (logior (need-arm-gpr reg) |
---|
1021 | (ash 1 4) |
---|
1022 | (ash (encode-arm-shift-type op) 5) |
---|
1023 | (ash (need-arm-gpr count) 8))) |
---|
1024 | (ecase (keywordize (car count)) |
---|
1025 | (:$ (destructuring-bind (countval) (cdr count) |
---|
1026 | (set-field-value instruction (byte 12 0) |
---|
1027 | (logior (need-arm-gpr reg) |
---|
1028 | (ash (encode-arm-shift-type op) 5) |
---|
1029 | (ash (logand 31 (eval countval)) 7)))))))))))))) |
---|
1030 | |
---|
1031 | (defun insert-shifter-constant (value instruction) |
---|
1032 | (let* ((opcode (lap-instruction-opcode instruction)) |
---|
1033 | (constant (encode-arm-immediate value))) |
---|
1034 | (setf (lap-instruction-opcode instruction) |
---|
1035 | (if constant |
---|
1036 | (logior constant (logior (ash 1 25) opcode)) |
---|
1037 | ;; If value couldn't be encoded but its complement can be |
---|
1038 | ;; and there's an instruction that can operate on complemented |
---|
1039 | ;; values, change the instruction and encode the complemented |
---|
1040 | ;; value. If that doesn't work, try negating the value and |
---|
1041 | ;; seeing if there's an equivalent instruction that could use |
---|
1042 | ;; that. If none of this works, complain that the value can't |
---|
1043 | ;; be encoded. |
---|
1044 | (let* ((op (ldb (byte 4 21) opcode)) |
---|
1045 | (newop nil)) |
---|
1046 | (if (or (and (setq constant (encode-arm-immediate (lognot value))) |
---|
1047 | (setq newop (svref *equivalent-complemented-opcodes* op))) |
---|
1048 | (and (setq constant (encode-arm-immediate (- value))) |
---|
1049 | (setq newop (svref *equivalent-negated-opcodes* op)))) |
---|
1050 | (logior constant |
---|
1051 | (logior (ash 1 25) (dpb newop (byte 4 21) opcode))) |
---|
1052 | (error "Can't encode ARM constant ~s." value))))))) |
---|
1053 | |
---|
1054 | (defun set-opcode-value-from-addressing-mode (opcode mode constant-index) |
---|
1055 | ;; Look at mode and set P/W/U bits. If CONSTANT-INDEX is |
---|
1056 | ;; true, the U bit depends on the sign of the constant. |
---|
1057 | (ecase mode |
---|
1058 | ((:@ :+@ :+@! :@!) |
---|
1059 | ;; Preindexed, no writeback unless :[+]@! , add register operands. |
---|
1060 | (unless constant-index |
---|
1061 | (setq opcode (logior opcode (ash 1 23)))) |
---|
1062 | (when (or (eq mode :+@!) |
---|
1063 | (eq mode :@!)) |
---|
1064 | (setq opcode (logior opcode (ash 1 21)))) |
---|
1065 | (setq opcode (logior opcode (ash 1 24)))) |
---|
1066 | ((:-@ :-@!) |
---|
1067 | ;; Preindexed. Leave the U bit clear, maybe set W if writeback. |
---|
1068 | (when (eq mode :-@!) |
---|
1069 | (setq opcode (logior opcode (ash 1 21)))) |
---|
1070 | (setq opcode (logior opcode (ash 1 24)))) |
---|
1071 | ((:@+ :@-) |
---|
1072 | ;; Postindex; writeback is implicit (and setting P and W would |
---|
1073 | ;; change the instruction.) |
---|
1074 | (unless (or (eq mode :@-) constant-index) |
---|
1075 | (setq opcode (logior opcode (ash 1 23)))))) |
---|
1076 | opcode) |
---|
1077 | |
---|
1078 | |
---|
1079 | (defun set-addressing-mode (instruction mode constant-index) |
---|
1080 | (setf (lap-instruction-opcode instruction) |
---|
1081 | (set-opcode-value-from-addressing-mode |
---|
1082 | (lap-instruction-opcode instruction) mode constant-index))) |
---|
1083 | |
---|
1084 | ;;; "general" address operand, as used in LDR/LDRB/STR/STRB |
---|
1085 | (defun parse-m12-operand (form instruction) |
---|
1086 | (if (atom form) |
---|
1087 | (error "Invalid memory operand ~s" form) |
---|
1088 | (let* ((mode (keywordize (car form)))) |
---|
1089 | (if (eq mode :=) |
---|
1090 | (destructuring-bind (label) (cdr form) |
---|
1091 | (when (arm::arm-subprimitive-address label) |
---|
1092 | (error "Invalid label in ~s." form)) |
---|
1093 | (set-field-value instruction (byte 4 16) arm::pc) |
---|
1094 | (set-field-value instruction (byte 1 24) 1) ;P bit |
---|
1095 | ;; Insert function will have to set U bit appropriately. |
---|
1096 | (lap-note-label-reference label instruction :mem12)) |
---|
1097 | (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form) |
---|
1098 | (unless (or index-p (eq mode :@)) |
---|
1099 | (error "missing index in memory operand ~s." form)) |
---|
1100 | (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) |
---|
1101 | (let* ((quoted (ccl::quoted-form-p index)) |
---|
1102 | (index-op (if quoted :quote (and (consp index) (keywordize (car index))))) |
---|
1103 | (constant-index (or quoted (eq index-op :$)))) |
---|
1104 | (cond (constant-index |
---|
1105 | (destructuring-bind (val) (cdr index) |
---|
1106 | (let* ((constval (if quoted |
---|
1107 | (need-constant index) |
---|
1108 | (eval val)))) |
---|
1109 | (if (< constval 0) |
---|
1110 | (setq constval (- constval)) |
---|
1111 | ;; das u bit |
---|
1112 | (set-field-value instruction (byte 1 23) 1)) |
---|
1113 | (unless (typep constval '(unsigned-byte 12)) |
---|
1114 | (warn "constant offset too large : ~s" constval)) |
---|
1115 | (set-field-value instruction (byte 12 0) constval)))) |
---|
1116 | (t |
---|
1117 | (set-field-value instruction (byte 1 25) 1) |
---|
1118 | (if (atom index) |
---|
1119 | (set-field-value instruction (byte 12 0) (need-arm-gpr index)) |
---|
1120 | ;; Shifts here are always by a constant (not another reg) |
---|
1121 | (if (eq index-op :rrx) |
---|
1122 | (destructuring-bind (rm) (cdr index) |
---|
1123 | (set-field-value instruction (byte 12 0) |
---|
1124 | (logior (need-arm-gpr rm) |
---|
1125 | (ash (encode-arm-shift-type :ror) 5)))) |
---|
1126 | |
---|
1127 | (destructuring-bind (rm shift-expr) (cdr index) |
---|
1128 | (unless (and (consp shift-expr) |
---|
1129 | (eq (keywordize (car shift-expr)) :$)) |
---|
1130 | (error "Shift count must be immediate : ~s" shift-expr)) |
---|
1131 | (destructuring-bind (count-expr) (cdr shift-expr) |
---|
1132 | (set-field-value instruction (byte 12 0) |
---|
1133 | (logior (need-arm-gpr rm) |
---|
1134 | (ash (encode-arm-shift-type |
---|
1135 | index-op) 5) |
---|
1136 | (ash (logand 31 (eval count-expr)) |
---|
1137 | 7))))))))) |
---|
1138 | (set-addressing-mode instruction mode constant-index))))))) |
---|
1139 | |
---|
1140 | (defun parse-reglist-operand (form instruction) |
---|
1141 | (let* ((mask 0)) |
---|
1142 | (dolist (r form) |
---|
1143 | (let* ((regno (need-arm-gpr r))) |
---|
1144 | (when (logbitp regno mask) |
---|
1145 | (warn "Duplicate register ~s in ~s." r form)) |
---|
1146 | (setq mask (logior mask (ash 1 regno))))) |
---|
1147 | (if (zerop mask) |
---|
1148 | (error "Empty register list ~s." form) |
---|
1149 | (set-field-value instruction (byte 16 0) mask)))) |
---|
1150 | |
---|
1151 | (defun parse-rnw-operand (form instruction) |
---|
1152 | (if (atom form) |
---|
1153 | (set-field-value instruction (byte 4 16) (need-arm-gpr form)) |
---|
1154 | (if (eq (keywordize (car form)) :!) |
---|
1155 | (destructuring-bind (rn) (cdr form) |
---|
1156 | (set-field-value instruction (byte 1 21) 1) |
---|
1157 | (set-field-value instruction (byte 4 16) (need-arm-gpr rn))) |
---|
1158 | (error "Unrecognized writeback indicator in ~s." form)))) |
---|
1159 | |
---|
1160 | (defun parse-uuoA-operand (form instruction) |
---|
1161 | (set-field-value instruction (byte 4 8) (need-arm-gpr form))) |
---|
1162 | |
---|
1163 | (defun parse-uuo-unary-operand (form instruction) |
---|
1164 | (set-field-value instruction (byte 8 12) (need-constant form))) |
---|
1165 | |
---|
1166 | (defun parse-uuoB-operand (form instruction) |
---|
1167 | (set-field-value instruction (byte 4 12) (need-arm-gpr form))) |
---|
1168 | |
---|
1169 | (defun parse-uuoC-operand (form instruction) |
---|
1170 | (set-field-value instruction (byte 4 16) (need-arm-gpr form))) |
---|
1171 | |
---|
1172 | (defun parse-fpux-operand (form instruction) |
---|
1173 | (let* ((regno (if (typep form '(unsigned-byte 4)) |
---|
1174 | form |
---|
1175 | (ecase (keywordize form) |
---|
1176 | (:fpsid 0) |
---|
1177 | (:fpscr 1) |
---|
1178 | (:fpexc 8))))) |
---|
1179 | (set-field-value instruction (byte 4 16) regno))) |
---|
1180 | |
---|
1181 | (defun parse-imm16-operand (form instruction) |
---|
1182 | (unless (and (consp form) |
---|
1183 | (eq (keywordize (car form)) :$) |
---|
1184 | (consp (cdr form)) |
---|
1185 | (null (cddr form))) |
---|
1186 | (error "Bad 16-bit immediate operand: ~s" form)) |
---|
1187 | (let* ((val (eval (cadr form)))) |
---|
1188 | (set-field-value instruction (byte 12 0) (ldb (byte 12 0) val)) |
---|
1189 | (set-field-value instruction (byte 4 16) (ldb (byte 4 12) val)))) |
---|
1190 | |
---|
1191 | |
---|
1192 | (defun parse-rm-operand (form instruction) |
---|
1193 | (set-field-value instruction (byte 4 0) (need-arm-gpr form))) |
---|
1194 | |
---|
1195 | (defun parse-b-operand (form instruction) |
---|
1196 | (let* ((address (arm-subprimitive-address form))) |
---|
1197 | (if address |
---|
1198 | (let* ((lab (or (find-lap-label form) |
---|
1199 | (make-lap-label form)))) |
---|
1200 | (pushnew lab *called-subprim-jmp-labels*) |
---|
1201 | (push (cons instruction :b) (lap-label-refs lab))) |
---|
1202 | (lap-note-label-reference form instruction :b)))) |
---|
1203 | |
---|
1204 | (defun parse-subprim-operand (form instruction) |
---|
1205 | (let* ((address (or (arm-subprimitive-address form) |
---|
1206 | (when (arm-subprimitive-name form) form)))) |
---|
1207 | (unless address |
---|
1208 | (error "Unknown ARM subprimitive : ~s" form)) |
---|
1209 | (set-field-value instruction (byte 12 0) (encode-arm-immediate address)))) |
---|
1210 | |
---|
1211 | (defun parse-m8-operand (form instruction) |
---|
1212 | (if (atom form) |
---|
1213 | (error "Invalid memory operand ~s." form) |
---|
1214 | (let* ((mode (keywordize (car form))) |
---|
1215 | (constant-index nil)) |
---|
1216 | (destructuring-bind (rn index) (cdr form) |
---|
1217 | (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) |
---|
1218 | (cond ((atom index) |
---|
1219 | (set-field-value instruction (byte 4 0) (need-arm-gpr index))) |
---|
1220 | (t (unless (eq (keywordize (car index)) :$) |
---|
1221 | (error "Invalid index: ~s." index)) |
---|
1222 | (destructuring-bind (val) (cdr index) |
---|
1223 | (let* ((value (eval val))) |
---|
1224 | (setq constant-index t) |
---|
1225 | (if (< value 0) |
---|
1226 | (setq value (- value)) |
---|
1227 | (set-field-value instruction (byte 1 23) 1)) |
---|
1228 | (set-field-value instruction (byte 1 22) 1) |
---|
1229 | (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)) |
---|
1230 | (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))))))) |
---|
1231 | (set-addressing-mode instruction mode constant-index)))) |
---|
1232 | |
---|
1233 | (defun parse-dd-operand (form instruction) |
---|
1234 | (set-field-value instruction (byte 4 12) (need-arm-dfpr form))) |
---|
1235 | |
---|
1236 | (defun parse-dm-operand (form instruction) |
---|
1237 | (set-field-value instruction (byte 4 0) (need-arm-dfpr form))) |
---|
1238 | |
---|
1239 | (defun parse-sd-operand (form instruction) |
---|
1240 | (let* ((val (need-arm-sfpr form))) |
---|
1241 | (set-field-value instruction (byte 4 12) (ash val -1)) |
---|
1242 | (set-field-value instruction (byte 1 22) (logand val 1)))) |
---|
1243 | |
---|
1244 | (defun parse-sm-operand (form instruction) |
---|
1245 | (let* ((val (need-arm-sfpr form))) |
---|
1246 | (set-field-value instruction (byte 4 0) (ash val -1)) |
---|
1247 | (set-field-value instruction (byte 1 5) (logand val 1)))) |
---|
1248 | |
---|
1249 | (defun parse-dn-operand (form instruction) |
---|
1250 | (set-field-value instruction (byte 4 16) (need-arm-dfpr form))) |
---|
1251 | |
---|
1252 | (defun parse-sn-operand (form instruction) |
---|
1253 | (let* ((val (need-arm-sfpr form))) |
---|
1254 | (set-field-value instruction (byte 4 16) (ash val -1)) |
---|
1255 | (set-field-value instruction (byte 1 7) (logand val 1)))) |
---|
1256 | |
---|
1257 | (defun parse-rde-operand (form instruction) |
---|
1258 | (let* ((val (need-arm-gpr form))) |
---|
1259 | (when (oddp val) |
---|
1260 | (error "Register must be even-numbered: ~s." form)) |
---|
1261 | (set-field-value instruction (byte 4 12) val))) |
---|
1262 | |
---|
1263 | (defun parse-rs-operand (form instruction) |
---|
1264 | (set-field-value instruction (byte 4 8) (need-arm-gpr form))) |
---|
1265 | |
---|
1266 | (defun parse-fpaddr-operand (form instruction) |
---|
1267 | (if (atom form) |
---|
1268 | (error "Invalid FP address: ~s" form) |
---|
1269 | (destructuring-bind (op rn offset) form |
---|
1270 | (unless (eq (keywordize op) :@) |
---|
1271 | (error "Invalid FP addressing mode ~s in ~s." op form)) |
---|
1272 | (set-field-value instruction (byte 4 16) (need-arm-gpr rn)) |
---|
1273 | (unless (and (consp offset) (eq (keywordize (car offset)) :$)) |
---|
1274 | (error "Invalid FP address offset ~s in ~s." offset form)) |
---|
1275 | (destructuring-bind (offset-form) (cdr offset) |
---|
1276 | (let* ((offset-val (eval offset-form))) |
---|
1277 | (when (logtest offset-val 3) |
---|
1278 | (error "FP address offset ~s must be a multiple of 4 in ~s." offset form)) |
---|
1279 | (if (< offset-val 0) |
---|
1280 | (setq offset-val (- offset-val)) |
---|
1281 | (set-field-value instruction (byte 1 23) 1)) |
---|
1282 | (set-field-value instruction (byte 8 0) (ash offset-val -2))))))) |
---|
1283 | |
---|
1284 | (defun parse-@rn-operand (form instruction) |
---|
1285 | (when (or (atom form) |
---|
1286 | (not (eq (keywordize (car form)) :@))) |
---|
1287 | (error "Invalid register indirect operand: ~s" form)) |
---|
1288 | (destructuring-bind (rn) (cdr form) |
---|
1289 | (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))) |
---|
1290 | |
---|
1291 | (defparameter *arm-operand-parsers* |
---|
1292 | #(parse-rd-operand |
---|
1293 | parse-rn-operand |
---|
1294 | parse-shifter-operand |
---|
1295 | parse-m12-operand |
---|
1296 | parse-reglist-operand |
---|
1297 | parse-rnw-operand |
---|
1298 | parse-uuoa-operand |
---|
1299 | parse-uuo-unary-operand |
---|
1300 | parse-uuob-operand |
---|
1301 | parse-rm-operand |
---|
1302 | parse-b-operand |
---|
1303 | parse-subprim-operand |
---|
1304 | parse-m8-operand |
---|
1305 | parse-dd-operand |
---|
1306 | parse-dm-operand |
---|
1307 | parse-sd-operand |
---|
1308 | parse-sm-operand |
---|
1309 | parse-dn-operand |
---|
1310 | parse-sn-operand |
---|
1311 | parse-rde-operand |
---|
1312 | parse-rs-operand |
---|
1313 | parse-fpaddr-operand |
---|
1314 | parse-@rn-operand |
---|
1315 | parse-uuoc-operand |
---|
1316 | parse-fpux-operand |
---|
1317 | parse-imm16-operand |
---|
1318 | )) |
---|
1319 | |
---|
1320 | |
---|
1321 | |
---|
1322 | (defun make-lap-instruction (form) |
---|
1323 | (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*))) |
---|
1324 | (if (typep insn 'lap-instruction) |
---|
1325 | (progn |
---|
1326 | (setf (lap-instruction-source insn) form |
---|
1327 | (lap-instruction-address insn) nil |
---|
1328 | (lap-instruction-vinsn-info insn) nil |
---|
1329 | (lap-instruction-opcode insn) nil) |
---|
1330 | insn) |
---|
1331 | (%make-lap-instruction form)))) |
---|
1332 | |
---|
1333 | (defun emit-lap-instruction-element (insn seg) |
---|
1334 | (ccl::append-dll-node insn seg) |
---|
1335 | (let* ((addr (let* ((prev (ccl::dll-node-pred insn))) |
---|
1336 | (if (eq prev seg) |
---|
1337 | 0 |
---|
1338 | (the fixnum (+ (the fixnum (instruction-element-address prev)) |
---|
1339 | (the fixnum (instruction-element-size prev)))))))) |
---|
1340 | (setf (instruction-element-address insn) addr)) |
---|
1341 | insn) |
---|
1342 | |
---|
1343 | ;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to |
---|
1344 | ;;; generate an instruction. |
---|
1345 | (defun assemble-instruction (seg form) |
---|
1346 | (let* ((insn (make-lap-instruction form))) |
---|
1347 | (destructuring-bind (name . opvals) form |
---|
1348 | (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) |
---|
1349 | (unless template |
---|
1350 | (error "Unknown ARM instruction - ~s" form)) |
---|
1351 | (let* ((cond-indicator (and (consp (car opvals)) |
---|
1352 | (keywordize (caar opvals))))) |
---|
1353 | (when (or (eq cond-indicator :?) |
---|
1354 | (eq cond-indicator :~)) |
---|
1355 | (let* ((condform (pop opvals))) |
---|
1356 | (destructuring-bind (q cond-name) condform |
---|
1357 | (declare (ignore q)) |
---|
1358 | (let* ((c (need-arm-condition-name cond-name))) |
---|
1359 | (when (eq cond-indicator :~) |
---|
1360 | (if (< c 14) |
---|
1361 | (setq c (logxor c 1)) |
---|
1362 | (error "Invalid explicit condition ~s." condform))) |
---|
1363 | (if (and explicit-cond (not (eql c cond))) |
---|
1364 | (error "Can't use explicit condition and :? : ~s" condform) |
---|
1365 | (setq cond c))))))) |
---|
1366 | (let* ((optypes (arm-instruction-template-operand-types template)) |
---|
1367 | (n (length optypes))) |
---|
1368 | (unless (= n (length opvals)) |
---|
1369 | (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) |
---|
1370 | (setf (lap-instruction-opcode insn) |
---|
1371 | (arm-instruction-template-val template)) |
---|
1372 | (dotimes (i n) |
---|
1373 | (let* ((optype (pop optypes)) |
---|
1374 | (val (pop opvals))) |
---|
1375 | (funcall (svref *arm-operand-parsers* optype) val insn))) |
---|
1376 | (when cond |
---|
1377 | (setf (lap-instruction-opcode insn) |
---|
1378 | (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) |
---|
1379 | (emit-lap-instruction-element insn seg)))))) |
---|
1380 | |
---|
1381 | ;;; A label can only be emitted once. Once it's been emitted, its pred/succ |
---|
1382 | ;;; slots will be non-nil. |
---|
1383 | |
---|
1384 | (defun lap-label-emitted-p (lab) |
---|
1385 | (not (null (lap-label-pred lab)))) |
---|
1386 | |
---|
1387 | (defun %make-lap-label (name) |
---|
1388 | (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*))) |
---|
1389 | (if lab |
---|
1390 | (progn |
---|
1391 | (setf (lap-label-address lab) nil |
---|
1392 | (lap-label-refs lab) nil |
---|
1393 | (lap-label-name lab) name) |
---|
1394 | lab) |
---|
1395 | (%%make-lap-label name)))) |
---|
1396 | |
---|
1397 | (defun make-lap-label (name) |
---|
1398 | (let* ((lab (%make-lap-label name))) |
---|
1399 | (if (typep *lap-labels* 'hash-table) |
---|
1400 | (setf (gethash name *lap-labels*) lab) |
---|
1401 | (progn |
---|
1402 | (push lab *lap-labels*) |
---|
1403 | (if (> (length *lap-labels*) 255) |
---|
1404 | (let* ((hash (make-hash-table :size 512 :test #'eq))) |
---|
1405 | (dolist (l *lap-labels* (setq *lap-labels* hash)) |
---|
1406 | (setf (gethash (lap-label-name l) hash) l)))))) |
---|
1407 | lab)) |
---|
1408 | |
---|
1409 | (defun find-lap-label (name) |
---|
1410 | (if (typep *lap-labels* 'hash-table) |
---|
1411 | (gethash name *lap-labels*) |
---|
1412 | (car (member name *lap-labels* :test #'eq :key #'lap-label-name)))) |
---|
1413 | |
---|
1414 | (defun lap-note-label-reference (labx insn type) |
---|
1415 | (let* ((lab (or (find-lap-label labx) |
---|
1416 | (make-lap-label labx)))) |
---|
1417 | (push (cons insn type) (lap-label-refs lab)) |
---|
1418 | lab)) |
---|
1419 | |
---|
1420 | (defun emit-lap-label (seg name) |
---|
1421 | (let* ((lab (find-lap-label name))) |
---|
1422 | (if lab |
---|
1423 | (when (lap-label-emitted-p lab) |
---|
1424 | (error "Label ~s: multiply defined." name)) |
---|
1425 | (setq lab (make-lap-label name))) |
---|
1426 | (emit-lap-instruction-element lab seg))) |
---|
1427 | |
---|
1428 | (defmacro do-lap-labels ((lab &optional result) &body body) |
---|
1429 | (let* ((thunk-name (gensym)) |
---|
1430 | (k (gensym)) |
---|
1431 | (xlab (gensym))) |
---|
1432 | `(flet ((,thunk-name (,lab) ,@body)) |
---|
1433 | (if (listp *lap-labels*) |
---|
1434 | (dolist (,xlab *lap-labels*) |
---|
1435 | (,thunk-name ,xlab)) |
---|
1436 | (maphash #'(lambda (,k ,xlab) |
---|
1437 | (declare (ignore ,k)) |
---|
1438 | (,thunk-name ,xlab)) |
---|
1439 | *lap-labels*)) |
---|
1440 | ,result))) |
---|
1441 | |
---|
1442 | (defun section-size (seg) |
---|
1443 | (let* ((last (ccl::dll-node-pred seg))) |
---|
1444 | (if (eq last seg) ;empty |
---|
1445 | 0 |
---|
1446 | (the fixnum |
---|
1447 | (+ (the fixnum (instruction-element-address last)) |
---|
1448 | (the fixnum (instruction-element-size last))))))) |
---|
1449 | |
---|
1450 | (defun set-element-addresses (start seg) |
---|
1451 | (ccl::do-dll-nodes (element seg start) |
---|
1452 | (setf (instruction-element-address element) start) |
---|
1453 | (incf start (instruction-element-size element)))) |
---|
1454 | |
---|
1455 | |
---|
1456 | ;;; It's better to do this naively than to not do it at all |
---|
1457 | (defun drain-constant-pool (primary constant-pool) |
---|
1458 | (let* ((n-constant-bytes (section-size constant-pool))) |
---|
1459 | (declare (fixnum n-constant-bytes)) |
---|
1460 | (when (> n-constant-bytes 0) |
---|
1461 | (when (> (+ n-constant-bytes (section-size primary)) 4000) ; some slack here |
---|
1462 | ;; Jump around an embedded constant pool. We might be following |
---|
1463 | ;; some flavor of a jump with an unreachable one, or sticking |
---|
1464 | ;; some stuff in the middle of a jump table, or something. |
---|
1465 | ;; LAP functions that have jump tables aren't likely to be |
---|
1466 | ;; big enough to need to worry about this; if the compiler |
---|
1467 | ;; generates jump tables or other span-dependent things, it'll |
---|
1468 | ;; have to be careful about how it does so. |
---|
1469 | (let* ((target-name (gensym)) |
---|
1470 | (origin (make-lap-instruction nil)) |
---|
1471 | (offset (make-lap-instruction nil)) |
---|
1472 | (pool-count (make-lap-instruction nil)) |
---|
1473 | (offset-label (make-lap-label (gensym)))) |
---|
1474 | (assemble-instruction primary `(b ,target-name)) |
---|
1475 | (setf (lap-instruction-opcode origin) 0) |
---|
1476 | (emit-lap-instruction-element origin primary) |
---|
1477 | (setq *last-constant-pool-origin* origin) |
---|
1478 | (setf (lap-instruction-opcode offset) 0) |
---|
1479 | (emit-lap-instruction-element offset primary) |
---|
1480 | (setf (lap-instruction-opcode pool-count) |
---|
1481 | (ash n-constant-bytes (- arm::word-shift))) |
---|
1482 | (emit-lap-instruction-element pool-count primary) |
---|
1483 | (ccl::do-dll-nodes (datum constant-pool) |
---|
1484 | (ccl::remove-dll-node datum) |
---|
1485 | (emit-lap-instruction-element datum primary)) |
---|
1486 | (push (cons offset :offset) (lap-label-refs offset-label)) |
---|
1487 | (emit-lap-label primary (lap-label-name offset-label)) |
---|
1488 | (emit-lap-label primary target-name)))))) |
---|
1489 | |
---|
1490 | |
---|
1491 | |
---|
1492 | (defun arm-finalize (primary constant-pool) |
---|
1493 | (do-lap-labels (lab) |
---|
1494 | (loop |
---|
1495 | (when (dolist (ref (lap-label-refs lab) t) |
---|
1496 | (when (and (eq :b (cdr ref)) |
---|
1497 | (eq lab (lap-instruction-succ (car ref)))) |
---|
1498 | (ccl::remove-dll-node (car ref)) |
---|
1499 | (setf (lap-label-refs lab) |
---|
1500 | (delete ref (lap-label-refs lab))) |
---|
1501 | (return))) |
---|
1502 | (return)))) |
---|
1503 | (dolist (lab *called-subprim-jmp-labels*) |
---|
1504 | (unless (lap-label-emitted-p lab) |
---|
1505 | (emit-lap-instruction-element lab primary) |
---|
1506 | (assemble-instruction primary `(ba ,(lap-label-name lab))))) |
---|
1507 | (let* ((constants-size (section-size constant-pool))) |
---|
1508 | (unless (eql constants-size 0) |
---|
1509 | (let* ((c0 (make-lap-instruction nil))) |
---|
1510 | (setf (lap-instruction-opcode c0) (ash constants-size -2)) |
---|
1511 | (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool))))) |
---|
1512 | (let* ((w0 (make-lap-instruction nil)) |
---|
1513 | (w1 (make-lap-instruction nil))) |
---|
1514 | (setf (lap-instruction-opcode w0) 0) |
---|
1515 | (ccl::append-dll-node w0 primary) |
---|
1516 | (ccl::append-dll-node w1 primary ) |
---|
1517 | (let* ((n (set-element-addresses 0 primary))) |
---|
1518 | (setf (lap-instruction-opcode w1) (ash n (- arm::word-shift))) |
---|
1519 | (set-element-addresses n constant-pool))) |
---|
1520 | ;; Now fix up label references. Recall that the PC value at some |
---|
1521 | ;; point in program execution is 8 bytes beyond that point. |
---|
1522 | (do-lap-labels (lab) |
---|
1523 | (if (lap-label-emitted-p lab) |
---|
1524 | (let* ((labaddr (lap-label-address lab))) |
---|
1525 | (dolist (ref (lap-label-refs lab)) |
---|
1526 | (destructuring-bind (insn . reftype) ref |
---|
1527 | (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn))))) |
---|
1528 | (case reftype |
---|
1529 | (:b (setf (lap-instruction-opcode insn) |
---|
1530 | (dpb (ash diff-in-bytes -2) |
---|
1531 | (byte 24 0) |
---|
1532 | (lap-instruction-opcode insn)))) |
---|
1533 | (:mem12 |
---|
1534 | (if (>= diff-in-bytes 0) |
---|
1535 | (set-field-value insn (byte 1 23) 1) |
---|
1536 | (setq diff-in-bytes (- diff-in-bytes))) |
---|
1537 | (when (> (integer-length diff-in-bytes) 12) |
---|
1538 | (error "PC-relative displacement can't be encoded.")) |
---|
1539 | (set-field-value insn (byte 12 0) diff-in-bytes)) |
---|
1540 | (:offset |
---|
1541 | (setf (lap-instruction-opcode insn) |
---|
1542 | (1+ (ash (lap-instruction-address insn) (- arm::word-shift))))) |
---|
1543 | (t |
---|
1544 | (error "Label type ~s invalid or not yet supported." |
---|
1545 | reftype))))))) |
---|
1546 | (if (lap-label-refs lab) |
---|
1547 | (error "LAP label ~s was referenced but not defined." (lap-label-name lab))))) |
---|
1548 | (ccl::merge-dll-nodes primary constant-pool) |
---|
1549 | (let* ((last (ccl::dll-header-last primary))) |
---|
1550 | (ash (+ (instruction-element-address last) |
---|
1551 | (instruction-element-size last)) -2))) |
---|
1552 | |
---|
1553 | ;;; We want to be able to write vinsn templates using a (mostly) LAP-like |
---|
1554 | ;;; syntax, but ideally don't want to have to repeatedly expand those |
---|
1555 | ;;; vinsn-definition-time-invariant elements of that syntax. |
---|
1556 | ;;; |
---|
1557 | ;;; For example, if DEST is a vinsn parameter and the vinsn body |
---|
1558 | ;;; contains: |
---|
1559 | ;;; |
---|
1560 | ;;; (ldr DEST (:@ rcontext (:$ arm::tcr.db-link))) |
---|
1561 | ;;; |
---|
1562 | ;;; then we know at definition time: |
---|
1563 | ;;; 1) the opcode of the LDR instruction (obviously) |
---|
1564 | ;;; 2) the fact that the LDR's :mem12 operand uses indexed |
---|
1565 | ;;; addressing with an immediate operand and no writeback |
---|
1566 | ;;; 3) in this example, we also know the value of the RB field |
---|
1567 | ;;; and the value of the immediate operand, which happens |
---|
1568 | ;;; to be positive (setting the U bit). |
---|
1569 | ;;; |
---|
1570 | ;;; We can apply this knowledge at definition time, and set |
---|
1571 | ;;; the appropriate bits (U, RN, IMM12) in the opcode. |
---|
1572 | ;;; |
---|
1573 | ;;; We don't, of course, know the value of DEST at vinsn-definition |
---|
1574 | ;;; time, but we do know that it's the Nth vinsn parameter, so we |
---|
1575 | ;;; can turn this example into something like: |
---|
1576 | ;;; |
---|
1577 | ;;; `(,(augmented-opcode-for-LDR) #(rd-field) #(index-of-DEST) |
---|
1578 | ;;; |
---|
1579 | ;;; This is defined here (rather than in the compiler backend) since |
---|
1580 | ;;; it needs to know a lot about ARM instruction encoding. |
---|
1581 | |
---|
1582 | (defstruct (arm-vinsn-instruction (:constructor %make-arm-vinsn-instruction) |
---|
1583 | (:conc-name avi-)) |
---|
1584 | head |
---|
1585 | tail) |
---|
1586 | |
---|
1587 | (defun make-arm-vinsn-instruction (opcode) |
---|
1588 | (let* ((head (list opcode))) |
---|
1589 | (%make-arm-vinsn-instruction :head head :tail head))) |
---|
1590 | |
---|
1591 | (defun add-avi-operand (instruction field-type value) |
---|
1592 | (let* ((tail (avi-tail instruction))) |
---|
1593 | (setf (avi-tail instruction) |
---|
1594 | (cdr (rplacd tail (cons (cons field-type value) nil)))))) |
---|
1595 | |
---|
1596 | (defun avi-opcode (avi) |
---|
1597 | (car (avi-head avi))) |
---|
1598 | |
---|
1599 | (defun (setf avi-opcode) (new avi) |
---|
1600 | (setf (car (avi-head avi)) new)) |
---|
1601 | |
---|
1602 | (defun set-avi-opcode-field (avi bytespec value) |
---|
1603 | (setf (avi-opcode avi) |
---|
1604 | (dpb value bytespec (avi-opcode avi))) |
---|
1605 | value) |
---|
1606 | |
---|
1607 | |
---|
1608 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
1609 | (defparameter *vinsn-field-types* |
---|
1610 | #(:cond |
---|
1611 | :negated-cond |
---|
1612 | :rn |
---|
1613 | :rd |
---|
1614 | :rm |
---|
1615 | :rs |
---|
1616 | :alu-constant |
---|
1617 | :shift-count ;shift type is always explicit |
---|
1618 | :mem12-offset |
---|
1619 | :mem8-offset |
---|
1620 | :reglist-bit |
---|
1621 | :uuoA |
---|
1622 | :uuo-unary |
---|
1623 | :uuoB |
---|
1624 | :label |
---|
1625 | :subprim |
---|
1626 | :data-label |
---|
1627 | :dd |
---|
1628 | :dm |
---|
1629 | :sd |
---|
1630 | :sm |
---|
1631 | :dn |
---|
1632 | :sn |
---|
1633 | :fpaddr-offset |
---|
1634 | :uuoC |
---|
1635 | :imm16 |
---|
1636 | ))) |
---|
1637 | |
---|
1638 | (defmacro encode-vinsn-field-type (name) |
---|
1639 | (or (position name *vinsn-field-types*) |
---|
1640 | (error "Unknown vinsn-field-type name ~s." name))) |
---|
1641 | |
---|
1642 | (defparameter *arm-vinsn-operand-parsers* |
---|
1643 | #(vinsn-parse-rd-operand |
---|
1644 | vinsn-parse-rn-operand |
---|
1645 | vinsn-parse-shifter-operand |
---|
1646 | vinsn-parse-m12-operand |
---|
1647 | vinsn-parse-reglist-operand |
---|
1648 | vinsn-parse-rnw-operand |
---|
1649 | vinsn-parse-uuoa-operand |
---|
1650 | vinsn-parse-uuo-unary-operand |
---|
1651 | vinsn-parse-uuob-operand |
---|
1652 | vinsn-parse-rm-operand |
---|
1653 | vinsn-parse-b-operand |
---|
1654 | vinsn-parse-subprim-operand |
---|
1655 | vinsn-parse-m8-operand |
---|
1656 | vinsn-parse-dd-operand |
---|
1657 | vinsn-parse-dm-operand |
---|
1658 | vinsn-parse-sd-operand |
---|
1659 | vinsn-parse-sm-operand |
---|
1660 | vinsn-parse-dn-operand |
---|
1661 | vinsn-parse-sn-operand |
---|
1662 | vinsn-parse-rde-operand |
---|
1663 | vinsn-parse-rs-operand |
---|
1664 | vinsn-parse-fpaddr-operand |
---|
1665 | vinsn-parse-@rn-operand |
---|
1666 | vinsn-parse-uuoc-operand |
---|
1667 | vinsn-parse-fpux-operand |
---|
1668 | vinsn-parse-imm16-operand |
---|
1669 | )) |
---|
1670 | |
---|
1671 | (defun vinsn-arg-or-gpr (avi form vinsn-params encoded-type bytespec) |
---|
1672 | (let* ((p (position form vinsn-params))) |
---|
1673 | (cond (p |
---|
1674 | (add-avi-operand avi encoded-type (list p)) |
---|
1675 | nil) |
---|
1676 | (t |
---|
1677 | (set-avi-opcode-field avi bytespec (need-arm-gpr form)))))) |
---|
1678 | |
---|
1679 | (defun vinsn-arg-or-dfpr (avi form vinsn-params encoded-type bytespec) |
---|
1680 | (let* ((p (position form vinsn-params))) |
---|
1681 | (cond (p |
---|
1682 | (add-avi-operand avi encoded-type (list p)) |
---|
1683 | nil) |
---|
1684 | (t |
---|
1685 | (set-avi-opcode-field avi bytespec (need-arm-dfpr form)))))) |
---|
1686 | |
---|
1687 | (defun vinsn-arg-or-sfpr (avi form vinsn-params encoded-type top4 low1) |
---|
1688 | (let* ((p (position form vinsn-params))) |
---|
1689 | (cond (p |
---|
1690 | (add-avi-operand avi encoded-type (list p)) |
---|
1691 | nil) |
---|
1692 | (t |
---|
1693 | (let* ((val (need-arm-sfpr form))) |
---|
1694 | (set-avi-opcode-field avi top4 (ash val -1)) |
---|
1695 | (set-avi-opcode-field avi low1 (logand val 1))))))) |
---|
1696 | |
---|
1697 | (defun simplify-arm-vinsn-application (form params) |
---|
1698 | (labels ((simplify-operand (op) |
---|
1699 | (if (atom op) |
---|
1700 | (if (typep form 'fixnum) |
---|
1701 | op |
---|
1702 | (if (constantp op) |
---|
1703 | (eval op) |
---|
1704 | (let* ((p (position op params))) |
---|
1705 | (if p |
---|
1706 | (list p) |
---|
1707 | (error "Unknown operand: ~s" op))))) |
---|
1708 | (if (eq (car op) :apply) |
---|
1709 | `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) |
---|
1710 | (eval op))))) |
---|
1711 | `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form))))) |
---|
1712 | |
---|
1713 | (defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec) |
---|
1714 | (let* ((p (position form vinsn-params))) |
---|
1715 | (cond (p |
---|
1716 | (add-avi-operand avi encoded-type (list p)) |
---|
1717 | nil) |
---|
1718 | ((and (typep form 'keyword) |
---|
1719 | (eql encoded-type (encode-vinsn-field-type :mem12-offset))) |
---|
1720 | (add-avi-operand avi (encode-vinsn-field-type :data-label) form) |
---|
1721 | nil) |
---|
1722 | ((and (consp form) (eq (car form) :apply)) |
---|
1723 | (add-avi-operand avi encoded-type (simplify-arm-vinsn-application form vinsn-params)) |
---|
1724 | nil) |
---|
1725 | (t |
---|
1726 | (let* ((val (eval form))) |
---|
1727 | (when bytespec |
---|
1728 | (set-avi-opcode-field avi bytespec val)) |
---|
1729 | val))))) |
---|
1730 | |
---|
1731 | |
---|
1732 | |
---|
1733 | (defun vinsn-parse-rd-operand (avi value vinsn-params) |
---|
1734 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12))) |
---|
1735 | |
---|
1736 | (defun vinsn-parse-rn-operand (avi value vinsn-params) |
---|
1737 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))) |
---|
1738 | |
---|
1739 | (defun vinsn-parse-shifter-operand (avi value vinsn-params) |
---|
1740 | (if (atom value) |
---|
1741 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1742 | (ecase (car value) |
---|
1743 | (:$ |
---|
1744 | (destructuring-bind (v) (cdr value) |
---|
1745 | (let* ((val (vinsn-arg-or-constant avi v vinsn-params (encode-vinsn-field-type :alu-constant) nil))) |
---|
1746 | (when val |
---|
1747 | (let* ((constant (encode-arm-immediate val))) |
---|
1748 | (if constant |
---|
1749 | (progn |
---|
1750 | (set-avi-opcode-field avi (byte 1 25) 1) |
---|
1751 | (set-avi-opcode-field avi (byte 12 0) constant)) |
---|
1752 | (let* ((op (ldb (byte 4 21) (avi-opcode avi))) |
---|
1753 | (newop nil)) |
---|
1754 | (if (or (and (setq constant (encode-arm-immediate (lognot val))) |
---|
1755 | (setq newop (svref *equivalent-complemented-opcodes* op))) |
---|
1756 | (and (setq constant (encode-arm-immediate (- val))) |
---|
1757 | (setq newop (svref *equivalent-negated-opcodes* op)))) |
---|
1758 | (progn |
---|
1759 | (set-avi-opcode-field avi (byte 1 25) 1) |
---|
1760 | (set-avi-opcode-field avi (byte 4 21) newop) |
---|
1761 | (set-avi-opcode-field avi (byte 12 0) constant)) |
---|
1762 | |
---|
1763 | (error "Can't encode ARM constant ~s." value))))))))) |
---|
1764 | (:rrx |
---|
1765 | (destructuring-bind (rm) (cdr value) |
---|
1766 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1767 | (set-avi-opcode-field avi (byte 2 5) 3))) |
---|
1768 | ((:lsl :lsr :asr :ror) |
---|
1769 | (destructuring-bind (rm count) (cdr value) |
---|
1770 | (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type (car value))) |
---|
1771 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1772 | (cond |
---|
1773 | ((atom count) |
---|
1774 | (set-avi-opcode-field avi (byte 1 4) 1) |
---|
1775 | (vinsn-arg-or-gpr avi count vinsn-params (encode-vinsn-field-type :rs) (byte 4 8))) |
---|
1776 | (t |
---|
1777 | (unless (eq (car count) :$) |
---|
1778 | (error "Invalid shift count: ~s" count)) |
---|
1779 | (destructuring-bind (countval) (cdr count) |
---|
1780 | (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))))))) |
---|
1781 | |
---|
1782 | (defun vinsn-parse-m12-operand (avi value vinsn-params) |
---|
1783 | (when (typep value 'keyword) |
---|
1784 | (setq value `(:@ arm::pc (:$ ,value)))) |
---|
1785 | (destructuring-bind (op rn index) value ; no (:@ reg) sugar |
---|
1786 | (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) |
---|
1787 | (let* ((constant-index (and (consp index) (eq (car index) :$)))) |
---|
1788 | (unless constant-index |
---|
1789 | (set-avi-opcode-field avi (byte 1 25) 1)) |
---|
1790 | (cond |
---|
1791 | ((atom index) |
---|
1792 | (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))) |
---|
1793 | (constant-index |
---|
1794 | (destructuring-bind (constform) (cdr index) |
---|
1795 | (let* ((constval |
---|
1796 | (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem12-offset) nil))) |
---|
1797 | (when constval |
---|
1798 | (if (< constval 0) |
---|
1799 | (setq constval (- constval)) |
---|
1800 | (set-avi-opcode-field avi (byte 1 23) 1)) |
---|
1801 | (unless (typep constval '(unsigned-byte 12)) |
---|
1802 | (warn "constant offset too large : ~s" constval)) |
---|
1803 | (set-avi-opcode-field avi (byte 12 0) constval))))) |
---|
1804 | ((eq (car index) :rrx) |
---|
1805 | (destructuring-bind (rm) (cdr index) |
---|
1806 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1807 | (set-avi-opcode-field avi (byte 2 5) 3))) |
---|
1808 | (t |
---|
1809 | (destructuring-bind (shift-op rm shift-count) index |
---|
1810 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1811 | (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op)) |
---|
1812 | |
---|
1813 | (unless (and (consp shift-count) |
---|
1814 | (eq (car shift-count) :$)) |
---|
1815 | (error "Invalid shift-count: ~s" shift-count)) |
---|
1816 | (destructuring-bind (shift-count-form) (cdr shift-count) |
---|
1817 | (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))) |
---|
1818 | (setf (avi-opcode avi) |
---|
1819 | (set-opcode-value-from-addressing-mode (avi-opcode avi) op constant-index))))) |
---|
1820 | |
---|
1821 | (defun vinsn-parse-reglist-operand (avi value vinsn-params) |
---|
1822 | (dolist (r value) |
---|
1823 | (let* ((p (position r vinsn-params))) |
---|
1824 | (if p |
---|
1825 | (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p)) |
---|
1826 | (let* ((bit (need-arm-gpr r))) |
---|
1827 | (setf (avi-opcode avi) |
---|
1828 | (logior (avi-opcode avi) (ash 1 bit)))))))) |
---|
1829 | |
---|
1830 | (defun vinsn-parse-rnw-operand (avi value vinsn-params) |
---|
1831 | (let* ((rn (if (atom value) |
---|
1832 | value |
---|
1833 | (destructuring-bind (marker reg) value |
---|
1834 | (if (eq marker :!) |
---|
1835 | (set-avi-opcode-field avi (byte 1 21) 1) |
---|
1836 | (error "Unrecognized writeback indicator in ~s." value)) |
---|
1837 | reg)))) |
---|
1838 | (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))) |
---|
1839 | |
---|
1840 | (defun vinsn-parse-uuoA-operand (avi value vinsn-params) |
---|
1841 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoA) (byte 4 8))) |
---|
1842 | |
---|
1843 | (defun vinsn-parse-uuo-unary-operand (avi value vinsn-params) |
---|
1844 | (when (or (atom value) |
---|
1845 | (not (eq (car value) :$))) |
---|
1846 | (error "Invalid constant syntax in ~s." value)) |
---|
1847 | (destructuring-bind (valform) (cdr value) |
---|
1848 | (vinsn-arg-or-constant avi valform vinsn-params (encode-vinsn-field-type :uuo-unary) (byte 8 12)))) |
---|
1849 | |
---|
1850 | (defun vinsn-parse-uuoB-operand (avi value vinsn-params) |
---|
1851 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoB) (byte 4 12))) |
---|
1852 | |
---|
1853 | (defun vinsn-parse-uuoC-operand (avi value vinsn-params) |
---|
1854 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoC) (byte 4 16))) |
---|
1855 | |
---|
1856 | (defun vinsn-parse-fpux-operand (avi value vinsn-params) |
---|
1857 | (declare (ignore vinsn-params)) |
---|
1858 | (let* ((regno (if (typep value '(unsigned-byte 4)) |
---|
1859 | value |
---|
1860 | (ecase (keywordize value) |
---|
1861 | (:fpsid 0) |
---|
1862 | (:fpscr 1) |
---|
1863 | (:fpexc 8))))) |
---|
1864 | (set-avi-opcode-field avi (byte 4 16) regno))) |
---|
1865 | |
---|
1866 | (defun vinsn-parse-rm-operand (avi value vinsn-params) |
---|
1867 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))) |
---|
1868 | |
---|
1869 | (defun vinsn-parse-b-operand (avi value vinsn-params) |
---|
1870 | ;; Pretty much has to be a param or a local label what else would we b to ? |
---|
1871 | (let* ((p (position value vinsn-params)) |
---|
1872 | (addr nil)) |
---|
1873 | (cond (p |
---|
1874 | (add-avi-operand avi (encode-vinsn-field-type :label) (list p))) |
---|
1875 | ((typep value 'keyword) |
---|
1876 | (add-avi-operand avi (encode-vinsn-field-type :label) value)) |
---|
1877 | ((setq addr (arm-subprimitive-address value)) |
---|
1878 | (add-avi-operand avi (encode-vinsn-field-type :label) addr)) |
---|
1879 | ((arm-subprimitive-name value) |
---|
1880 | (add-avi-operand avi (encode-vinsn-field-type :label) value)) |
---|
1881 | (t |
---|
1882 | (error "Unknown branch target: ~s." value))))) |
---|
1883 | |
---|
1884 | ;;; This can only appear in a BA (mov PC,(:$ addr)) instruction, which |
---|
1885 | ;;; already has bit 25 set. |
---|
1886 | (defun vinsn-parse-subprim-operand (avi value vinsn-params) |
---|
1887 | (let* ((p (position value vinsn-params))) |
---|
1888 | (if p |
---|
1889 | (add-avi-operand avi (encode-vinsn-field-type :subprim) (list p)) |
---|
1890 | (let* ((addr (or (arm-subprimitive-address value) |
---|
1891 | (and (typep value 'integer) |
---|
1892 | (>= value #x4000) |
---|
1893 | (< value #x10000) |
---|
1894 | (not (logtest #x7f value)))))) |
---|
1895 | (unless addr |
---|
1896 | (error "Unknown ARM subprimitive address: ~s." value)) |
---|
1897 | (set-avi-opcode-field avi (byte 12 0) (encode-arm-immediate addr)))))) |
---|
1898 | |
---|
1899 | (defun vinsn-parse-m8-operand (avi value vinsn-params) |
---|
1900 | (if (atom value) |
---|
1901 | (error "Invalid memory operand ~s." value) |
---|
1902 | (destructuring-bind (mode rn index) value |
---|
1903 | (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) |
---|
1904 | (let* ((constant-index (and (consp index) (eq (car index) :$)))) |
---|
1905 | (when constant-index |
---|
1906 | (set-avi-opcode-field avi (byte 1 22) 1)) |
---|
1907 | (cond ((atom index) |
---|
1908 | (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))) |
---|
1909 | (constant-index |
---|
1910 | (destructuring-bind (constform) (cdr index) |
---|
1911 | (let* ((constval |
---|
1912 | (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem8-offset) nil))) |
---|
1913 | (when constval |
---|
1914 | (if (< constval 0) |
---|
1915 | (setq constval (- constval)) |
---|
1916 | (set-avi-opcode-field avi (byte 1 23) 1)) |
---|
1917 | (unless (typep constval '(unsigned-byte 8)) |
---|
1918 | (warn "constant offset too large : ~s" constval)) |
---|
1919 | (set-avi-opcode-field avi (byte 4 0) (ldb (byte 4 0) constval)) |
---|
1920 | (set-avi-opcode-field avi (byte 4 8) (ldb (byte 4 4) constval)))))) |
---|
1921 | ((eq (car index) :rrx) |
---|
1922 | (destructuring-bind (rm) (cdr index) |
---|
1923 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1924 | (set-avi-opcode-field avi (byte 2 5) 3))) |
---|
1925 | (t |
---|
1926 | (destructuring-bind (shift-op rm shift-count) index |
---|
1927 | (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)) |
---|
1928 | (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op)) |
---|
1929 | (unless (and (consp shift-count) |
---|
1930 | (eq (car shift-count) :$)) |
---|
1931 | (error "Invalid shift-count: ~s" shift-count)) |
---|
1932 | (destructuring-bind (shift-count-form) (cdr shift-count) |
---|
1933 | (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))) |
---|
1934 | (setf (avi-opcode avi) |
---|
1935 | (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index)))))) |
---|
1936 | |
---|
1937 | (defun vinsn-parse-dd-operand (avi value vinsn-params) |
---|
1938 | (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dd) (byte 4 12))) |
---|
1939 | |
---|
1940 | (defun vinsn-parse-dm-operand (avi value vinsn-params) |
---|
1941 | (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dm) (byte 4 0))) |
---|
1942 | |
---|
1943 | (defun vinsn-parse-sd-operand (avi value vinsn-params) |
---|
1944 | (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sd) (byte 4 12) (byte 1 22))) |
---|
1945 | |
---|
1946 | (defun vinsn-parse-sm-operand (avi value vinsn-params) |
---|
1947 | (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sm) (byte 4 0) (byte 1 5))) |
---|
1948 | |
---|
1949 | (defun vinsn-parse-dn-operand (avi value vinsn-params) |
---|
1950 | (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dn) (byte 4 16))) |
---|
1951 | |
---|
1952 | (defun vinsn-parse-sn-operand (avi value vinsn-params) |
---|
1953 | (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sn) (byte 4 16) (byte 1 7))) |
---|
1954 | |
---|
1955 | (defun vinsn-parse-rde-operand (avi value vinsn-params) |
---|
1956 | (let* ((val (get-arm-gpr value))) |
---|
1957 | (when (and val (oddp val)) |
---|
1958 | (error "Register ~s must be even-numbered." value))) |
---|
1959 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12))) |
---|
1960 | |
---|
1961 | (defun vinsn-parse-rs-operand (avi value vinsn-params) |
---|
1962 | (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (byte 4 8))) |
---|
1963 | |
---|
1964 | (defun vinsn-parse-fpaddr-operand (avi value vinsn-params) |
---|
1965 | (destructuring-bind (op rn offset) value |
---|
1966 | (unless (eq op :@) (error "Bad FP address operand: ~s." value)) |
---|
1967 | (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)) |
---|
1968 | (destructuring-bind (marker offform) offset |
---|
1969 | (unless (eq marker :$) (error "Bad FP offset: ~s" offset)) |
---|
1970 | (let* ((offval (vinsn-arg-or-constant avi offform vinsn-params (encode-vinsn-field-type :fpaddr-offset) nil))) |
---|
1971 | (when offval |
---|
1972 | (if (< offval 0) |
---|
1973 | (setq offval (- offval)) |
---|
1974 | (set-avi-opcode-field avi (byte 1 23) 1)) |
---|
1975 | (when (logtest 3 offval) |
---|
1976 | (error "Memory offset ~s must be a multiple of 4." offval)) |
---|
1977 | (set-avi-opcode-field avi (byte 8 0) (ash offval -2))))))) |
---|
1978 | |
---|
1979 | (defun vinsn-parse-imm16-operand (avi value vinsn-params) |
---|
1980 | (unless (and (consp value) |
---|
1981 | (eq (car value) :$) |
---|
1982 | (consp (cdr value)) |
---|
1983 | (null (cddr value))) |
---|
1984 | (error "Bad imm16 constant operand syntax: ~s." value)) |
---|
1985 | (let* ((val (vinsn-arg-or-constant avi (cadr value) vinsn-params (encode-vinsn-field-type :imm16) nil))) |
---|
1986 | (when val |
---|
1987 | (set-avi-opcode-field avi (byte 12 0) (ldb (byte 12 0) val)) |
---|
1988 | (set-avi-opcode-field avi (byte 4 16) (ldb (byte 4 12) val))))) |
---|
1989 | |
---|
1990 | |
---|
1991 | (defun vinsn-simplify-instruction (form vinsn-params) |
---|
1992 | (destructuring-bind (name . opvals) form |
---|
1993 | (case name |
---|
1994 | ((:code :data) form) |
---|
1995 | (:word (destructuring-bind (val) opvals |
---|
1996 | (let* ((p (position val vinsn-params))) |
---|
1997 | (list name (if p (list p) (eval val)))))) |
---|
1998 | (t |
---|
1999 | (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name) |
---|
2000 | (unless template |
---|
2001 | (error "Unknown ARM instruction - ~s" form)) |
---|
2002 | (let* ((cond-indicator (and (consp (car opvals)) |
---|
2003 | (keywordize (caar opvals)))) |
---|
2004 | (avi (make-arm-vinsn-instruction (arm-instruction-template-val template)))) |
---|
2005 | (when (or (eq cond-indicator :?) |
---|
2006 | (eq cond-indicator :~)) |
---|
2007 | (let* ((condform (pop opvals))) |
---|
2008 | (destructuring-bind (cond-name) (cdr condform) |
---|
2009 | (let* ((p (position cond-name vinsn-params))) |
---|
2010 | (if p |
---|
2011 | (if explicit-cond |
---|
2012 | (error "Can't use ~s with explicit condition name." condform) |
---|
2013 | (progn |
---|
2014 | (add-avi-operand avi (if (eq cond-indicator :?) |
---|
2015 | (encode-vinsn-field-type :cond) |
---|
2016 | (encode-vinsn-field-type :negated-cond)) |
---|
2017 | (list p)) |
---|
2018 | (setq cond nil))) |
---|
2019 | (let* ((c (need-arm-condition-name cond-name))) |
---|
2020 | (when (eq cond-indicator :~) |
---|
2021 | (if (< c 14) |
---|
2022 | (setq c (logxor c 1)) |
---|
2023 | (error "Invalid explicit condition ~s." condform))) |
---|
2024 | (if (and explicit-cond (not (eql c cond))) |
---|
2025 | (error "Can't use explicit condition and :? : ~s" condform) |
---|
2026 | (setq cond c)))))))) |
---|
2027 | (let* ((optypes (arm-instruction-template-operand-types template)) |
---|
2028 | (n (length optypes))) |
---|
2029 | (unless (= n (length opvals)) |
---|
2030 | (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form)) |
---|
2031 | (dotimes (i n) |
---|
2032 | (let* ((optype (pop optypes)) |
---|
2033 | (opval (pop opvals))) |
---|
2034 | (funcall (svref *arm-vinsn-operand-parsers* optype) |
---|
2035 | avi opval vinsn-params))) |
---|
2036 | (when cond |
---|
2037 | (set-avi-opcode-field avi (byte 4 28) cond)) |
---|
2038 | (avi-head avi)))))))) |
---|
2039 | |
---|
2040 | |
---|
2041 | (defparameter *arm-vinsn-insert-functions* |
---|
2042 | #(vinsn-insert-cond-operand |
---|
2043 | vinsn-insert-negated-cond-operand |
---|
2044 | vinsn-insert-rn-operand |
---|
2045 | vinsn-insert-rd-operand |
---|
2046 | vinsn-insert-rm-operand |
---|
2047 | vinsn-insert-rs-operand |
---|
2048 | vinsn-insert-alu-constant-operand |
---|
2049 | vinsn-insert-shift-count-operand ;shift type is always explicit |
---|
2050 | vinsn-insert-mem12-offset-operand |
---|
2051 | vinsn-insert-mem8-offset-operand |
---|
2052 | vinsn-insert-reglist-bit-operand |
---|
2053 | vinsn-insert-uuoA-operand |
---|
2054 | vinsn-insert-uuo-unary-operand |
---|
2055 | vinsn-insert-uuoB-operand |
---|
2056 | vinsn-insert-label-operand |
---|
2057 | vinsn-insert-subprim-operand |
---|
2058 | vinsn-insert-data-label-operand |
---|
2059 | vinsn-insert-dd-operand |
---|
2060 | vinsn-insert-dm-operand |
---|
2061 | vinsn-insert-sd-operand |
---|
2062 | vinsn-insert-sm-operand |
---|
2063 | vinsn-insert-dn-operand |
---|
2064 | vinsn-insert-sn-operand |
---|
2065 | vinsn-insert-fpaddr-offset-operand |
---|
2066 | vinsn-insert-uuoc-operand |
---|
2067 | vinsn-insert-imm16-operand |
---|
2068 | )) |
---|
2069 | |
---|
2070 | (defun vinsn-insert-cond-operand (instruction value) |
---|
2071 | (set-field-value instruction (byte 4 28) value)) |
---|
2072 | |
---|
2073 | (defun vinsn-insert-negated-cond-operand (instruction value) |
---|
2074 | (set-field-value instruction (byte 4 28) (logxor value 1))) |
---|
2075 | |
---|
2076 | (defun vinsn-insert-rn-operand (instruction value) |
---|
2077 | (set-field-value instruction (byte 4 16) value)) |
---|
2078 | |
---|
2079 | (defun vinsn-insert-rd-operand (instruction value) |
---|
2080 | (set-field-value instruction (byte 4 12) value)) |
---|
2081 | |
---|
2082 | (defun vinsn-insert-rm-operand (instruction value) |
---|
2083 | (set-field-value instruction (byte 4 0) value)) |
---|
2084 | |
---|
2085 | (defun vinsn-insert-rs-operand (instruction value) |
---|
2086 | (set-field-value instruction (byte 4 8) value)) |
---|
2087 | |
---|
2088 | (defun vinsn-insert-alu-constant-operand (instruction value) |
---|
2089 | (insert-shifter-constant value instruction)) |
---|
2090 | |
---|
2091 | (defun vinsn-insert-shift-count-operand (instruction value) |
---|
2092 | (set-field-value instruction (byte 5 7) value)) |
---|
2093 | |
---|
2094 | (defun vinsn-insert-mem12-offset-operand (instruction value) |
---|
2095 | (if (typep value 'lap-label) |
---|
2096 | (lap-note-label-reference value instruction :mem12) |
---|
2097 | (progn |
---|
2098 | (if (< value 0) |
---|
2099 | (setq value (- value)) |
---|
2100 | (set-field-value instruction (byte 1 23) 1)) |
---|
2101 | (set-field-value instruction (byte 12 0) value)))) |
---|
2102 | |
---|
2103 | (defun vinsn-insert-mem8-offset-operand (instruction value) |
---|
2104 | (if (< value 0) |
---|
2105 | (setq value (- value)) |
---|
2106 | (set-field-value instruction (byte 1 23) 1)) |
---|
2107 | (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)) |
---|
2108 | (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))) |
---|
2109 | |
---|
2110 | (defun vinsn-insert-reglist-bit-operand (instruction value) |
---|
2111 | (set-field-value instruction (byte 1 value) 1)) |
---|
2112 | |
---|
2113 | (defun vinsn-insert-uuoA-operand (instruction value) |
---|
2114 | (set-field-value instruction (byte 4 8) value)) |
---|
2115 | |
---|
2116 | (defun vinsn-insert-uuo-unary-operand (instruction value) |
---|
2117 | (set-field-value instruction (byte 8 12) value)) |
---|
2118 | |
---|
2119 | (defun vinsn-insert-uuoB-operand (instruction value) |
---|
2120 | (set-field-value instruction (byte 4 12) value)) |
---|
2121 | |
---|
2122 | (defun vinsn-insert-uuoC-operand (instruction value) |
---|
2123 | (set-field-value instruction (byte 4 16) value)) |
---|
2124 | |
---|
2125 | (defun vinsn-insert-label-operand (instruction value) |
---|
2126 | (let* ((label (etypecase value |
---|
2127 | (cons (or (find-lap-label value) |
---|
2128 | (error "No LAP label for ~s." (car value)))) |
---|
2129 | (lap-label value) |
---|
2130 | (ccl::vinsn-label |
---|
2131 | (or (find-lap-label value) |
---|
2132 | (make-lap-label value))) |
---|
2133 | (fixnum (let* ((lab (or (find-lap-label value) |
---|
2134 | (make-lap-label value)))) |
---|
2135 | (pushnew lab *called-subprim-jmp-labels*) |
---|
2136 | lab))))) |
---|
2137 | (push (cons instruction :b) (lap-label-refs label)))) |
---|
2138 | |
---|
2139 | (defun vinsn-insert-subprim-operand (instruction value) |
---|
2140 | (insert-shifter-constant value instruction)) |
---|
2141 | |
---|
2142 | (defun vinsn-insert-data-label-operand (instruction value) |
---|
2143 | (let* ((label (if (typep value 'lap-label) value (find-lap-label value)))) |
---|
2144 | (unless label |
---|
2145 | (error "Mystery data label: ~s" value)) |
---|
2146 | (push (cons instruction :mem12) (lap-label-refs label)))) |
---|
2147 | |
---|
2148 | (defun vinsn-insert-dd-operand (instruction value) |
---|
2149 | (set-field-value instruction (byte 4 12) value) ) |
---|
2150 | |
---|
2151 | (defun vinsn-insert-dm-operand (instruction value) |
---|
2152 | (set-field-value instruction (byte 4 0) value)) |
---|
2153 | |
---|
2154 | (defun vinsn-insert-sd-operand (instruction value) |
---|
2155 | (set-field-value instruction (byte 4 12) (ash value -1)) |
---|
2156 | (set-field-value instruction (byte 1 22) (logand value 1))) |
---|
2157 | |
---|
2158 | (defun vinsn-insert-sm-operand (instruction value) |
---|
2159 | (set-field-value instruction (byte 4 0) (ash value -1)) |
---|
2160 | (set-field-value instruction (byte 1 5) (logand value 1))) |
---|
2161 | |
---|
2162 | (defun vinsn-insert-dn-operand (instruction value) |
---|
2163 | (set-field-value instruction (byte 4 16) value)) |
---|
2164 | |
---|
2165 | (defun vinsn-insert-sn-operand (instruction value) |
---|
2166 | (set-field-value instruction (byte 4 16) (ash value -1)) |
---|
2167 | (set-field-value instruction (byte 1 7) (logand value 1))) |
---|
2168 | |
---|
2169 | (defun vinsn-insert-fpaddr-offset-operand (instruction value) |
---|
2170 | (if (< value 0) |
---|
2171 | (setq value (- value)) |
---|
2172 | (set-field-value instruction (byte 1 23) 1)) |
---|
2173 | (set-field-value instruction (byte 8 0) (ash value -2))) |
---|
2174 | |
---|
2175 | (defun vinsn-insert-imm16-operand (instruction value) |
---|
2176 | (set-field-value instruction (byte 12 0) (ldb (byte 12 0) value)) |
---|
2177 | (set-field-value instruction (byte 4 16) (ldb (byte 4 12) value))) |
---|
2178 | |
---|
2179 | |
---|
2180 | |
---|
2181 | (provide "ARM-ASM") |
---|