1 ;;;; that part of the description of the ARM instruction set (for
2 ;;;; ARMv5) which can live on the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
14 ;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
15 ;;; I wonder whether the separation of the disassembler from the
16 ;;; virtual machine is valid or adds value.
18 (setf sb
!disassem
:*disassem-inst-alignment-bytes
* 4)
21 (defparameter *conditions
*
37 (defparameter *condition-name-vec
*
38 (let ((vec (make-array 16 :initial-element nil
)))
39 (dolist (cond *conditions
*)
40 (when (null (aref vec
(cdr cond
)))
41 (setf (aref vec
(cdr cond
)) (car cond
))))
44 ;;; Set assembler parameters. (In CMU CL, this was done with
45 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
46 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
47 (setf sb
!assem
:*assem-scheduler-p
* nil
))
49 (defun conditional-opcode (condition)
50 (cdr (assoc condition
*conditions
* :test
#'eq
)))
52 ;;;; disassembler field definitions
54 (defun maybe-add-notes (dstate)
55 (let* ((inst (sb!disassem
::sap-ref-int
56 (sb!disassem
:dstate-segment-sap dstate
)
57 (sb!disassem
:dstate-cur-offs dstate
)
59 (sb!disassem
::dstate-byte-order dstate
)))
60 (op (ldb (byte 8 20) inst
))
61 (offset (ldb (byte 12 0) inst
))
62 (rn (ldb (byte 4 16) inst
)))
63 (cond ((and (= rn null-offset
))
64 (let ((offset (+ nil-value offset
)))
67 (sb!disassem
:maybe-note-assembler-routine offset nil dstate
)
68 (sb!disassem
::maybe-note-static-symbol
69 (logior offset other-pointer-lowtag
) dstate
))
71 (sb!disassem
::maybe-note-static-symbol offset dstate
)))))
77 (sb!disassem
:note-code-constant offset dstate
))
79 (let ((value (sb!disassem
::sap-ref-int
80 (sb!disassem
:dstate-segment-sap dstate
)
81 (+ (sb!disassem
:dstate-cur-offs dstate
)
84 (sb!disassem
::dstate-byte-order dstate
))))
85 (sb!disassem
:maybe-note-assembler-routine value nil dstate
))))))))))
87 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
88 ;; DEFINE-ARG-TYPE requires that any :PRINTER be defined at
89 ;; compile-time... Why?
91 (defun print-condition (value stream dstate
)
92 (declare (type stream stream
)
95 (unless (= value
14) ;; Don't print :al
96 (princ (aref *condition-name-vec
* value
) stream
)))
98 (defun print-reg (value stream dstate
)
99 (declare (type stream stream
)
102 (princ (aref *register-names
* value
) stream
))
104 (defun print-float-reg (value stream dstate
)
105 (declare (type stream stream
)
108 (destructuring-bind (double high low
) value
109 (format stream
"~[S~;D~]~a"
113 (logior (ash high
1) low
)))))
115 (defun print-float-sys-reg (value stream dstate
)
116 (declare (type stream stream
)
122 (#b1000
"FPEXC")) stream
))
124 (defun print-shift-type (value stream dstate
)
125 (declare (type stream stream
)
128 (princ (aref #(lsl lsr asr ror
) value
) stream
))
130 (defun print-immediate-shift (value stream dstate
)
131 (declare (type stream stream
)
132 (type (cons fixnum
(cons fixnum null
)) value
)
134 (destructuring-bind (amount shift
) value
137 (zerop shift
))) ;; No shift
140 (princ ", RRX" stream
))
143 (princ (aref #(lsl lsr asr ror
) shift
) stream
)
145 (princ amount stream
)))))
147 (defun print-shifter-immediate (value stream dstate
)
148 (declare (type stream stream
)
150 (maybe-add-notes dstate
)
151 (let* ((rotate (ldb (byte 4 8) value
))
152 (immediate (mask-field (byte 8 0) value
))
153 (left (mask-field (byte 32 0)
154 (ash immediate
(- 32 rotate rotate
))))
155 (right (ash immediate
(- 0 rotate rotate
))))
156 (princ (logior left right
) stream
)))
158 (defun use-label-relative-label (value dstate
)
159 (declare (type (signed-byte 24) value
)
160 (type sb
!disassem
:disassem-state dstate
))
161 (+ 8 (ash value
2) (sb!disassem
:dstate-cur-addr dstate
)))
163 (defun print-load/store-immediate
(value stream dstate
)
164 (declare (type stream stream
)
165 (type (cons bit
(cons bit
(cons bit
(cons fixnum null
)))) value
))
166 (maybe-add-notes dstate
)
167 (destructuring-bind (p u w offset
) value
171 (princ (if (zerop p
) "], #" ", #") stream
)
174 (princ offset stream
)
176 (princ (if (zerop w
) "]" "]!") stream
))))))
178 (defun print-load/store-register
(value stream dstate
)
179 (destructuring-bind (p u w shift-imm shift rm
) value
182 (princ (if (zerop u
) ", -" ", ") stream
)
183 (print-reg rm stream dstate
)
184 (print-immediate-shift (list shift-imm shift
) stream dstate
)
186 (princ (if (zerop w
) "]" "]!") stream
))))
188 (defun print-msr-field-mask (value stream dstate
)
189 (declare (type stream stream
)
190 (type (cons bit
(cons (unsigned-byte 4) null
)) value
)
192 (destructuring-bind (spsr-p field-mask
) value
194 (princ "CPSR_" stream
)
195 (princ "SPSR_" stream
))
196 (when (logbitp 0 field-mask
) (princ "c" stream
))
197 (when (logbitp 1 field-mask
) (princ "x" stream
))
198 (when (logbitp 2 field-mask
) (princ "s" stream
))
199 (when (logbitp 3 field-mask
) (princ "f" stream
))))
202 (sb!disassem
:define-arg-type condition-code
203 :printer
#'print-condition
)
205 (sb!disassem
:define-arg-type reg
206 :printer
#'print-reg
)
208 (sb!disassem
:define-arg-type float-reg
209 :printer
#'print-float-reg
)
211 (sb!disassem
:define-arg-type float-sys-reg
212 :printer
#'print-float-sys-reg
)
214 (sb!disassem
:define-arg-type shift-type
215 :printer
#'print-shift-type
)
217 (sb!disassem
:define-arg-type immediate-shift
218 :printer
#'print-immediate-shift
)
220 (sb!disassem
:define-arg-type shifter-immediate
221 :printer
#'print-shifter-immediate
)
223 (sb!disassem
:define-arg-type relative-label
225 :use-label
#'use-label-relative-label
)
227 (sb!disassem
:define-arg-type load
/store-immediate
228 :printer
#'print-load
/store-immediate
)
230 (sb!disassem
:define-arg-type load
/store-register
231 :printer
#'print-load
/store-register
)
233 ;; We use a prefilter in order to read trap codes in order to avoid
234 ;; encoding the code within the instruction body (requiring the use of
235 ;; a different trap instruction and a SIGILL handler) and in order to
236 ;; avoid attempting to include the code in the decoded instruction
237 ;; proper (requiring moving to a 40-bit instruction for disassembling
238 ;; trap codes, and being affected by endianness issues).
239 (sb!disassem
:define-arg-type debug-trap-code
240 :prefilter
(lambda (value dstate
)
241 (declare (ignore value
))
242 (sb!disassem
:read-suffix
8 dstate
)))
244 (sb!disassem
:define-arg-type msr-field-mask
245 :printer
#'print-msr-field-mask
)
247 ;;;; disassembler instruction format definitions
249 (sb!disassem
:define-instruction-format
250 (dp-shift-immediate 32
251 :default-printer
'(:name cond
:tab rd
", " rn
", " rm shift
))
252 (cond :field
(byte 4 28) :type
'condition-code
)
253 (opcode-8 :field
(byte 8 20))
254 (rn :field
(byte 4 16) :type
'reg
)
255 (rd :field
(byte 4 12) :type
'reg
)
256 (shift :fields
(list (byte 5 7) (byte 2 5)) :type
'immediate-shift
)
257 (register-shift-p :field
(byte 1 4) :value
0)
258 (rm :field
(byte 4 0) :type
'reg
))
260 (sb!disassem
:define-instruction-format
261 (dp-shift-register 32
262 :default-printer
'(:name cond
:tab rd
", " rn
", " rm
", " shift-type
" " rs
))
263 (cond :field
(byte 4 28) :type
'condition-code
)
264 (opcode-8 :field
(byte 8 20))
265 (rn :field
(byte 4 16) :type
'reg
)
266 (rd :field
(byte 4 12) :type
'reg
)
267 (rs :field
(byte 4 8) :type
'reg
)
268 (multiply-p :field
(byte 1 7) :value
0)
269 (shift-type :field
(byte 2 5) :type
'shift-type
)
270 (register-shift-p :field
(byte 1 4) :value
1)
271 (rm :field
(byte 4 0) :type
'reg
))
273 (sb!disassem
:define-instruction-format
275 :default-printer
'(:name cond
:tab rd
", " rn
", #" immediate
))
276 (cond :field
(byte 4 28) :type
'condition-code
)
277 (opcode-8 :field
(byte 8 20))
278 (rn :field
(byte 4 16) :type
'reg
)
279 (rd :field
(byte 4 12) :type
'reg
)
280 (immediate :field
(byte 12 0) :type
'shifter-immediate
))
282 (sb!disassem
:define-instruction-format
283 (branch 32 :default-printer
'(:name cond
:tab target
))
284 (cond :field
(byte 4 28) :type
'condition-code
)
285 (opcode-4 :field
(byte 4 24))
286 (target :field
(byte 24 0) :type
'relative-label
))
288 (sb!disassem
:define-instruction-format
289 (load/store-immediate
32
290 ;; FIXME: cond should come between LDR/STR and B.
291 :default-printer
'(:name cond
:tab rd
", [" rn load
/store-offset
))
292 (cond :field
(byte 4 28) :type
'condition-code
)
293 (opcode-3 :field
(byte 3 25))
294 (load/store-offset
:fields
(list (byte 1 24)
298 :type
'load
/store-immediate
)
299 (opcode-b :field
(byte 1 22))
300 (opcode-l :field
(byte 1 20))
301 (rn :field
(byte 4 16) :type
'reg
)
302 (rd :field
(byte 4 12) :type
'reg
))
304 (sb!disassem
:define-instruction-format
305 (load/store-register
32
306 ;; FIXME: cond should come between LDR/STR and B.
307 :default-printer
'(:name cond
:tab rd
", [" rn load
/store-offset
))
308 (cond :field
(byte 4 28) :type
'condition-code
)
309 (opcode-3 :field
(byte 3 25))
310 (load/store-offset
:fields
(list (byte 1 24)
313 (byte 5 7) ;; shift_imm
316 :type
'load
/store-register
)
317 (opcode-b :field
(byte 1 22))
318 (opcode-l :field
(byte 1 20))
319 (opcode-0 :field
(byte 1 4))
320 (rn :field
(byte 4 16) :type
'reg
)
321 (rd :field
(byte 4 12) :type
'reg
))
323 (sb!disassem
:define-instruction-format
324 (swi 32 :default-printer
'(:name cond
:tab
"#" swi-number
))
325 (cond :field
(byte 4 28) :type
'condition-code
)
326 (opcode-4 :field
(byte 4 24))
327 (swi-number :field
(byte 24 0)))
329 (sb!disassem
:define-instruction-format
330 (debug-trap 32 :default-printer
'(:name
:tab code
))
331 (opcode-32 :field
(byte 32 0))
332 (code :type
'debug-trap-code
:reader debug-trap-code
))
334 (sb!disassem
:define-instruction-format
336 :default-printer
'(:name cond
:tab field-mask
", #" immediate
))
337 (cond :field
(byte 4 28) :type
'condition-code
)
338 (opcode-5 :field
(byte 5 23) :value
#b00110
)
339 (field-mask :fields
(list (byte 1 22) (byte 4 16)) :type
'msr-field-mask
)
340 (opcode-2 :field
(byte 2 20) :value
#b10
)
341 (sbo :field
(byte 4 12) :value
#b1111
)
342 (immediate :field
(byte 12 0) :type
'shifter-immediate
))
344 (sb!disassem
:define-instruction-format
346 :default-printer
'(:name cond
:tab field-mask
", " rm
))
347 (cond :field
(byte 4 28) :type
'condition-code
)
348 (opcode-5 :field
(byte 5 23) :value
#b00010
)
349 (field-mask :fields
(list (byte 1 22) (byte 4 16)) :type
'msr-field-mask
)
350 (opcode-2 :field
(byte 2 20) :value
#b10
)
351 (sbo :field
(byte 4 12) :value
#b1111
)
352 (sbz :field
(byte 8 4) :value
#b00000000
)
353 (rm :field
(byte 4 0) :type
'reg
))
355 (sb!disassem
:define-instruction-format
357 :default-printer
'(:name cond
:tab rd
", " rs
", " rm
))
358 (cond :field
(byte 4 28) :type
'condition-code
)
359 (opcode-8 :field
(byte 8 20))
360 (rd :field
(byte 4 16) :type
'reg
)
361 (sbz :field
(byte 4 12) :value
0)
362 (rs :field
(byte 4 8) :type
'reg
)
363 (opcode-4 :field
(byte 4 4))
364 (rm :field
(byte 4 0) :type
'reg
))
366 (sb!disassem
:define-instruction-format
368 :default-printer
'(:name cond
:tab rd
", " rs
", " rm
", " num
))
369 (cond :field
(byte 4 28) :type
'condition-code
)
370 (opcode-8 :field
(byte 8 20))
371 (rd :field
(byte 4 16) :type
'reg
)
372 (num :field
(byte 4 12) :type
'reg
)
373 (rs :field
(byte 4 8) :type
'reg
)
374 (opcode-4 :field
(byte 4 4))
375 (rm :field
(byte 4 0) :type
'reg
))
377 (sb!disassem
:define-instruction-format
379 :default-printer
'(:name cond
:tab rdlo
", " rdhi
", " rs
", " rm
))
380 (cond :field
(byte 4 28) :type
'condition-code
)
381 (opcode-8 :field
(byte 8 20))
382 (rdhi :field
(byte 4 16) :type
'reg
)
383 (rdlo :field
(byte 4 12) :type
'reg
)
384 (rs :field
(byte 4 8) :type
'reg
)
385 (opcode-4 :field
(byte 4 4))
386 (rm :field
(byte 4 0) :type
'reg
))
388 (sb!disassem
:define-instruction-format
390 :default-printer
'(:name cond
:tab rm
))
391 (cond :field
(byte 4 28) :type
'condition-code
)
392 (opcode-8 :field
(byte 8 20))
393 (sbo :field
(byte 12 8) :value
#xFFF
)
394 (opcode-4 :field
(byte 4 4))
395 (rm :field
(byte 4 0) :type
'reg
))
397 (sb!disassem
:define-instruction-format
399 :default-printer
'(:name cond
:tab fd
", " fn
", " fm
))
400 (cond :field
(byte 4 28) :type
'condition-code
)
401 (opc-1 :field
(byte 4 24) :value
#b1110
)
402 (p :field
(byte 1 23))
403 (q :field
(byte 1 21))
404 (r :field
(byte 1 20))
405 (s :field
(byte 1 6))
406 (fn :fields
(list (byte 1 8) (byte 4 16) (byte 1 7)) :type
'float-reg
)
407 (fd :fields
(list (byte 1 8) (byte 4 12) (byte 1 22)) :type
'float-reg
)
408 (fm :fields
(list (byte 1 8) (byte 4 0) (byte 1 5)) :type
'float-reg
)
409 (opc-2 :field
(byte 3 9) :value
#b101
)
410 (size :field
(byte 1 8))
411 (opc-3 :field
(byte 1 4) :value
0))
413 (sb!disassem
:define-instruction-format
415 :default-printer
'(:name cond
:tab fd
", " fm
))
416 (cond :field
(byte 4 28) :type
'condition-code
)
417 (opc-1 :field
(byte 5 23) :value
#b11101
)
418 (opc-2 :field
(byte 2 20) :value
#b11
)
419 (opc :field
(byte 4 16))
420 (fd :fields
(list (byte 1 8) (byte 4 12) (byte 1 22)) :type
'float-reg
)
421 (fm :fields
(list (byte 1 8) (byte 4 0) (byte 1 5)) :type
'float-reg
)
422 (opc-3 :field
(byte 3 9) :value
#b101
)
423 (size :field
(byte 1 8))
424 (n :field
(byte 1 7))
425 (s :field
(byte 1 6) :value
1)
426 (opc-4 :field
(byte 1 4) :value
0))
428 (sb!disassem
:define-instruction-format
430 :default-printer
'(:name cond
:tab fd
))
431 (cond :field
(byte 4 28) :type
'condition-code
)
432 (opc-1 :field
(byte 5 23) :value
#b11101
)
433 (opc-2 :field
(byte 2 20) :value
#b11
)
434 (opc :field
(byte 4 16))
435 (fd :fields
(list (byte 1 8) (byte 4 12) (byte 1 22)) :type
'float-reg
)
437 (fm :fields
(list (byte 1 8) (byte 4 0) (byte 1 5)) :type
'float-reg
)
438 (opc-3 :field
(byte 3 9) :value
#b101
)
439 (size :field
(byte 1 8))
440 (n :field
(byte 1 7))
441 (s :field
(byte 1 6) :value
1)
442 (sbz :field
(byte 6 0) :value
0))
444 (sb!disassem
:define-instruction-format
446 (cond :field
(byte 4 28) :type
'condition-code
)
447 (opc-1 :field
(byte 4 24) :value
#b1110
)
448 (opc :field
(byte 3 21))
449 (l :field
(byte 1 20))
450 (fn :fields
(list (byte 1 8) (byte 1 7) (byte 4 16)) :type
'float-reg
)
451 (rd :field
(byte 4 12) :type
'reg
)
452 (opc-3 :field
(byte 3 9) :value
#b101
)
453 (size :field
(byte 1 8))
454 (opc-4 :field
(byte 7 0) :value
#b0010000
))
456 (sb!disassem
:define-instruction-format
458 (cond :field
(byte 4 28) :type
'condition-code
)
459 (opc-1 :field
(byte 4 24) :value
#b1110
)
460 (opc :field
(byte 3 21))
461 (l :field
(byte 1 20))
462 (fn :field
(byte 4 16) :type
'float-sys-reg
)
463 (rd :field
(byte 4 12) :type
'reg
)
464 (opc-3 :field
(byte 3 9) :value
#b101
)
465 (opc-4 :field
(byte 8 0) :value
#b00010000
))
467 (sb!disassem
:define-instruction-format
469 (cond :field
(byte 4 28) :type
'condition-code
)
470 (opc-1 :field
(byte 7 21) :value
#b1100010
)
471 (l :field
(byte 1 20))
472 (rn :field
(byte 4 16) :type
'reg
)
473 (rd :field
(byte 4 12) :type
'reg
)
474 (opc-2 :field
(byte 3 9) :value
#b101
)
475 (size :field
(byte 1 8))
476 (opc-3 :field
(byte 2 6) :value
0)
477 (fm :fields
(list (byte 1 8) (byte 4 0) (byte 1 5)) :type
'float-reg
)
478 (opc-4 :field
(byte 1 4) :value
1))
480 (sb!disassem
:define-instruction-format
482 :default-printer
'(:name cond
))
483 (cond :field
(byte 4 28) :type
'condition-code
)
484 (op :field
(byte 28 0)))
486 ;;;; special magic to support decoding internal-error and related traps
488 ;; snarf-error-junk is basically identical on all platforms that
489 ;; define it (meaning, not Alpha). Shouldn't it be common somewhere?
490 (defun snarf-error-junk (sap offset
&optional length-only
)
491 (let* ((length (sb!sys
:sap-ref-8 sap offset
))
492 (vector (make-array length
:element-type
'(unsigned-byte 8))))
493 (declare (type sb
!sys
:system-area-pointer sap
)
494 (type (unsigned-byte 8) length
)
495 (type (simple-array (unsigned-byte 8) (*)) vector
))
497 (values 0 (1+ length
) nil nil
))
499 (sb!kernel
:copy-ub8-from-system-area sap
(1+ offset
)
501 (collect ((sc-offsets)
503 (lengths 1) ; the length byte
505 (error-number (sb!c
:read-var-integer vector index
)))
508 (when (>= index length
)
510 (let ((old-index index
))
511 (sc-offsets (sb!c
:read-var-integer vector index
))
512 (lengths (- index old-index
))))
518 (defun debug-trap-control (chunk inst stream dstate
)
519 (declare (ignore inst
))
520 (flet ((nt (x) (if stream
(sb!disassem
:note x dstate
))))
521 (case (debug-trap-code chunk dstate
)
524 (#.pending-interrupt-trap
525 (nt "Pending interrupt trap"))
528 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
531 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
533 (nt "Breakpoint trap"))
534 (#.fun-end-breakpoint-trap
535 (nt "Function end breakpoint trap"))
536 (#.single-step-around-trap
537 (nt "Single step around trap"))
538 (#.single-step-before-trap
539 (nt "Single step before trap")))))
541 ;;;; primitive emitters
543 ;(define-bitfield-emitter emit-word 16
546 (define-bitfield-emitter emit-word
32
551 (defun emit-absolute-fixup (segment fixup
)
552 (note-fixup segment
:absolute fixup
)
553 (let ((offset (fixup-offset fixup
)))
555 (emit-back-patch segment
556 4 ; FIXME: n-word-bytes
557 (lambda (segment posn
)
558 (declare (ignore posn
))
560 (- (+ (component-header-length)
561 (or (label-position offset
)
563 other-pointer-lowtag
))))
564 (emit-dword segment
(or offset
0)))))
566 (defun emit-relative-fixup (segment fixup
)
567 (note-fixup segment
:relative fixup
)
568 (emit-dword segment
(or (fixup-offset fixup
) 0)))
571 ;;;; miscellaneous hackery
573 (defun register-p (thing)
575 (eq (sb-name (sc-sb (tn-sc thing
))) 'registers
)))
577 (defmacro with-condition-defaulted
((argvar arglist
) &body body
)
578 (let ((internal-emitter (gensym)))
579 `(flet ((,internal-emitter
,arglist
581 (if (assoc (car ,argvar
) *conditions
*)
582 (apply #',internal-emitter
,argvar
)
583 (apply #',internal-emitter
:al
,argvar
)))))
585 (define-instruction byte
(segment byte
)
587 (emit-byte segment byte
)))
589 ;(define-instruction word (segment word)
591 ; (emit-word segment word)))
593 (define-instruction word
(segment word
)
597 (note-fixup segment
:absolute word
)
598 (emit-word segment
0))
600 (emit-word segment word
)))))
602 (defun emit-header-data (segment type
)
603 (emit-back-patch segment
605 (lambda (segment posn
)
609 (component-header-length))
613 (define-instruction simple-fun-header-word
(segment)
615 (emit-header-data segment simple-fun-header-widetag
)))
617 (define-instruction lra-header-word
(segment)
619 (emit-header-data segment return-pc-header-widetag
)))
621 ;;;; Addressing mode 1 support
623 ;;; Addressing mode 1 has some 11 formats. These are immediate,
624 ;;; register, and nine shift/rotate functions based on one or more
625 ;;; registers. As the mnemonics used for these functions are not
626 ;;; currently used, we simply define them as constructors for a
627 ;;; shifter-operand structure, similar to the make-ea function in the
630 (defstruct shifter-operand
635 (defun lsl (register operand
)
636 (aver (register-p register
))
637 (aver (or (register-p operand
)
638 (typep operand
'(integer 0 31))))
640 (make-shifter-operand :register register
:function-code
0 :operand operand
))
642 (defun lsr (register operand
)
643 (aver (register-p register
))
644 (aver (or (register-p operand
)
645 (typep operand
'(integer 1 32))))
647 (make-shifter-operand :register register
:function-code
1 :operand operand
))
649 (defun asr (register operand
)
650 (aver (register-p register
))
651 (aver (or (register-p operand
)
652 (typep operand
'(integer 1 32))))
654 (make-shifter-operand :register register
:function-code
2 :operand operand
))
656 (defun ror (register operand
)
657 ;; ROR is a special case: the encoding for ROR with an immediate
658 ;; shift of 32 (0) is actually RRX.
659 (aver (register-p register
))
660 (aver (or (register-p operand
)
661 (typep operand
'(integer 1 31))))
663 (make-shifter-operand :register register
:function-code
3 :operand operand
))
665 (defun rrx (register)
666 ;; RRX is a special case: it is encoded as ROR with an immediate
667 ;; shift of 32 (0), and has no operand.
668 (aver (register-p register
))
669 (make-shifter-operand :register register
:function-code
3 :operand
0))
671 (define-condition cannot-encode-immediate-operand
(error)
672 ((value :initarg
:value
)))
674 (defun encodable-immediate (operand)
675 ;; 32-bit immediate data is encoded as an 8-bit immediate data value
676 ;; and a 4-bit immediate shift count. The actual value is the
677 ;; immediate data rotated right by a number of bits equal to twice
678 ;; the shift count. Note that this means that there are a limited
679 ;; number of valid immediate integers and that some integers have
680 ;; multiple possible encodings. In the case of multiple encodings,
681 ;; the correct one to use is the one with the lowest shift count.
683 ;; XXX: Is it possible to determine the correct encoding in constant
684 ;; time, rather than time proportional to the final shift count? Is
685 ;; it possible to determine if a given integer is valid without
686 ;; attempting to encode it? Are such solutions cheaper (either time
687 ;; or spacewise) than simply attempting to encode it?
688 (labels ((try-immediate-encoding (value shift
)
689 (unless (<= 0 shift
15)
690 (return-from encodable-immediate
))
691 (if (typep value
'(unsigned-byte 8))
692 (dpb shift
(byte 4 8) value
)
693 (try-immediate-encoding (dpb value
(byte 30 2)
694 (ldb (byte 2 30) value
))
696 (try-immediate-encoding operand
0)))
698 (defun encode-shifter-immediate (operand)
700 (encodable-immediate operand
)
701 (error 'cannot-encode-immediate-operand
:value operand
)))
703 (defun encode-shifter-operand (operand)
706 (dpb 1 (byte 1 25) (encode-shifter-immediate operand
)))
710 ((eq 'registers
(sb-name (sc-sb (tn-sc operand
))))
711 ;; For those wondering, this is LSL immediate for 0 bits.
714 ((eq 'null
(sc-name (tn-sc operand
)))
717 (t (error "Don't know how to encode TN ~A as a SHIFTER-OPERAND" operand
))))
720 (let ((Rm (tn-offset (shifter-operand-register operand
)))
721 (shift-code (shifter-operand-function-code operand
))
722 (shift-amount (shifter-operand-operand operand
)))
723 (etypecase shift-amount
725 (dpb shift-amount
(byte 5 7)
726 (dpb shift-code
(byte 2 5)
729 (dpb (tn-offset shift-amount
) (byte 4 8)
730 (dpb shift-code
(byte 2 5)
734 (defmacro composite-immediate-instruction
(op r x y
&key fixnumize neg-op invert-y invert-r single-op-op first-op first-no-source
)
735 ;; Successively applies 8-bit wide chunks of Y to X using OP storing the result in R.
737 ;; If FIXNUMIZE is true, Y is fixnumized before being used.
738 ;; If NEG-OP is given and Y is negative, NEG-OP is used instead of OP.
739 ;; If INVERT-Y is given LOGNOT is applied to Y before it being used (but after possibly
741 ;; If INVERT-R is given R is bit wise inverted at the end.
742 ;; If SINGLE-OP-OP is given and (possibly fixnumized) Y fits into a single ARM immediate
743 ;; it is used for a single operation instead of OP.
744 ;; If FIRST-OP is given, it is used in the first iteration instead of OP.
745 ;; If FIRST-NO-SOURCE is given, there will be ne source register (X) in the first iteration.
746 (let ((bytespec (gensym "bytespec"))
747 (value (gensym "value"))
748 (transformed (gensym "transformed")))
749 (labels ((instruction (source-reg op neg-op
&optional no-source
)
752 (inst ,neg-op
,r
,@(when (not no-source
)`(,source-reg
))
753 (mask-field ,bytespec
,value
))
754 (inst ,op
,r
,@(when (not no-source
) `(,source-reg
))
755 (mask-field ,bytespec
,value
))))
756 `((inst ,op
,r
,@(when (not no-source
) `(,source-reg
))
757 (mask-field ,bytespec
,value
))))
758 (setf (ldb ,bytespec
,value
) 0)))
760 `((let ((,bytespec
(byte 8 (logandc1 1 (lowest-set-bit-index ,value
)))))
761 ,@(instruction x
(or first-op op
) neg-op first-no-source
))
762 (do ((,bytespec
(byte 8 (logandc1 1 (lowest-set-bit-index ,value
)))
763 (byte 8 (logandc1 1 (lowest-set-bit-index ,value
)))))
765 ,@(instruction r op neg-op
)
767 `((inst mvn
,r
,r
)))))))
768 `(let* ((,transformed
,(if fixnumize
771 (,value
(ldb (byte 32 0)
773 `((if (< ,transformed
0) (- ,transformed
) ,transformed
))
775 `((lognot ,transformed
))
780 (inst ,single-op-op
,r
,x
,transformed
))
781 (cannot-encode-immediate-operand ()
786 ;;;; Addressing mode 2 support
788 ;;; Addressing mode 2 ostensibly has 9 formats. These are formed from
789 ;;; a cross product of three address calculations and three base
790 ;;; register writeback modes. As one of the address calculations is a
791 ;;; scaled register calculation identical to the mode 1 register shift
792 ;;; by constant, we reuse the shifter-operand structure and its public
795 (defstruct memory-operand
801 ;;; The @ macro is used to encode a memory addressing mode. The
802 ;;; parameters for the base form are a base register, an optional
803 ;;; offset (either an integer, a register tn or a shifter-operand
804 ;;; structure with a constant shift amount, optionally within a unary
805 ;;; - form), and a base register writeback mode (either :offset,
806 ;;; :pre-index, or :post-index). The alternative form uses a label as
807 ;;; the base register, and accepts only (optionally negated) integers
808 ;;; as offsets, and requires a mode of :offset.
809 (defun %
@ (base offset direction mode
)
811 (aver (eq mode
:offset
))
812 (aver (integerp offset
)))
814 (when (shifter-operand-p offset
)
815 (aver (integerp (shifter-operand-operand offset
))))
817 ;; Fix up direction with negative offsets.
818 (when (and (not (label-p base
))
821 (setf offset
(- offset
))
822 (setf direction
(if (eq direction
:up
) :down
:up
)))
824 (make-memory-operand :base base
:offset offset
825 :direction direction
:mode mode
))
827 (defmacro @ (base &optional
(offset 0) (mode :offset
))
828 (let* ((direction (if (and (consp offset
)
830 (null (cddr offset
)))
833 (offset (if (eq direction
:down
) (cadr offset
) offset
)))
834 `(%
@ ,base
,offset
,direction
,mode
)))
836 ;;;; Data-processing instructions
838 ;;; Data processing instructions have a 4-bit opcode field and a 1-bit
839 ;;; "S" field for updating condition bits. They are adjacent, so we
840 ;;; roll them into one 5-bit field for convenience.
842 (define-bitfield-emitter emit-dp-instruction
32
843 (byte 4 28) (byte 2 26) (byte 1 25) (byte 5 20)
844 (byte 4 16) (byte 4 12) (byte 12 0))
846 ;;; There are 16 data processing instructions, with a breakdown as
849 ;;; 1.) Two "move" instructions, with no "source" operand (they have
850 ;;; destination and shifter operands only).
852 ;;; 2.) Four "test" instructions, with no "destination" operand.
853 ;;; These instructions always have their "S" bit set, though it
854 ;;; is not specified in their mnemonics.
856 ;;; 3.) Ten "normal" instructions, with all three operands.
858 ;;; Aside from this, the instructions all have a regular encoding, so
859 ;;; we can use a single macro to define them.
861 (defmacro define-data-processing-instruction
(instruction opcode dest-p src-p
)
862 `(define-instruction ,instruction
(segment &rest args
)
863 (:printer dp-shift-immediate
((opcode-8 ,opcode
)
864 ,@(unless dest-p
'((rd 0)))
865 ,@(unless src-p
'((rn 0))))
868 '('(:name cond
:tab rn
", " rm shift
)))
870 '('(:name cond
:tab rd
", " rm shift
)))))
871 (:printer dp-shift-register
((opcode-8 ,opcode
)
872 ,@(unless dest-p
'((rd 0)))
873 ,@(unless src-p
'((rn 0))))
876 '('(:name cond
:tab rn
", " rm
", " shift-type
" " rs
)))
878 '('(:name cond
:tab rd
", " rm
", " shift-type
" " rs
)))))
879 (:printer dp-immediate
((opcode-8 ,(logior opcode
#x20
))
880 ,@(unless dest-p
'((rd 0)))
881 ,@(unless src-p
'((rn 0))))
884 '('(:name cond
:tab rn
", " immediate
)))
886 '('(:name cond
:tab rd
", " immediate
)))))
888 (with-condition-defaulted (args (condition ,@(if dest-p
'(dest))
891 ,(if dest-p
'(aver (register-p dest
)))
892 ,(if src-p
'(aver (register-p src
)))
893 (let ((shifter-operand (encode-shifter-operand shifter-operand
)))
894 (emit-dp-instruction segment
895 (conditional-opcode condition
)
897 (ldb (byte 1 25) shifter-operand
)
899 ,(if src-p
'(tn-offset src
) 0)
900 ,(if dest-p
'(tn-offset dest
) 0)
901 (ldb (byte 12 0) shifter-operand
)))))))
903 (define-data-processing-instruction and
#x00 t t
)
904 (define-data-processing-instruction ands
#x01 t t
)
905 (define-data-processing-instruction eor
#x02 t t
)
906 (define-data-processing-instruction eors
#x03 t t
)
907 (define-data-processing-instruction sub
#x04 t t
)
908 (define-data-processing-instruction subs
#x05 t t
)
909 (define-data-processing-instruction rsb
#x06 t t
)
910 (define-data-processing-instruction rsbs
#x07 t t
)
911 (define-data-processing-instruction add
#x08 t t
)
912 (define-data-processing-instruction adds
#x09 t t
)
913 (define-data-processing-instruction adc
#x0a t t
)
914 (define-data-processing-instruction adcs
#x0b t t
)
915 (define-data-processing-instruction sbc
#x0c t t
)
916 (define-data-processing-instruction sbcs
#x0d t t
)
917 (define-data-processing-instruction rsc
#x0e t t
)
918 (define-data-processing-instruction rscs
#x0f t t
)
919 (define-data-processing-instruction orr
#x18 t t
)
920 (define-data-processing-instruction orrs
#x19 t t
)
921 (define-data-processing-instruction bic
#x1c t t
)
922 (define-data-processing-instruction bics
#x1d t t
)
924 (define-data-processing-instruction tst
#x11 nil t
)
925 (define-data-processing-instruction teq
#x13 nil t
)
926 (define-data-processing-instruction cmp
#x15 nil t
)
927 (define-data-processing-instruction cmn
#x17 nil t
)
929 (define-data-processing-instruction mov
#x1a t nil
)
930 (define-data-processing-instruction movs
#x1b t nil
)
931 (define-data-processing-instruction mvn
#x1e t nil
)
932 (define-data-processing-instruction mvns
#x1f t nil
)
934 ;;;; Exception-generating instructions
936 ;;; There are two exception-generating instructions. One, BKPT, is
937 ;;; ostensibly used as a breakpoint instruction, and to communicate
938 ;;; with debugging hardware. The other, SWI, is intended for use as a
939 ;;; system call interface. We need both because, at least on some
940 ;;; platforms, the only breakpoint trap that works properly is a
943 (define-bitfield-emitter emit-swi-instruction
32
944 (byte 4 28) (byte 4 24) (byte 24 0))
946 (define-instruction swi
(segment &rest args
)
947 (:printer swi
((opcode-4 #b1111
)))
949 (with-condition-defaulted (args (condition code
))
950 (emit-swi-instruction segment
951 (conditional-opcode condition
)
954 (define-bitfield-emitter emit-bkpt-instruction
32
955 (byte 4 28) (byte 8 20) (byte 12 8) (byte 4 4) (byte 4 0))
957 (define-instruction bkpt
(segment code
)
959 (emit-bkpt-instruction segment
#b1110
#b00010010
960 (ldb (byte 12 4) code
)
962 (ldb (byte 4 0) code
))))
964 ;;; It turns out that the Linux kernel decodes this particular
965 ;;; officially undefined instruction as a single-instruction SIGTRAP
966 ;;; generation instruction, or breakpoint.
967 (define-instruction debug-trap
(segment)
968 (:printer debug-trap
((opcode-32 #xe7f001f0
))
969 :default
:control
#'debug-trap-control
)
971 (emit-word segment
#xe7f001f0
)))
973 ;;;; Miscellaneous arithmetic instructions
975 (define-bitfield-emitter emit-clz-instruction
32
976 (byte 4 28) (byte 12 16) (byte 4 12) (byte 8 4) (byte 4 0))
978 (define-instruction clz
(segment &rest args
)
979 (:printer dp-shift-register
((opcode-8 #b00010110
)
983 '(:name cond
:tab rd
", " rm
))
985 (with-condition-defaulted (args (condition dest src
))
986 (aver (register-p dest
))
987 (aver (register-p src
))
988 (emit-clz-instruction segment
(conditional-opcode condition
)
994 ;;;; Branch instructions
996 (define-bitfield-emitter emit-branch-instruction
32
997 (byte 4 28) (byte 4 24) (byte 24 0))
999 (defun emit-branch-back-patch (segment condition opcode dest
)
1000 (emit-back-patch segment
4
1001 (lambda (segment posn
)
1002 (emit-branch-instruction segment
1003 (conditional-opcode condition
)
1006 (- (label-position dest
)
1009 (define-instruction b
(segment &rest args
)
1010 (:printer branch
((opcode-4 #b1010
)))
1012 (with-condition-defaulted (args (condition dest
))
1013 (aver (label-p dest
))
1014 (emit-branch-back-patch segment condition
#b1010 dest
))))
1016 (define-instruction bl
(segment &rest args
)
1017 (:printer branch
((opcode-4 #b1011
)))
1019 (with-condition-defaulted (args (condition dest
))
1020 (aver (label-p dest
))
1021 (emit-branch-back-patch segment condition
#b1011 dest
))))
1023 (define-bitfield-emitter emit-branch-exchange-instruction
32
1024 (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12)
1025 (byte 4 8) (byte 4 4) (byte 4 0))
1027 (define-instruction bx
(segment &rest args
)
1028 (:printer branch-exchange
((opcode-8 #b00010010
)
1031 (with-condition-defaulted (args (condition dest
))
1032 (aver (register-p dest
))
1033 (emit-branch-exchange-instruction segment
1034 (conditional-opcode condition
)
1035 #b00010010
#b1111
#b1111
1036 #b1111
#b0001
(tn-offset dest
)))))
1038 (define-instruction blx
(segment &rest args
)
1039 (:printer branch-exchange
((opcode-8 #b00010010
)
1042 (with-condition-defaulted (args (condition dest
))
1043 (aver (register-p dest
))
1044 (emit-branch-exchange-instruction segment
1045 (conditional-opcode condition
)
1046 #b00010010
#b1111
#b1111
1047 #b1111
#b0011
(tn-offset dest
)))))
1049 ;;;; Semaphore instructions
1051 (defun emit-semaphore-instruction (segment opcode condition dest value address
)
1052 (aver (register-p dest
))
1053 (aver (register-p value
))
1054 (aver (memory-operand-p address
))
1055 (aver (zerop (memory-operand-offset address
)))
1056 (aver (eq :offset
(memory-operand-mode address
)))
1057 (emit-dp-instruction segment
(conditional-opcode condition
)
1058 #b00
0 opcode
(tn-offset (memory-operand-base address
))
1060 (dpb #b1001
(byte 4 4) (tn-offset value
))))
1062 (define-instruction swp
(segment &rest args
)
1064 (with-condition-defaulted (args (condition dest value address
))
1065 (emit-semaphore-instruction segment
#b10000
1066 condition dest value address
))))
1068 (define-instruction swpb
(segment &rest args
)
1070 (with-condition-defaulted (args (condition dest value address
))
1071 (emit-semaphore-instruction segment
#b10100
1072 condition dest value address
))))
1074 ;;;; Status-register instructions
1076 (define-instruction mrs
(segment &rest args
)
1077 (:printer dp-shift-immediate
((opcode-8 #b0010000
)
1081 '(:name cond
:tab rd
", CPSR"))
1082 (:printer dp-shift-immediate
((opcode-8 #b0010100
)
1086 '(:name cond
:tab rd
", SPSR"))
1088 (with-condition-defaulted (args (condition dest reg
))
1089 (aver (register-p dest
))
1090 (aver (member reg
'(:cpsr
:spsr
)))
1091 (emit-dp-instruction segment
(conditional-opcode condition
)
1092 #b00
0 (if (eq reg
:cpsr
) #b10000
#b10100
)
1093 #b1111
(tn-offset dest
) 0))))
1095 (defun encode-status-register-fields (fields)
1096 (let ((fields (string fields
)))
1097 (labels ((frob (mask index
)
1098 (let* ((field (aref fields index
))
1099 (field-mask (cdr (assoc field
1100 '((#\C .
#b0001
) (#\X .
#b0010
)
1101 (#\S .
#b0100
) (#\F .
#b1000
))
1104 (error "bad status register field desginator ~S" fields
))
1105 (if (< (1+ index
) (length fields
))
1106 (frob (logior mask field-mask
) (1+ index
))
1107 (logior mask field-mask
)))))
1110 (defmacro cpsr
(fields)
1111 (encode-status-register-fields fields
))
1113 (defmacro spsr
(fields)
1114 (logior #b10000
(encode-status-register-fields fields
)))
1116 (define-instruction msr
(segment &rest args
)
1117 (:printer msr-immediate
())
1118 (:printer msr-register
())
1120 (with-condition-defaulted (args (condition field-mask src
))
1121 (aver (or (register-p src
)
1123 (let ((encoded-src (encode-shifter-operand src
)))
1124 (emit-dp-instruction segment
(conditional-opcode condition
)
1125 #b00
(ldb (byte 1 25) encoded-src
)
1126 (if (logbitp 4 field-mask
) #b10110
#b10010
)
1128 (ldb (byte 12 0) encoded-src
))))))
1130 ;;;; Multiply instructions
1132 (define-bitfield-emitter emit-multiply-instruction
32
1133 (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12)
1134 (byte 4 8) (byte 4 4) (byte 4 0))
1137 ((define-multiply-instruction (name field-mapping opcode1 opcode2
)
1138 (let ((arglist (ecase field-mapping
1139 (:dzsm
'(dest src multiplicand
))
1140 (:dnsm
'(dest src multiplicand num
))
1141 (:ddsm
'(dest-lo dest src multiplicand
)))))
1142 `(define-instruction ,name
(segment &rest args
)
1143 (:printer
,(symbolicate 'multiply- field-mapping
)
1144 ((opcode-8 ,opcode1
)
1145 (opcode-4 ,opcode2
)))
1147 (with-condition-defaulted (args (condition ,@arglist
))
1150 collect
`(aver (register-p ,arg
)))
1151 (emit-multiply-instruction segment
(conditional-opcode condition
)
1154 ,(ecase field-mapping
1156 (:dnsm
'(tn-offset num
))
1157 (:ddsm
'(tn-offset dest-lo
)))
1160 (tn-offset multiplicand
))))))))
1162 (define-multiply-instruction mul
:dzsm
#b00000000
#b1001
)
1163 (define-multiply-instruction muls
:dzsm
#b00000001
#b1001
)
1164 (define-multiply-instruction mla
:dnsm
#b00000010
#b1001
)
1165 (define-multiply-instruction mlas
:dnsm
#b00000011
#b1001
)
1167 (define-multiply-instruction umull
:ddsm
#b00001000
#b1001
)
1168 (define-multiply-instruction umulls
:ddsm
#b00001001
#b1001
)
1169 (define-multiply-instruction umlal
:ddsm
#b00001010
#b1001
)
1170 (define-multiply-instruction umlals
:ddsm
#b00001011
#b1001
)
1172 (define-multiply-instruction smull
:ddsm
#b00001100
#b1001
)
1173 (define-multiply-instruction smulls
:ddsm
#b00001101
#b1001
)
1174 (define-multiply-instruction smlal
:ddsm
#b00001110
#b1001
)
1175 (define-multiply-instruction smlals
:ddsm
#b00001111
#b1001
)
1177 (define-multiply-instruction smlabb
:dnsm
#b00010000
#b1000
)
1178 (define-multiply-instruction smlatb
:dnsm
#b00010000
#b1010
)
1179 (define-multiply-instruction smlabt
:dnsm
#b00010000
#b1100
)
1180 (define-multiply-instruction smlatt
:dnsm
#b00010000
#b1110
)
1182 (define-multiply-instruction smlalbb
:ddsm
#b00010100
#b1000
)
1183 (define-multiply-instruction smlaltb
:ddsm
#b00010100
#b1010
)
1184 (define-multiply-instruction smlalbt
:ddsm
#b00010100
#b1100
)
1185 (define-multiply-instruction smlaltt
:ddsm
#b00010100
#b1110
)
1187 (define-multiply-instruction smulbb
:dzsm
#b00010110
#b1000
)
1188 (define-multiply-instruction smultb
:dzsm
#b00010110
#b1010
)
1189 (define-multiply-instruction smulbt
:dzsm
#b00010110
#b1100
)
1190 (define-multiply-instruction smultt
:dzsm
#b00010110
#b1110
)
1192 (define-multiply-instruction smlawb
:dnsm
#b00010010
#b1000
)
1193 (define-multiply-instruction smlawt
:dnsm
#b00010010
#b1100
)
1195 (define-multiply-instruction smulwb
:dzsm
#b00010010
#b1010
)
1196 (define-multiply-instruction smulwt
:dzsm
#b00010010
#b1110
))
1198 ;;;; Load/store instructions
1200 ;;; Emit a load/store instruction. CONDITION is a condition code
1201 ;;; name, KIND is :load or :store, WIDTH is :word or :byte, DATA is a
1202 ;;; register TN and ADDRESS is either a memory-operand structure or a
1204 (defun emit-load/store-instruction
(segment condition kind width data address
)
1205 (flet ((compute-opcode (direction mode
)
1206 (let ((opcode-bits '(:load
#b00001
:store
#b00000
1207 :word
#b00000
:byte
#b00100
1208 :up
#b01000
:down
#b00000
1211 :post-index
#b00000
)))
1212 (reduce #'logior
(list kind width direction mode
)
1213 :key
(lambda (value) (getf opcode-bits value
))))))
1216 (let* ((base (memory-operand-base address
))
1217 (offset (memory-operand-offset address
))
1218 (direction (memory-operand-direction address
))
1219 (mode (memory-operand-mode address
))
1220 (cond-bits (conditional-opcode condition
)))
1225 (lambda (segment posn
)
1226 (let* ((label-delta (- (label-position base
)
1228 (offset-delta (if (eq direction
:up
)
1231 (overall-delta (+ label-delta
1233 (absolute-delta (abs overall-delta
)))
1234 (aver (typep absolute-delta
'(unsigned-byte 12)))
1235 (emit-dp-instruction segment cond-bits
#b01
0
1236 (compute-opcode (if (< overall-delta
0)
1240 pc-offset
(tn-offset data
)
1243 (aver (typep offset
'(unsigned-byte 12)))
1244 (emit-dp-instruction segment cond-bits
#b01
0
1245 (compute-opcode direction mode
)
1246 (tn-offset base
) (tn-offset data
)
1249 (emit-dp-instruction segment cond-bits
#b01
1
1250 (compute-opcode direction mode
)
1251 (tn-offset base
) (tn-offset data
)
1252 (encode-shifter-operand offset
))))))
1256 ;; FIXME: This is for stack TN references, and needs must be
1261 ((define-load/store-instruction
(name kind width
)
1262 `(define-instruction ,name
(segment &rest args
)
1263 (:printer load
/store-immediate
((opcode-3 #b010
)
1264 (opcode-b ,(ecase width
1267 (opcode-l ,(ecase kind
1270 (:printer load
/store-register
((opcode-3 #b011
)
1272 (opcode-b ,(ecase width
1275 (opcode-l ,(ecase kind
1279 (with-condition-defaulted (args (condition reg address
))
1280 (aver (or (register-p reg
)
1281 ,@(when (eq :store kind
)
1283 (eq 'null
(sc-name (tn-sc reg
))))))))
1284 (emit-load/store-instruction segment condition
1286 (if (register-p reg
) reg null-tn
)
1288 (define-load/store-instruction ldr
:load
:word
)
1289 (define-load/store-instruction ldrb
:load
:byte
)
1290 (define-load/store-instruction str
:store
:word
)
1291 (define-load/store-instruction strb
:store
:byte
))
1293 ;;; Emit a miscellaneous load/store instruction. CONDITION is a
1294 ;;; condition code name, OPCODE1 is the low bit of the first opcode
1295 ;;; field, OPCODE2 is the second opcode field, DATA is a register TN
1296 ;;; and ADDRESS is either a memory-operand structure or a stack TN.
1297 (defun emit-misc-load/store-instruction
(segment condition opcode1
1298 opcode2 data address
)
1299 (flet ((compute-opcode (kind direction mode
)
1300 (let ((opcode-bits '(:register
#b00000
:immediate
#b00100
1301 :up
#b01000
:down
#b00000
1304 :post-index
#b00000
)))
1305 (reduce #'logior
(list kind direction mode
)
1306 :key
(lambda (value) (getf opcode-bits value
))))))
1309 (let* ((base (memory-operand-base address
))
1310 (offset (memory-operand-offset address
))
1311 (direction (memory-operand-direction address
))
1312 (mode (memory-operand-mode address
))
1313 (cond-bits (conditional-opcode condition
)))
1318 (lambda (segment posn
)
1319 (let* ((label-delta (- (label-position base
)
1321 (offset-delta (if (eq direction
:up
)
1324 (overall-delta (+ label-delta
1326 (absolute-delta (abs overall-delta
)))
1327 (aver (typep absolute-delta
'(unsigned-byte 8)))
1328 (emit-multiply-instruction segment cond-bits
1330 (compute-opcode :immedaite
1331 (if (< overall-delta
0)
1335 (tn-offset base
) (tn-offset data
)
1336 (ldb (byte 4 4) absolute-delta
)
1337 opcode2 absolute-delta
)))))
1339 (aver (typep offset
'(unsigned-byte 8)))
1340 (emit-multiply-instruction segment cond-bits
1342 (compute-opcode :immediate direction mode
))
1343 (tn-offset base
) (tn-offset data
)
1344 (ldb (byte 4 4) offset
)
1346 ((register-p offset
)
1347 (emit-multiply-instruction segment cond-bits
1349 (compute-opcode :register direction mode
))
1350 (tn-offset base
) (tn-offset data
)
1351 0 opcode2
(tn-offset offset
)))
1353 (error "bad thing for a miscellaneous load/store address ~S"
1358 ;; FIXME: This is for stack TN references, and needs must be
1363 ((define-misc-load/store-instruction
(name opcode1 opcode2 double-width
)
1364 `(define-instruction ,name
(segment &rest args
)
1366 (with-condition-defaulted (args (condition reg address
))
1367 (aver (register-p reg
))
1368 ,(when double-width
'(aver (evenp (tn-offset reg
))))
1369 (emit-misc-load/store-instruction segment condition
1372 (define-misc-load/store-instruction strh
0 #b1011 nil
)
1373 (define-misc-load/store-instruction ldrd
0 #b1101 t
)
1374 (define-misc-load/store-instruction strd
0 #b1111 t
)
1376 (define-misc-load/store-instruction ldrh
1 #b1011 nil
)
1377 (define-misc-load/store-instruction ldrsb
1 #b1101 nil
)
1378 (define-misc-load/store-instruction ldrsh
1 #b1111 nil
))
1380 ;;;; Boxed-object computation instructions (for LRA and CODE)
1382 ;;; Compute the address of a CODE object by parsing the header of a
1383 ;;; nearby LRA or SIMPLE-FUN.
1384 (define-instruction compute-code
(segment code lip object-label temp
)
1389 (lambda (segment position
)
1390 (assemble (segment vop
)
1391 ;; Calculate the address of the code component. This is an
1392 ;; exercise in excess cleverness. First, we calculate (from
1393 ;; our program counter only) the address of OBJECT-LABEL plus
1394 ;; OTHER-POINTER-LOWTAG. The extra two words are to
1395 ;; compensate for the offset applied by ARM CPUs when reading
1396 ;; the program counter.
1397 (inst sub lip pc-tn
(- ;; The 8 below is the displacement
1398 ;; from reading the program counter.
1400 (+ (label-position object-label
)
1401 other-pointer-lowtag
)))
1402 ;; Next, we read the function header.
1403 (inst ldr temp
(@ lip
(- other-pointer-lowtag
)))
1404 ;; And finally we use the header value (a count in words),
1405 ;; plus the fact that the top two bits of the widetag are
1406 ;; clear (SIMPLE-FUN-HEADER-WIDETAG is #x2A and
1407 ;; RETURN-PC-HEADER-WIDETAG is #x36) to compute the boxed
1408 ;; address of the code component.
1409 (inst sub code lip
(lsr temp
(- 8 word-shift
))))))))
1411 ;;; Compute the address of a nearby LRA object by dead reckoning from
1412 ;;; the location of the current instruction.
1413 (define-instruction compute-lra
(segment dest lip lra-label
)
1416 ;; We can compute the LRA in a single instruction if the overall
1417 ;; offset puts it to within an 8-bit displacement. Otherwise, we
1418 ;; need to load it by parts into LIP until we're down to an 8-bit
1419 ;; displacement, and load the final 8 bits into DEST. We may
1420 ;; safely presume that an overall displacement may be up to 24 bits
1421 ;; wide (the PPC backend has special provision for branches over 15
1422 ;; bits, which implies that segments can become large, but a 16
1423 ;; megabyte segment (24 bits of displacement) is ridiculous), so we
1424 ;; need to cover a range of up to three octets of displacement.
1425 (labels ((compute-delta (position &optional magic-value
)
1426 (- (+ (label-position lra-label
1427 (when magic-value position
)
1429 other-pointer-lowtag
)
1430 ;; The 8 below is the displacement
1431 ;; from reading the program counter.
1434 (load-chunk (segment delta dst src chunk
)
1435 (assemble (segment vop
)
1437 (inst sub dst src chunk
)
1438 (inst add dst src chunk
))))
1440 (three-instruction-emitter (segment position
)
1441 (let* ((delta (compute-delta position
))
1442 (absolute-delta (abs delta
)))
1443 (load-chunk segment delta
1444 lip pc-tn
(mask-field (byte 8 16) absolute-delta
))
1445 (load-chunk segment delta
1446 lip lip
(mask-field (byte 8 8) absolute-delta
))
1447 (load-chunk segment delta
1448 dest lip
(mask-field (byte 8 0) absolute-delta
))))
1450 (two-instruction-emitter (segment position
)
1451 (let* ((delta (compute-delta position
))
1452 (absolute-delta (abs delta
)))
1453 (assemble (segment vop
)
1454 (load-chunk segment delta
1455 lip pc-tn
(mask-field (byte 8 8) absolute-delta
))
1456 (load-chunk segment delta
1457 dest lip
(mask-field (byte 8 0) absolute-delta
)))))
1459 (one-instruction-emitter (segment position
)
1460 (let* ((delta (compute-delta position
))
1461 (absolute-delta (abs delta
)))
1462 (assemble (segment vop
)
1463 (load-chunk segment delta
1464 dest pc-tn absolute-delta
))))
1466 (two-instruction-maybe-shrink (segment posn magic-value
)
1467 (let ((delta (compute-delta posn magic-value
)))
1468 (when (<= (integer-length delta
) 8)
1469 (emit-back-patch segment
4
1470 #'one-instruction-emitter
)
1473 (three-instruction-maybe-shrink (segment posn magic-value
)
1474 (let ((delta (compute-delta posn magic-value
)))
1475 (when (<= (integer-length delta
) 16)
1476 (emit-chooser segment
8 2
1477 #'two-instruction-maybe-shrink
1478 #'two-instruction-emitter
)
1481 ;; We need to emit up to three instructions, which is 12 octets.
1482 ;; This preserves a mere two bits of alignment.
1484 #'three-instruction-maybe-shrink
1485 #'three-instruction-emitter
))))
1487 ;;; Load a register from a "nearby" LABEL by dead reckoning from the
1488 ;;; location of the current instruction.
1489 (define-instruction load-from-label
(segment &rest args
)
1492 (with-condition-defaulted (args (condition dest lip label
))
1493 ;; We can load the word addressed by a label in a single
1494 ;; instruction if the overall offset puts it to within a 12-bit
1495 ;; displacement. Otherwise, we need to build an address by parts
1496 ;; into LIP until we're down to a 12-bit displacement, and then
1497 ;; apply the final 12 bits with LDR. For now, we'll allow up to 20
1498 ;; bits of displacement, as that should be easy to implement, and a
1499 ;; megabyte large code object is already a bit unwieldly. If
1500 ;; neccessary, we can expand to a 28 bit displacement.
1501 (labels ((compute-delta (position &optional magic-value
)
1502 (- (label-position label
1503 (when magic-value position
)
1505 ;; The 8 below is the displacement
1506 ;; from reading the program counter.
1509 (load-chunk (segment delta dst src chunk
)
1510 (assemble (segment vop
)
1512 (inst sub condition dst src chunk
)
1513 (inst add condition dst src chunk
))))
1515 (two-instruction-emitter (segment position
)
1516 (let* ((delta (compute-delta position
))
1517 (absolute-delta (abs delta
)))
1518 (assemble (segment vop
)
1519 (load-chunk segment delta
1520 lip pc-tn
(mask-field (byte 8 12) absolute-delta
))
1521 (inst ldr condition dest
(@ lip
(mask-field (byte 12 0) delta
))))))
1523 (one-instruction-emitter (segment position
)
1524 (let* ((delta (compute-delta position
)))
1525 (assemble (segment vop
)
1526 (inst ldr condition dest
(@ pc-tn delta
)))))
1528 (two-instruction-maybe-shrink (segment posn magic-value
)
1529 (let ((delta (compute-delta posn magic-value
)))
1530 (when (<= (integer-length delta
) 12)
1531 (emit-back-patch segment
4
1532 #'one-instruction-emitter
)
1535 ;; We need to emit up to two instructions, which is 8 octets,
1536 ;; but might wish to emit only one. This preserves a mere two
1537 ;; bits of alignment.
1539 #'two-instruction-maybe-shrink
1540 #'two-instruction-emitter
)))))
1542 ;; data processing floating point instructions
1543 (define-bitfield-emitter emit-fp-dp-instruction
32
1545 (byte 4 24) ; #b1110
1550 (byte 4 16) ; Fn || extension op
1553 (byte 1 8) ; double/single precission
1554 (byte 1 7) ; N || extension op
1560 (defun low-bit-float-reg (reg-tn)
1561 (logand 1 (tn-offset reg-tn
)))
1563 (defun high-bits-float-reg (reg-tn)
1564 (ash (tn-offset reg-tn
) -
1))
1566 (defmacro define-binary-fp-data-processing-instruction
(name precision p q r s
)
1567 (let ((precision-flag (ecase precision
1570 `(define-instruction ,name
(segment &rest args
)
1571 (:printer fp-binary
((p ,p
)
1575 (size ,precision-flag
)))
1577 (with-condition-defaulted (args (condition dest op-n op-m
))
1578 (emit-fp-dp-instruction segment
1579 (conditional-opcode condition
)
1582 (low-bit-float-reg dest
)
1585 (high-bits-float-reg op-n
)
1586 (high-bits-float-reg dest
)
1589 (low-bit-float-reg op-n
)
1591 (low-bit-float-reg op-m
)
1593 (high-bits-float-reg op-m
)))))))
1595 (defmacro define-binary-fp-data-processing-instructions
(root p q r s
)
1597 (define-binary-fp-data-processing-instruction ,(symbolicate root
's
) :single
,p
,q
,r
,s
)
1598 (define-binary-fp-data-processing-instruction ,(symbolicate root
'd
) :double
,p
,q
,r
,s
)))
1600 (define-binary-fp-data-processing-instructions fmac
0 0 0 0)
1601 (define-binary-fp-data-processing-instructions fnmac
0 0 0 1)
1602 (define-binary-fp-data-processing-instructions fmsc
0 0 1 0)
1603 (define-binary-fp-data-processing-instructions fnmsc
0 0 1 1)
1604 (define-binary-fp-data-processing-instructions fmul
0 1 0 0)
1605 (define-binary-fp-data-processing-instructions fnmul
0 1 0 1)
1606 (define-binary-fp-data-processing-instructions fadd
0 1 1 0)
1607 (define-binary-fp-data-processing-instructions fsub
0 1 1 1)
1608 (define-binary-fp-data-processing-instructions fdiv
1 0 0 0)
1610 ;;; op-m-sbz means that it should-be-zero, and only one register is supplied.
1611 (defmacro define-unary-fp-data-processing-instruction
(name precision fn n
1613 (let ((precision-flag (ecase precision
1616 `(define-instruction ,name
(segment &rest args
)
1617 (:printer
,(if op-m-sbz
1620 ((size ,precision-flag
)
1624 (with-condition-defaulted (args (condition dest
1627 (emit-fp-dp-instruction segment
1628 (conditional-opcode condition
)
1631 (low-bit-float-reg dest
)
1635 (high-bits-float-reg dest
)
1642 '(low-bit-float-reg op-m
))
1646 '(high-bits-float-reg op-m
))))))))
1648 (defmacro define-unary-fp-data-processing-instructions
(root fn n
&key op-m-sbz
)
1650 (define-unary-fp-data-processing-instruction ,(symbolicate root
's
) :single
,fn
,n
1651 :op-m-sbz
,op-m-sbz
)
1652 (define-unary-fp-data-processing-instruction ,(symbolicate root
'd
) :double
,fn
,n
1653 :op-m-sbz
,op-m-sbz
)))
1655 (define-unary-fp-data-processing-instructions fcpy
#b0000
0)
1656 (define-unary-fp-data-processing-instructions fabs
#b0000
1)
1657 (define-unary-fp-data-processing-instructions fneg
#b0001
0)
1658 (define-unary-fp-data-processing-instructions fsqrt
#b0001
1)
1659 (define-unary-fp-data-processing-instructions fcmp
#b0100
0)
1660 (define-unary-fp-data-processing-instructions fcmpe
#b0100
1)
1661 (define-unary-fp-data-processing-instructions fcmpz
#b0101
0 :op-m-sbz t
)
1662 (define-unary-fp-data-processing-instructions fcmpez
#b0101
1 :op-m-sbz t
)
1663 (define-unary-fp-data-processing-instructions fuito
#b1000
0)
1664 (define-unary-fp-data-processing-instructions fsito
#b1000
1)
1665 (define-unary-fp-data-processing-instructions ftoui
#b1100
0)
1666 (define-unary-fp-data-processing-instructions ftouiz
#b1100
1)
1667 (define-unary-fp-data-processing-instructions ftosi
#b1101
0)
1668 (define-unary-fp-data-processing-instructions ftosiz
#b1101
1)
1670 (define-unary-fp-data-processing-instruction fcvtds
:single
#b0111
1)
1671 (define-unary-fp-data-processing-instruction fcvtsd
:double
#b0111
1)
1673 ;;; Load/Store Float Instructions
1675 (define-bitfield-emitter emit-fp-ls-instruction
32
1686 (byte 1 8) ; double/single precission
1687 (byte 8 0)) ; offset
1689 ;; Define a load/store multiple floating point instruction. PRECISION is
1690 ;; :SINGLE for single precision values and :DOUBLE for double precision values.
1691 ;; DIRECTION has to be either :LOAD or :STORE.
1692 ;; If INC-OFFSET is true, the offset part of the instruction will be incremented by 1
1693 ;; indicating in the double case a load/store unknown instruction.
1694 (defmacro define-load-store-multiple-fp-instruction
(name precision direction
&optional inc-offset
)
1695 (let ((precision-flag (ecase precision
1698 (direction-flag (ecase direction
1701 `(define-instruction ,name
(segment &rest args
)
1703 (with-condition-defaulted (args (condition address base-reg reg-count
))
1709 ((:unindexed
:increment
) 0)
1712 ((:unindexed
:increment
) 1)
1716 ((:increment
:decrement
) 1))))
1717 (emit-fp-ls-instruction segment
1718 (conditional-opcode condition
)
1722 (low-bit-float-reg base-reg
)
1726 (high-bits-float-reg base-reg
)
1730 (:single
'reg-count
)
1731 (:double
`(+ (* 2 reg-count
)
1732 ,(if inc-offset
1 0)))))))))))
1734 ;; multiple single precision
1735 (define-load-store-multiple-fp-instruction fstms
:single
:store
)
1736 (define-load-store-multiple-fp-instruction fldms
:single
:load
)
1737 ;; multiple double precision
1738 (define-load-store-multiple-fp-instruction fstmd
:double
:store
)
1739 (define-load-store-multiple-fp-instruction fldmd
:double
:load
)
1740 ;; multiple double precision registers of unknown content (needs up to 2 * reg-count + 1 words of space)
1741 (define-load-store-multiple-fp-instruction fstmx
:double
:store t
)
1742 (define-load-store-multiple-fp-instruction fldmx
:double
:load t
)
1744 ;; KLUDGE: this group of pseudo-instructions are fragile (no error
1745 ;; handling for the various ways to mis-use them), have no support for
1746 ;; predication, and use the somewhat-broken interface for the
1747 ;; load-store-multiple-fp instructions above.
1748 (define-instruction-macro load-complex-single
(dest memory-operand
)
1749 `(inst fldms
(memory-operand-base ,memory-operand
) ,dest
2))
1750 (define-instruction-macro load-complex-double
(dest memory-operand
)
1751 `(inst fldmd
(memory-operand-base ,memory-operand
) ,dest
2))
1752 (define-instruction-macro store-complex-single
(src memory-operand
)
1753 `(inst fstms
(memory-operand-base ,memory-operand
) ,src
2))
1754 (define-instruction-macro store-complex-double
(src memory-operand
)
1755 `(inst fstmd
(memory-operand-base ,memory-operand
) ,src
2))
1757 ;; Define a load/store one floating point instruction. PRECISION is
1758 ;; :SINGLE for single precision values and :DOUBLE for double precision values.
1759 ;; DIRECTION has to be either :LOAD or :STORE.
1760 (defmacro define-load-store-one-fp-instruction
(name precision direction
)
1761 (let ((precision-flag (ecase precision
1764 (direction-flag (ecase direction
1767 `(define-instruction ,name
(segment &rest args
)
1769 (with-condition-defaulted (args (condition float-reg memory-operand
))
1770 (let ((base (memory-operand-base memory-operand
))
1771 (offset (memory-operand-offset memory-operand
))
1772 (direction (memory-operand-direction memory-operand
)))
1773 (aver (eq (memory-operand-mode memory-operand
) :offset
))
1774 (aver (and (integerp offset
)
1775 (zerop (logand offset
3))))
1776 ;; FIXME: Should support LABEL bases.
1778 (emit-fp-ls-instruction segment
1779 (conditional-opcode condition
)
1782 (if (eq direction
:up
) 1 0)
1783 (low-bit-float-reg float-reg
)
1787 (high-bits-float-reg float-reg
)
1790 (ash offset -
2))))))))
1792 (define-load-store-one-fp-instruction fsts
:single
:store
)
1793 (define-load-store-one-fp-instruction flds
:single
:load
)
1794 (define-load-store-one-fp-instruction fstd
:double
:store
)
1795 (define-load-store-one-fp-instruction fldd
:double
:load
)
1798 ;; single register transfer instructions
1800 (define-bitfield-emitter emit-fp-srt-instruction
32
1802 (byte 4 24) ; #b1110
1809 (byte 1 8) ; precision
1812 (byte 7 0)) ; #b0010000
1814 (define-bitfield-emitter emit-conditional-instruction
32
1818 ;;; This has the same encoding as FMRX R15, FPSCR
1819 (define-instruction fmstat
(segment &rest args
)
1820 (:printer conditional
1823 (with-condition-defaulted (args (condition))
1824 (emit-conditional-instruction segment
1825 (conditional-opcode condition
)
1828 (defun system-reg-encoding (float-reg)
1834 (defmacro define-single-reg-transfer-fp-instruction
(name precision direction opcode
&optional system-reg
)
1835 (let ((precision-flag (ecase precision
1838 (direction-flag (ecase direction
1841 `(define-instruction ,name
(segment &rest args
)
1842 (:printer
,(if system-reg
1847 (size ,precision-flag
))
1848 ',(if (eq direction
:to-arm
)
1849 '(:name cond
:tab rd
", " fn
)
1850 '(:name cond
:tab fn
", " rd
)))
1852 (with-condition-defaulted (args (condition ,@(if (eq direction
:to-arm
)
1853 '(arm-reg float-reg
)
1854 '(float-reg arm-reg
))))
1855 (emit-fp-srt-instruction segment
1856 (conditional-opcode condition
)
1861 '(system-reg-encoding float-reg
)
1862 '(high-bits-float-reg float-reg
))
1868 '(low-bit-float-reg float-reg
))
1871 (define-single-reg-transfer-fp-instruction fmsr
:single
:from-arm
#b000
)
1872 (define-single-reg-transfer-fp-instruction fmrs
:single
:to-arm
#b000
)
1873 (define-single-reg-transfer-fp-instruction fmdlr
:double
:from-arm
#b000
)
1874 (define-single-reg-transfer-fp-instruction fmrdl
:double
:to-arm
#b000
)
1875 (define-single-reg-transfer-fp-instruction fmdhr
:double
:from-arm
#b001
)
1876 (define-single-reg-transfer-fp-instruction fmrdh
:double
:to-arm
#b001
)
1877 (define-single-reg-transfer-fp-instruction fmxr
:single
:from-arm
#b111 t
)
1878 (define-single-reg-transfer-fp-instruction fmrx
:single
:to-arm
#b111 t
)
1880 (define-bitfield-emitter emit-fp-trt-instruction
32
1882 (byte 7 21) ; #b1100010
1887 (byte 1 8) ; precision
1893 (defmacro define-two-reg-transfer-fp-instruction
(name precision direction
)
1894 (let ((precision-flag (ecase precision
1897 (direction-flag (ecase direction
1900 `(define-instruction ,name
(segment &rest args
)
1902 ((l ,direction-flag
)
1903 (size ,precision-flag
))
1904 ',(if (eq direction
:to-arm
)
1905 '(:name cond
:tab rd
", " rn
", " fm
)
1906 '(:name cond
:tab fm
", " rd
", " rn
)))
1908 (with-condition-defaulted (args (condition ,@(if (eq direction
:to-arm
)
1909 '(arm-reg-1 arm-reg-2 float-reg
)
1910 '(float-reg arm-reg-1 arm-reg-2
))))
1911 (emit-fp-trt-instruction segment
1912 (conditional-opcode condition
)
1915 (tn-offset arm-reg-2
)
1916 (tn-offset arm-reg-1
)
1920 (low-bit-float-reg float-reg
)
1922 (high-bits-float-reg float-reg
)))))))
1924 (define-two-reg-transfer-fp-instruction fmsrr
:single
:from-arm
)
1925 (define-two-reg-transfer-fp-instruction fmrrs
:single
:to-arm
)
1926 (define-two-reg-transfer-fp-instruction fmdrr
:double
:from-arm
)
1927 (define-two-reg-transfer-fp-instruction fmrrd
:double
:to-arm
)