1 ;;;; the instruction set definition for HPPA
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
15 (setf sb
!assem
:*assem-scheduler-p
* nil
))
17 ;;;; Utility functions.
19 (defun reg-tn-encoding (tn)
20 (declare (type tn tn
))
25 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
28 (defun fp-reg-tn-encoding (tn)
29 (declare (type tn tn
))
31 (fp-single-zero (values 0 nil
))
32 (single-reg (values (tn-offset tn
) nil
))
33 (fp-double-zero (values 0 t
))
34 (double-reg (values (tn-offset tn
) t
))))
36 (defconstant-eqx compare-conditions
37 '(:never
:= :< :<= :<< :<<= :sv
:od
:tr
:<> :>= :> :>>= :>> :nsv
:ev
)
40 (deftype compare-condition
()
41 `(member nil
,@compare-conditions
))
43 (defun compare-condition (cond)
44 (declare (type compare-condition cond
))
46 (let ((result (or (position cond compare-conditions
:test
#'eq
)
47 (error "Bogus Compare/Subtract condition: ~S" cond
))))
48 (values (ldb (byte 3 0) result
)
52 (defconstant-eqx add-conditions
53 '(:never
:= :< :<= :nuv
:znv
:sv
:od
:tr
:<> :>= :> :uv
:vnz
:nsv
:ev
)
56 (deftype add-condition
()
57 `(member nil
,@add-conditions
))
59 (defun add-condition (cond)
60 (declare (type add-condition cond
))
62 (let ((result (or (position cond add-conditions
:test
#'eq
)
63 (error "Bogus Add condition: ~S" cond
))))
64 (values (ldb (byte 3 0) result
)
68 (defconstant-eqx logical-conditions
69 '(:never
:= :< :<= nil nil nil
:od
:tr
:<> :>= :> nil nil nil
:ev
)
72 (deftype logical-condition
()
73 `(member nil
,@(remove nil logical-conditions
)))
75 (defun logical-condition (cond)
76 (declare (type logical-condition cond
))
78 (let ((result (or (position cond logical-conditions
:test
#'eq
)
79 (error "Bogus Logical condition: ~S" cond
))))
80 (values (ldb (byte 3 0) result
)
84 (defconstant-eqx unit-conditions
85 '(:never nil
:sbz
:shz
:sdc
:sbc
:shc
:tr nil
:nbz
:nhz
:ndc
:nbc
:nhc
)
88 (deftype unit-condition
()
89 `(member nil
,@(remove nil unit-conditions
)))
91 (defun unit-condition (cond)
92 (declare (type unit-condition cond
))
94 (let ((result (or (position cond unit-conditions
:test
#'eq
)
95 (error "Bogus Unit condition: ~S" cond
))))
96 (values (ldb (byte 3 0) result
)
100 (defconstant-eqx extract
/deposit-conditions
101 '(:never
:= :< :od
:tr
:<> :>= :ev
)
104 (deftype extract
/deposit-condition
()
105 `(member nil
,@extract
/deposit-conditions
))
107 (defun extract/deposit-condition
(cond)
108 (declare (type extract
/deposit-condition cond
))
110 (or (position cond extract
/deposit-conditions
:test
#'eq
)
111 (error "Bogus Extract/Deposit condition: ~S" cond
))
115 (defun space-encoding (space)
116 (declare (type (unsigned-byte 3) space
))
117 (dpb (ldb (byte 2 0) space
)
119 (ldb (byte 1 2) space
)))
122 ;;;; Initial disassembler setup.
124 (setf sb
!disassem
:*disassem-inst-alignment-bytes
* 4)
126 (defvar *disassem-use-lisp-reg-names
* t
)
128 (defparameter reg-symbols
131 (cond ((null name
) nil
)
132 (t (make-symbol (concatenate 'string
"$" name
)))))
135 (sb!disassem
:define-arg-type reg
136 :printer
#'(lambda (value stream dstate
)
137 (declare (stream stream
) (fixnum value
))
138 (let ((regname (aref reg-symbols value
)))
139 (princ regname stream
)
140 (sb!disassem
:maybe-note-associated-storage-ref
146 (defparameter float-reg-symbols
148 (loop for n from
0 to
31 collect
(make-symbol (format nil
"$F~d" n
)))
151 (sb!disassem
:define-arg-type fp-reg
152 :printer
#'(lambda (value stream dstate
)
153 (declare (stream stream
) (fixnum value
))
154 (let ((regname (aref float-reg-symbols value
)))
155 (princ regname stream
)
156 (sb!disassem
:maybe-note-associated-storage-ref
162 (sb!disassem
:define-arg-type fp-fmt-0c
163 :printer
#'(lambda (value stream dstate
)
164 (declare (ignore dstate
) (stream stream
) (fixnum value
))
166 (0 (format stream
"~A" '\
,SGL
))
167 (1 (format stream
"~A" '\
,DBL
))
168 (3 (format stream
"~A" '\
,QUAD
)))))
170 (defun low-sign-extend (x n
)
171 (let ((normal (dpb x
(byte 1 (1- n
)) (ldb (byte (1- n
) 1) x
))))
173 (logior (ash -
1 (1- n
)) normal
)
176 (defun sign-extend (x n
)
177 (if (logbitp (1- n
) x
)
178 (logior (ash -
1 (1- n
)) x
)
181 (defun assemble-bits (x list
)
184 (dolist (e (reverse list
))
185 (setf result
(logior result
(ash (ldb e x
) offset
)))
186 (incf offset
(byte-size e
)))
189 (defmacro define-imx-decode
(name bits
)
190 `(sb!disassem
:define-arg-type
,name
191 :printer
#'(lambda (value stream dstate
)
192 (declare (ignore dstate
) (stream stream
) (fixnum value
))
193 (format stream
"~S" (low-sign-extend value
,bits
)))))
195 (define-imx-decode im5
5)
196 (define-imx-decode im11
11)
197 (define-imx-decode im14
14)
199 (sb!disassem
:define-arg-type im3
200 :printer
#'(lambda (value stream dstate
)
201 (declare (ignore dstate
) (stream stream
) (fixnum value
))
202 (format stream
"~S" (assemble-bits value
`(,(byte 1 0)
205 (sb!disassem
:define-arg-type im21
206 :printer
#'(lambda (value stream dstate
)
207 (declare (ignore dstate
) (stream stream
) (fixnum value
))
209 (assemble-bits value
`(,(byte 1 0) ,(byte 11 1)
210 ,(byte 2 14) ,(byte 5 16)
213 (sb!disassem
:define-arg-type cp
214 :printer
#'(lambda (value stream dstate
)
215 (declare (ignore dstate
) (stream stream
) (fixnum value
))
216 (format stream
"~S" (- 31 value
))))
218 (sb!disassem
:define-arg-type clen
219 :printer
#'(lambda (value stream dstate
)
220 (declare (ignore dstate
) (stream stream
) (fixnum value
))
221 (format stream
"~S" (- 32 value
))))
223 (sb!disassem
:define-arg-type compare-condition
224 :printer
#("" \
,= \
,< \
,<= \
,<< \
,<<= \
,SV \
,OD \
,TR \
,<> \
,>=
225 \
,> \
,>>= \
,>> \
,NSV \
,EV
))
227 (sb!disassem
:define-arg-type compare-condition-false
228 :printer
#(\
,TR \
,<> \
,>= \
,> \
,>>= \
,>> \
,NSV \
,EV
229 "" \
,= \
,< \
,<= \
,<< \
,<<= \
,SV \
,OD
))
231 (sb!disassem
:define-arg-type add-condition
232 :printer
#("" \
,= \
,< \
,<= \
,NUV \
,ZNV \
,SV \
,OD \
,TR \
,<> \
,>= \
,> \
,UV
235 (sb!disassem
:define-arg-type add-condition-false
236 :printer
#(\
,TR \
,<> \
,>= \
,> \
,UV \
,VNZ \
,NSV \
,EV
237 "" \
,= \
,< \
,<= \
,NUV \
,ZNV \
,SV \
,OD
))
239 (sb!disassem
:define-arg-type logical-condition
240 :printer
#("" \
,= \
,< \
,<= "" "" "" \
,OD \
,TR \
,<> \
,>= \
,> "" "" "" \
,EV
))
242 (sb!disassem
:define-arg-type unit-condition
243 :printer
#("" "" \
,SBZ \
,SHZ \
,SDC \
,SBC \
,SHC \
,TR
"" \
,NBZ \
,NHZ \
,NDC
246 (sb!disassem
:define-arg-type extract
/deposit-condition
247 :printer
#("" \
,= \
,< \
,OD \
,TR \
,<> \
,>= \
,EV
))
249 (sb!disassem
:define-arg-type extract
/deposit-condition-false
250 :printer
#(\
,TR \
,<> \
,>= \
,EV
"" \
,= \
,< \
,OD
))
252 (sb!disassem
:define-arg-type nullify
255 (sb!disassem
:define-arg-type fcmp-cond
256 :printer
#(\FALSE? \FALSE
\? \
!<=> \
= \
=T
\?= \
!<> \
!?
>= \
< \?<
257 \
!>= \
!?
> \
<= \?<= \
!> \
!?
<= \
> \?>\ \
!<= \
!?
< \
>=
258 \?>= \
!< \
!?
= \
<> \
!= \
!=T \
!? \
<=> \TRUE? \TRUE
))
260 (sb!disassem
:define-arg-type integer
261 :printer
#'(lambda (value stream dstate
)
262 (declare (ignore dstate
) (stream stream
) (fixnum value
))
263 (format stream
"~S" value
)))
265 (sb!disassem
:define-arg-type space
266 :printer
#("" |
1,| |
2,| |
3,|
))
269 ;;;; Define-instruction-formats for disassembler.
271 (sb!disassem
:define-instruction-format
273 (op :field
(byte 6 26))
274 (b :field
(byte 5 21) :type
'reg
)
275 (t/r
:field
(byte 5 16) :type
'reg
)
276 (s :field
(byte 2 14) :type
'space
)
277 (im14 :field
(byte 14 0) :type
'im14
))
279 (defconstant-eqx cmplt-index-print
'((:cond
((u :constant
1) '\
,S
))
280 (:cond
((m :constant
1) '\
,M
)))
283 (defconstant-eqx cmplt-disp-print
'((:cond
((m :constant
1)
284 (:cond
((s :constant
0) '\
,MA
)
288 (defconstant-eqx cmplt-store-print
'((:cond
((s :constant
0) '\
,B
)
290 (:cond
((m :constant
1) '\
,M
)))
293 (sb!disassem
:define-instruction-format
294 (extended-load/store
32)
295 (op1 :field
(byte 6 26) :value
3)
296 (b :field
(byte 5 21) :type
'reg
)
297 (x/im5
/r
:field
(byte 5 16) :type
'reg
)
298 (s :field
(byte 2 14) :type
'space
)
299 (u :field
(byte 1 13))
300 (op2 :field
(byte 3 10))
301 (ext4/c
:field
(byte 4 6))
302 (m :field
(byte 1 5))
303 (t/im5
:field
(byte 5 0) :type
'reg
))
305 (sb!disassem
:define-instruction-format
306 (ldil 32 :default-printer
'(:name
:tab im21
"," t
))
307 (op :field
(byte 6 26))
308 (t :field
(byte 5 21) :type
'reg
)
309 (im21 :field
(byte 21 0) :type
'im21
))
311 (sb!disassem
:define-instruction-format
313 (op1 :field
(byte 6 26))
314 (t :field
(byte 5 21) :type
'reg
)
315 (w :fields
`(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
317 #'(lambda (value dstate
)
318 (declare (type sb
!disassem
:disassem-state dstate
) (list value
))
319 (let ((x (logior (ash (first value
) 12) (ash (second value
) 1)
322 (assemble-bits x
`(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
323 ,(byte 10 2))) 17) 2)
324 (sb!disassem
:dstate-cur-addr dstate
) 8))))
325 (op2 :field
(byte 3 13))
326 (n :field
(byte 1 1) :type
'nullify
))
328 (sb!disassem
:define-instruction-format
330 (op1 :field
(byte 6 26))
331 (r2 :field
(byte 5 21) :type
'reg
)
332 (r1 :field
(byte 5 16) :type
'reg
)
333 (w :fields
`(,(byte 11 2) ,(byte 1 0))
335 #'(lambda (value dstate
)
336 (declare (type sb
!disassem
:disassem-state dstate
) (list value
))
337 (let ((x (logior (ash (first value
) 1) (second value
))))
339 (assemble-bits x
`(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
341 (sb!disassem
:dstate-cur-addr dstate
) 8))))
342 (c :field
(byte 3 13))
343 (n :field
(byte 1 1) :type
'nullify
))
345 (sb!disassem
:define-instruction-format
347 (op1 :field
(byte 6 26))
348 (t :field
(byte 5 21) :type
'reg
)
349 (x :field
(byte 5 16) :type
'reg
)
350 (op2 :field
(byte 3 13))
351 (x1 :field
(byte 11 2))
352 (n :field
(byte 1 1) :type
'nullify
)
353 (x2 :field
(byte 1 0)))
355 (sb!disassem
:define-instruction-format
356 (r3-inst 32 :default-printer
'(:name c
:tab r1
"," r2
"," t
))
357 (r3 :field
(byte 6 26) :value
2)
358 (r2 :field
(byte 5 21) :type
'reg
)
359 (r1 :field
(byte 5 16) :type
'reg
)
360 (c :field
(byte 3 13))
361 (f :field
(byte 1 12))
362 (op :field
(byte 7 5))
363 (t :field
(byte 5 0) :type
'reg
))
365 (sb!disassem
:define-instruction-format
366 (imm-inst 32 :default-printer
'(:name c
:tab im11
"," r
"," t
))
367 (op :field
(byte 6 26))
368 (r :field
(byte 5 21) :type
'reg
)
369 (t :field
(byte 5 16) :type
'reg
)
370 (c :field
(byte 3 13))
371 (f :field
(byte 1 12))
372 (o :field
(byte 1 11))
373 (im11 :field
(byte 11 0) :type
'im11
))
375 (sb!disassem
:define-instruction-format
376 (extract/deposit-inst
32)
377 (op1 :field
(byte 6 26))
378 (r2 :field
(byte 5 21) :type
'reg
)
379 (r1 :field
(byte 5 16) :type
'reg
)
380 (c :field
(byte 3 13) :type
'extract
/deposit-condition
)
381 (op2 :field
(byte 3 10))
382 (cp :field
(byte 5 5) :type
'cp
)
383 (t/clen
:field
(byte 5 0) :type
'clen
))
385 (sb!disassem
:define-instruction-format
386 (break 32 :default-printer
'(:name
:tab im13
"," im5
))
387 (op1 :field
(byte 6 26) :value
0)
388 (im13 :field
(byte 13 13))
389 (q2 :field
(byte 8 5) :value
0)
390 (im5 :field
(byte 5 0)))
392 (defun snarf-error-junk (sap offset
&optional length-only
)
393 (let* ((length (sb!sys
:sap-ref-8 sap offset
))
394 (vector (make-array length
:element-type
'(unsigned-byte 8))))
395 (declare (type sb
!sys
:system-area-pointer sap
)
396 (type (unsigned-byte 8) length
)
397 (type (simple-array (unsigned-byte 8) (*)) vector
))
399 (values 0 (1+ length
) nil nil
))
401 (sb!kernel
:copy-ub8-from-system-area sap
(1+ offset
)
403 (collect ((sc-offsets)
405 (lengths 1) ; the length byte
407 (error-number (sb!c
:read-var-integer vector index
)))
410 (when (>= index length
)
412 (let ((old-index index
))
413 (sc-offsets (sb!c
:read-var-integer vector index
))
414 (lengths (- index old-index
))))
420 (defun break-control (chunk inst stream dstate
)
421 (declare (ignore inst
))
422 (flet ((nt (x) (if stream
(sb!disassem
:note x dstate
))))
423 (case (break-im5 chunk dstate
)
426 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
429 (sb!disassem
:handle-break-args
#'snarf-error-junk stream dstate
))
431 (nt "Breakpoint trap"))
432 (#.pending-interrupt-trap
433 (nt "Pending interrupt trap"))
436 (#.fun-end-breakpoint-trap
437 (nt "Function end breakpoint trap"))
440 (sb!disassem
:define-instruction-format
442 (op1 :field
(byte 6 26) :value
0)
443 (r1 :field
(byte 5 21) :type
'reg
)
444 (r2 :field
(byte 5 16) :type
'reg
)
445 (s :field
(byte 3 13))
446 (op2 :field
(byte 8 5))
447 (r3 :field
(byte 5 0) :type
'reg
))
449 (sb!disassem
:define-instruction-format
451 (op :field
(byte 6 26))
452 (b :field
(byte 5 21) :type
'reg
)
453 (x :field
(byte 5 16) :type
'reg
)
454 (s :field
(byte 2 14) :type
'space
)
455 (u :field
(byte 1 13))
456 (x1 :field
(byte 1 12))
457 (x2 :field
(byte 2 10))
458 (x3 :field
(byte 1 9))
459 (x4 :field
(byte 3 6))
460 (m :field
(byte 1 5))
461 (t :field
(byte 5 0) :type
'fp-reg
))
463 (sb!disassem
:define-instruction-format
465 (op1 :field
(byte 6 26))
466 (r :field
(byte 5 21) :type
'fp-reg
)
467 (x1 :field
(byte 5 16) :type
'fp-reg
)
468 (op2 :field
(byte 3 13))
469 (fmt :field
(byte 2 11) :type
'fp-fmt-0c
)
470 (x2 :field
(byte 2 9))
471 (x3 :field
(byte 3 6))
472 (x4 :field
(byte 1 5))
473 (t :field
(byte 5 0) :type
'fp-reg
))
475 (sb!disassem
:define-instruction-format
477 (op1 :field
(byte 6 26))
478 (r :field
(byte 5 21) :type
'fp-reg
)
479 (x1 :field
(byte 4 17) :value
0)
480 (x2 :field
(byte 2 15))
481 (df :field
(byte 2 13) :type
'fp-fmt-0c
)
482 (sf :field
(byte 2 11) :type
'fp-fmt-0c
)
483 (x3 :field
(byte 2 9) :value
1)
484 (x4 :field
(byte 3 6) :value
0)
485 (x5 :field
(byte 1 5) :value
0)
486 (t :field
(byte 5 0) :type
'fp-reg
))
490 ;;;; Load and Store stuff.
492 (define-bitfield-emitter emit-load
/store
32
500 (defun im14-encoding (segment disp
)
501 (declare (type (or fixup
(signed-byte 14))))
502 (cond ((fixup-p disp
)
503 (note-fixup segment
:load disp
)
504 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
507 (dpb (ldb (byte 13 0) disp
)
509 (ldb (byte 1 13) disp
)))))
511 (macrolet ((define-load-inst (name opcode
)
512 `(define-instruction ,name
(segment disp base reg
)
513 (:declare
(type tn reg base
)
514 (type (or fixup
(signed-byte 14)) disp
))
515 (:printer load
/store
((op ,opcode
) (s 0))
516 '(:name
:tab im14
"(" s b
")," t
/r
))
518 (emit-load/store segment
,opcode
519 (reg-tn-encoding base
) (reg-tn-encoding reg
) 0
520 (im14-encoding segment disp
)))))
521 (define-store-inst (name opcode
)
522 `(define-instruction ,name
(segment reg disp base
)
523 (:declare
(type tn reg base
)
524 (type (or fixup
(signed-byte 14)) disp
))
525 (:printer load
/store
((op ,opcode
) (s 0))
526 '(:name
:tab t
/r
"," im14
"(" s b
")"))
528 (emit-load/store segment
,opcode
529 (reg-tn-encoding base
) (reg-tn-encoding reg
) 0
530 (im14-encoding segment disp
))))))
531 (define-load-inst ldw
#x12
)
532 (define-load-inst ldh
#x11
)
533 (define-load-inst ldb
#x10
)
534 (define-load-inst ldwm
#x13
)
535 (define-load-inst ldo
#x0D
)
537 (define-store-inst stw
#x1A
)
538 (define-store-inst sth
#x19
)
539 (define-store-inst stb
#x18
)
540 (define-store-inst stwm
#x1B
))
542 (define-bitfield-emitter emit-extended-load
/store
32
543 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
544 (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
546 (macrolet ((define-load-indexed-inst (name opcode
)
547 `(define-instruction ,name
(segment index base reg
&key modify scale
)
548 (:declare
(type tn reg base index
)
549 (type (member t nil
) modify scale
))
550 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'reg
)
552 `(:name
,@cmplt-index-print
:tab x
/im5
/r
555 (emit-extended-load/store
556 segment
#x03
(reg-tn-encoding base
) (reg-tn-encoding index
)
557 0 (if scale
1 0) 0 ,opcode
(if modify
1 0)
558 (reg-tn-encoding reg
))))))
559 (define-load-indexed-inst ldwx
2)
560 (define-load-indexed-inst ldhx
1)
561 (define-load-indexed-inst ldbx
0)
562 (define-load-indexed-inst ldcwx
7))
564 (defun short-disp-encoding (segment disp
)
565 (declare (type (or fixup
(signed-byte 5)) disp
))
566 (cond ((fixup-p disp
)
567 (note-fixup segment
:load-short disp
)
568 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
571 (dpb (ldb (byte 4 0) disp
)
573 (ldb (byte 1 4) disp
)))))
575 (macrolet ((define-load-short-inst (name opcode
)
576 `(define-instruction ,name
(segment base disp reg
&key modify
)
577 (:declare
(type tn base reg
)
578 (type (or fixup
(signed-byte 5)) disp
)
579 (type (member :before
:after nil
) modify
))
580 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'im5
)
582 `(:name
,@cmplt-disp-print
:tab x
/im5
/r
589 (:after
(values 1 0))
590 (:before
(values 1 1)))
591 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
592 (short-disp-encoding segment disp
)
594 (reg-tn-encoding reg
))))))
595 (define-store-short-inst (name opcode
)
596 `(define-instruction ,name
(segment reg base disp
&key modify
)
597 (:declare
(type tn reg base
)
598 (type (or fixup
(signed-byte 5)) disp
)
599 (type (member :before
:after nil
) modify
))
600 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'im5
)
602 `(:name
,@cmplt-disp-print
:tab x
/im5
/r
603 "," t
/im5
"(" s b
")"))
609 (:after
(values 1 0))
610 (:before
(values 1 1)))
611 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
612 (short-disp-encoding segment disp
)
614 (reg-tn-encoding reg
)))))))
615 (define-load-short-inst ldws
2)
616 (define-load-short-inst ldhs
1)
617 (define-load-short-inst ldbs
0)
618 (define-load-short-inst ldcws
7)
620 (define-store-short-inst stws
10)
621 (define-store-short-inst sths
9)
622 (define-store-short-inst stbs
8))
624 (define-instruction stbys
(segment reg base disp where
&key modify
)
625 (:declare
(type tn reg base
)
626 (type (signed-byte 5) disp
)
627 (type (member :begin
:end
) where
)
628 (type (member t nil
) modify
))
629 (:printer extended-load
/store
((ext4/c
#xC
) (t/im5 nil
:type
'im5
) (op2 4))
630 `(:name
,@cmplt-store-print
:tab x
/im5
/r
"," t
/im5
"(" s b
")"))
632 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
633 (reg-tn-encoding reg
) 0
634 (ecase where
(:begin
0) (:end
1))
635 4 #xC
(if modify
1 0)
636 (short-disp-encoding segment disp
))))
639 ;;;; Immediate Instructions.
641 (define-bitfield-emitter emit-ldil
32
646 (defun immed-21-encoding (segment value
)
647 (declare (type (or fixup
(signed-byte 21) (unsigned-byte 21)) value
))
648 (cond ((fixup-p value
)
649 (note-fixup segment
:hi value
)
650 (aver (or (null (fixup-offset value
)) (zerop (fixup-offset value
))))
653 (logior (ash (ldb (byte 5 2) value
) 16)
654 (ash (ldb (byte 2 7) value
) 14)
655 (ash (ldb (byte 2 0) value
) 12)
656 (ash (ldb (byte 11 9) value
) 1)
657 (ldb (byte 1 20) value
)))))
659 (define-instruction ldil
(segment value reg
)
660 (:declare
(type tn reg
)
661 (type (or (signed-byte 21) (unsigned-byte 21) fixup
) value
))
662 (:printer ldil
((op #x08
)))
664 (emit-ldil segment
#x08
(reg-tn-encoding reg
)
665 (immed-21-encoding segment value
))))
667 (define-instruction addil
(segment value reg
)
668 (:declare
(type tn reg
)
669 (type (or (signed-byte 21) (unsigned-byte 21) fixup
) value
))
670 (:printer ldil
((op #x0A
)))
672 (emit-ldil segment
#x0A
(reg-tn-encoding reg
)
673 (immed-21-encoding segment value
))))
676 ;;;; Branch instructions.
678 (define-bitfield-emitter emit-branch
32
679 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
680 (byte 11 2) (byte 1 1) (byte 1 0))
682 (defun label-relative-displacement (label posn
&optional delta-if-after
)
683 (declare (type label label
) (type index posn
))
684 (ash (- (if delta-if-after
685 (label-position label posn delta-if-after
)
686 (label-position label
))
689 (defun decompose-branch-disp (segment disp
)
690 (declare (type (or fixup
(signed-byte 17)) disp
))
691 (cond ((fixup-p disp
)
692 (note-fixup segment
:branch disp
)
693 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
696 (values (ldb (byte 5 11) disp
)
697 (dpb (ldb (byte 10 0) disp
)
699 (ldb (byte 1 10) disp
))
700 (ldb (byte 1 16) disp
)))))
702 (defun emit-relative-branch (segment opcode link sub-opcode target nullify
)
703 (declare (type (unsigned-byte 6) opcode
)
704 (type (unsigned-byte 5) link
)
705 (type (unsigned-byte 1) sub-opcode
)
707 (type (member t nil
) nullify
))
708 (emit-back-patch segment
4
709 #'(lambda (segment posn
)
710 (let ((disp (label-relative-displacement target posn
)))
711 (aver (<= (- (ash 1 16)) disp
(1- (ash 1 16))))
714 (decompose-branch-disp segment disp
)
715 (emit-branch segment opcode link w1 sub-opcode w2
716 (if nullify
1 0) w
))))))
718 (define-instruction b
(segment target
&key nullify
)
719 (:declare
(type label target
) (type (member t nil
) nullify
))
721 (emit-relative-branch segment
#x3A
0 0 target nullify
)))
723 (define-instruction bl
(segment target reg
&key nullify
)
724 (:declare
(type tn reg
) (type label target
) (type (member t nil
) nullify
))
725 (:printer branch17
((op1 #x3A
) (op2 0)) '(:name n
:tab w
"," t
))
727 (emit-relative-branch segment
#x3A
(reg-tn-encoding reg
) 0 target nullify
)))
729 (define-instruction gateway
(segment target reg
&key nullify
)
730 (:declare
(type tn reg
) (type label target
) (type (member t nil
) nullify
))
731 (:printer branch17
((op1 #x3A
) (op2 1)) '(:name n
:tab w
"," t
))
733 (emit-relative-branch segment
#x3A
(reg-tn-encoding reg
) 1 target nullify
)))
735 ;;; BLR is useless because we have no way to generate the offset.
737 (define-instruction bv
(segment base
&key nullify offset
)
738 (:declare
(type tn base
)
739 (type (member t nil
) nullify
)
740 (type (or tn null
) offset
))
741 (:printer branch
((op1 #x3A
) (op2 6)) '(:name n
:tab x
"(" t
")"))
743 (emit-branch segment
#x3A
(reg-tn-encoding base
)
744 (if offset
(reg-tn-encoding offset
) 0)
745 6 0 (if nullify
1 0) 0)))
747 (define-instruction be
(segment disp space base
&key nullify
)
748 (:declare
(type (or fixup
(signed-byte 17)) disp
)
750 (type (unsigned-byte 3) space
)
751 (type (member t nil
) nullify
))
752 (:printer branch17
((op1 #x38
) (op2 nil
:type
'im3
))
753 '(:name n
:tab w
"(" op2
"," t
")"))
757 (decompose-branch-disp segment disp
)
758 (emit-branch segment
#x38
(reg-tn-encoding base
) w1
759 (space-encoding space
) w2
(if nullify
1 0) w
))))
761 (define-instruction ble
(segment disp space base
&key nullify
)
762 (:declare
(type (or fixup
(signed-byte 17)) disp
)
764 (type (unsigned-byte 3) space
)
765 (type (member t nil
) nullify
))
766 (:printer branch17
((op1 #x39
) (op2 nil
:type
'im3
))
767 '(:name n
:tab w
"(" op2
"," t
")"))
771 (decompose-branch-disp segment disp
)
772 (emit-branch segment
#x39
(reg-tn-encoding base
) w1
773 (space-encoding space
) w2
(if nullify
1 0) w
))))
775 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify
)
776 (emit-back-patch segment
4
777 #'(lambda (segment posn
)
778 (let ((disp (label-relative-displacement target posn
)))
779 (aver (<= (- (ash 1 11)) disp
(1- (ash 1 11))))
780 (let ((w1 (logior (ash (ldb (byte 10 0) disp
) 1)
781 (ldb (byte 1 10) disp
)))
782 (w (ldb (byte 1 11) disp
)))
783 (emit-branch segment opcode r2 r1 cond w1
(if nullify
1 0) w
))))))
785 (defun im5-encoding (value)
786 (declare (type (signed-byte 5) value
)
787 #+nil
(values (unsigned-byte 5)))
788 (dpb (ldb (byte 4 0) value
)
790 (ldb (byte 1 4) value
)))
792 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
)
793 (let* ((conditional (symbolicate cond-kind
"-CONDITION"))
794 (false-conditional (symbolicate conditional
"-FALSE")))
796 (define-instruction ,r-name
(segment cond r1 r2 target
&key nullify
)
797 (:declare
(type ,conditional cond
)
800 (type (member t nil
) nullify
))
801 (:printer branch12
((op1 ,r-opcode
) (c nil
:type
',conditional
))
802 '(:name c n
:tab r1
"," r2
"," w
))
803 ,@(unless (= r-opcode
#x32
)
804 `((:printer branch12
((op1 ,(+ 2 r-opcode
))
805 (c nil
:type
',false-conditional
))
806 '(:name c n
:tab r1
"," r2
"," w
))))
809 (cond-encoding false
)
811 (emit-conditional-branch
812 segment
(if false
,(+ r-opcode
2) ,r-opcode
)
813 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
814 cond-encoding target nullify
))))
815 (define-instruction ,i-name
(segment cond imm reg target
&key nullify
)
816 (:declare
(type ,conditional cond
)
817 (type (signed-byte 5) imm
)
819 (type (member t nil
) nullify
))
820 (:printer branch12
((op1 ,i-opcode
) (r1 nil
:type
'im5
)
821 (c nil
:type
',conditional
))
822 '(:name c n
:tab r1
"," r2
"," w
))
823 ,@(unless (= r-opcode
#x32
)
824 `((:printer branch12
((op1 ,(+ 2 i-opcode
)) (r1 nil
:type
'im5
)
825 (c nil
:type
',false-conditional
))
826 '(:name c n
:tab r1
"," r2
"," w
))))
829 (cond-encoding false
)
831 (emit-conditional-branch
832 segment
(if false
(+ ,i-opcode
2) ,i-opcode
)
833 (reg-tn-encoding reg
) (im5-encoding imm
)
834 cond-encoding target nullify
))))))))
835 (define-branch-inst movb
#x32 movib
#x33 extract
/deposit
)
836 (define-branch-inst comb
#x20 comib
#x21 compare
)
837 (define-branch-inst addb
#x28 addib
#x29 add
))
839 (define-instruction bb
(segment cond reg posn target
&key nullify
)
840 (:declare
(type (member t nil
) cond nullify
)
842 (type (or (member :variable
) (unsigned-byte 5)) posn
))
843 (:printer branch12
((op1 30) (c nil
:type
'extract
/deposit-condition
))
844 '('BVB c n
:tab r1
"," w
))
847 (opcode posn-encoding
)
848 (if (eq posn
:variable
)
851 (emit-conditional-branch segment opcode posn-encoding
852 (reg-tn-encoding reg
)
853 (if cond
2 6) target nullify
))))
856 ;;;; Computation Instructions
858 (define-bitfield-emitter emit-r3-inst
32
859 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
860 (byte 1 12) (byte 7 5) (byte 5 0))
862 (macrolet ((define-r3-inst (name cond-kind opcode
)
863 `(define-instruction ,name
(segment r1 r2 res
&optional cond
)
864 (:declare
(type tn res r1 r2
))
865 (:printer r3-inst
((op ,opcode
) (c nil
:type
',(symbolicate
868 ,@(when (= opcode
#x12
)
869 `((:printer r3-inst
((op ,opcode
) (r2 0)
870 (c nil
:type
',(symbolicate cond-kind
872 `('COPY
:tab r1
"," t
))))
876 (,(symbolicate cond-kind
"-CONDITION") cond
)
877 (emit-r3-inst segment
#x02
(reg-tn-encoding r2
) (reg-tn-encoding r1
)
878 cond
(if false
1 0) ,opcode
879 (reg-tn-encoding res
)))))))
880 (define-r3-inst add add
#x30
)
881 (define-r3-inst addl add
#x50
)
882 (define-r3-inst addo add
#x70
)
883 (define-r3-inst addc add
#x38
)
884 (define-r3-inst addco add
#x78
)
885 (define-r3-inst sh1add add
#x32
)
886 (define-r3-inst sh1addl add
#x52
)
887 (define-r3-inst sh1addo add
#x72
)
888 (define-r3-inst sh2add add
#x34
)
889 (define-r3-inst sh2addl add
#x54
)
890 (define-r3-inst sh2addo add
#x74
)
891 (define-r3-inst sh3add add
#x36
)
892 (define-r3-inst sh3addl add
#x56
)
893 (define-r3-inst sh3addo add
#x76
)
894 (define-r3-inst sub compare
#x20
)
895 (define-r3-inst subo compare
#x60
)
896 (define-r3-inst subb compare
#x28
)
897 (define-r3-inst subbo compare
#x68
)
898 (define-r3-inst subt compare
#x26
)
899 (define-r3-inst subto compare
#x66
)
900 (define-r3-inst ds compare
#x22
)
901 (define-r3-inst comclr compare
#x44
)
902 (define-r3-inst or logical
#x12
)
903 (define-r3-inst xor logical
#x14
)
904 (define-r3-inst and logical
#x10
)
905 (define-r3-inst andcm logical
#x00
)
906 (define-r3-inst uxor unit
#x1C
)
907 (define-r3-inst uaddcm unit
#x4C
)
908 (define-r3-inst uaddcmt unit
#x4E
)
909 (define-r3-inst dcor unit
#x5C
)
910 (define-r3-inst idcor unit
#x5E
))
912 (define-bitfield-emitter emit-imm-inst
32
913 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
914 (byte 1 12) (byte 1 11) (byte 11 0))
916 (defun im11-encoding (value)
917 (declare (type (signed-byte 11) value
)
918 #+nil
(values (unsigned-byte 11)))
919 (dpb (ldb (byte 10 0) value
)
921 (ldb (byte 1 10) value
)))
923 (macrolet ((define-imm-inst (name cond-kind opcode subcode
)
924 `(define-instruction ,name
(segment imm src dst
&optional cond
)
925 (:declare
(type tn dst src
)
926 (type (signed-byte 11) imm
))
927 (:printer imm-inst
((op ,opcode
) (o ,subcode
)
929 ',(symbolicate cond-kind
"-CONDITION"))))
933 (,(symbolicate cond-kind
"-CONDITION") cond
)
934 (emit-imm-inst segment
,opcode
(reg-tn-encoding src
)
935 (reg-tn-encoding dst
) cond
936 (if false
1 0) ,subcode
937 (im11-encoding imm
)))))))
938 (define-imm-inst addi add
#x2D
0)
939 (define-imm-inst addio add
#x2D
1)
940 (define-imm-inst addit add
#x2C
0)
941 (define-imm-inst addito add
#x2C
1)
942 (define-imm-inst subi compare
#x25
0)
943 (define-imm-inst subio compare
#x25
1)
944 (define-imm-inst comiclr compare
#x24
0))
946 (define-bitfield-emitter emit-extract
/deposit-inst
32
947 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
948 (byte 3 10) (byte 5 5) (byte 5 0))
950 (define-instruction shd
(segment r1 r2 count res
&optional cond
)
951 (:declare
(type tn res r1 r2
)
952 (type (or (member :variable
) (integer 0 31)) count
))
953 (:printer extract
/deposit-inst
((op1 #x34
) (op2 2) (t/clen nil
:type
'reg
))
954 '(:name c
:tab r1
"," r2
"," cp
"," t
/clen
))
955 (:printer extract
/deposit-inst
((op1 #x34
) (op2 0) (t/clen nil
:type
'reg
))
956 '('VSHD c
:tab r1
"," r2
"," t
/clen
))
960 (emit-extract/deposit-inst segment
#x34
961 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
962 (extract/deposit-condition cond
)
963 0 0 (reg-tn-encoding res
)))
965 (emit-extract/deposit-inst segment
#x34
966 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
967 (extract/deposit-condition cond
)
969 (reg-tn-encoding res
))))))
971 (macrolet ((define-extract-inst (name opcode
)
972 `(define-instruction ,name
(segment src posn len res
&optional cond
)
973 (:declare
(type tn res src
)
974 (type (or (member :variable
) (integer 0 31)) posn
)
975 (type (integer 1 32) len
))
976 (:printer extract
/deposit-inst
((op1 #x34
) (cp nil
:type
'integer
)
978 '(:name c
:tab r2
"," cp
"," t
/clen
"," r1
))
979 (:printer extract
/deposit-inst
((op1 #x34
) (op2 ,(- opcode
2)))
980 '('V
:name c
:tab r2
"," t
/clen
"," r1
))
984 (emit-extract/deposit-inst segment
#x34
(reg-tn-encoding src
)
985 (reg-tn-encoding res
)
986 (extract/deposit-condition cond
)
987 ,(- opcode
2) 0 (- 32 len
)))
989 (emit-extract/deposit-inst segment
#x34
(reg-tn-encoding src
)
990 (reg-tn-encoding res
)
991 (extract/deposit-condition cond
)
992 ,opcode posn
(- 32 len
))))))))
993 (define-extract-inst extru
6)
994 (define-extract-inst extrs
7))
996 (macrolet ((define-deposit-inst (name opcode
)
997 `(define-instruction ,name
(segment src posn len res
&optional cond
)
998 (:declare
(type tn res
)
999 (type (or tn
(signed-byte 5)) src
)
1000 (type (or (member :variable
) (integer 0 31)) posn
)
1001 (type (integer 1 32) len
))
1002 (:printer extract
/deposit-inst
((op1 #x35
) (op2 ,opcode
))
1003 ',(let ((base '('VDEP c
:tab r1
"," t
/clen
"," r2
)))
1004 (if (= opcode
0) (cons ''Z base
) base
)))
1005 (:printer extract
/deposit-inst
((op1 #x35
) (op2 ,(+ 2 opcode
)))
1006 ',(let ((base '('DEP c
:tab r1
"," cp
"," t
/clen
"," r2
)))
1007 (if (= opcode
0) (cons ''Z base
) base
)))
1008 (:printer extract
/deposit-inst
((op1 #x35
) (r1 nil
:type
'im5
)
1009 (op2 ,(+ 4 opcode
)))
1010 ',(let ((base '('VDEPI c
:tab r1
"," t
/clen
"," r2
)))
1011 (if (= opcode
0) (cons ''Z base
) base
)))
1012 (:printer extract
/deposit-inst
((op1 #x35
) (r1 nil
:type
'im5
)
1013 (op2 ,(+ 6 opcode
)))
1014 ',(let ((base '('DEPI c
:tab r1
"," cp
"," t
/clen
"," r2
)))
1015 (if (= opcode
0) (cons ''Z base
) base
)))
1017 (multiple-value-bind
1018 (opcode src-encoding
)
1021 (values ,opcode
(reg-tn-encoding src
)))
1023 (values ,(+ opcode
4) (im5-encoding src
))))
1024 (multiple-value-bind
1025 (opcode posn-encoding
)
1030 (values (+ opcode
2) (- 31 posn
))))
1031 (emit-extract/deposit-inst segment
#x35
(reg-tn-encoding res
)
1033 (extract/deposit-condition cond
)
1034 opcode posn-encoding
(- 32 len
))))))))
1036 (define-deposit-inst dep
1)
1037 (define-deposit-inst zdep
0))
1041 ;;;; System Control Instructions.
1043 (define-bitfield-emitter emit-break
32
1044 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1046 (define-instruction break
(segment &optional
(im5 0) (im13 0))
1047 (:declare
(type (unsigned-byte 13) im13
)
1048 (type (unsigned-byte 5) im5
))
1049 (:printer break
() :default
:control
#'break-control
)
1051 (emit-break segment
0 im13
0 im5
)))
1053 (define-bitfield-emitter emit-system-inst
32
1054 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1056 (define-instruction ldsid
(segment res base
&optional
(space 0))
1057 (:declare
(type tn res base
)
1058 (type (integer 0 3) space
))
1059 (:printer system-inst
((op2 #x85
) (c nil
:type
'space
)
1060 (s nil
:printer
#(0 0 1 1 2 2 3 3)))
1061 `(:name
:tab
"(" s r1
")," r3
))
1063 (emit-system-inst segment
0 (reg-tn-encoding base
) 0 (ash space
1) #x85
1064 (reg-tn-encoding res
))))
1066 (define-instruction mtsp
(segment reg space
)
1067 (:declare
(type tn reg
) (type (integer 0 7) space
))
1068 (:printer system-inst
((op2 #xC1
)) '(:name
:tab r2
"," s
))
1070 (emit-system-inst segment
0 0 (reg-tn-encoding reg
) (space-encoding space
)
1073 (define-instruction mfsp
(segment space reg
)
1074 (:declare
(type tn reg
) (type (integer 0 7) space
))
1075 (:printer system-inst
((op2 #x25
) (c nil
:type
'space
)) '(:name
:tab s r3
))
1077 (emit-system-inst segment
0 0 0 (space-encoding space
) #x25
1078 (reg-tn-encoding reg
))))
1080 (deftype control-reg
()
1081 '(or (unsigned-byte 5) (member :sar
)))
1083 (defun control-reg (reg)
1084 (declare (type control-reg reg
)
1085 #+nil
(values (unsigned-byte 32)))
1086 (if (typep reg
'(unsigned-byte 5))
1091 (define-instruction mtctl
(segment reg ctrl-reg
)
1092 (:declare
(type tn reg
) (type control-reg ctrl-reg
))
1093 (:printer system-inst
((op2 #xC2
)) '(:name
:tab r2
"," r1
))
1095 (emit-system-inst segment
0 (control-reg ctrl-reg
) (reg-tn-encoding reg
)
1098 (define-instruction mfctl
(segment ctrl-reg reg
)
1099 (:declare
(type tn reg
) (type control-reg ctrl-reg
))
1100 (:printer system-inst
((op2 #x45
)) '(:name
:tab r1
"," r3
))
1102 (emit-system-inst segment
0 (control-reg ctrl-reg
) 0 0 #x45
1103 (reg-tn-encoding reg
))))
1107 ;;;; Floating point instructions.
1109 (define-bitfield-emitter emit-fp-load
/store
32
1110 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1111 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1113 (define-instruction fldx
(segment index base result
&key modify scale side
)
1114 (:declare
(type tn index base result
)
1115 (type (member t nil
) modify scale
)
1116 (type (member nil
0 1) side
))
1117 (:printer fp-load
/store
((op #x0b
) (x1 0) (x2 0) (x3 0))
1118 `('FLDDX
,@cmplt-index-print
:tab x
"(" s b
")" "," t
))
1119 (:printer fp-load
/store
((op #x09
) (x1 0) (x2 0) (x3 0))
1120 `('FLDWX
,@cmplt-index-print
:tab x
"(" s b
")" "," t
))
1122 (multiple-value-bind
1123 (result-encoding double-p
)
1124 (fp-reg-tn-encoding result
)
1127 (setf double-p nil
))
1128 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1129 (reg-tn-encoding index
) 0 (if scale
1 0) 0 0 0
1130 (or side
0) (if modify
1 0) result-encoding
))))
1132 (define-instruction fstx
(segment value index base
&key modify scale side
)
1133 (:declare
(type tn index base value
)
1134 (type (member t nil
) modify scale
)
1135 (type (member nil
0 1) side
))
1136 (:printer fp-load
/store
((op #x0b
) (x1 0) (x2 0) (x3 1))
1137 `('FSTDX
,@cmplt-index-print
:tab t
"," x
"(" s b
")"))
1138 (:printer fp-load
/store
((op #x09
) (x1 0) (x2 0) (x3 1))
1139 `('FSTWX
,@cmplt-index-print
:tab t
"," x
"(" s b
")"))
1141 (multiple-value-bind
1142 (value-encoding double-p
)
1143 (fp-reg-tn-encoding value
)
1146 (setf double-p nil
))
1147 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1148 (reg-tn-encoding index
) 0 (if scale
1 0) 0 0 1
1149 (or side
0) (if modify
1 0) value-encoding
))))
1151 (define-instruction flds
(segment disp base result
&key modify side
)
1152 (:declare
(type tn base result
)
1153 (type (signed-byte 5) disp
)
1154 (type (member :before
:after nil
) modify
)
1155 (type (member nil
0 1) side
))
1156 (:printer fp-load
/store
((op #x0b
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 0))
1157 `('FLDDS
,@cmplt-disp-print
:tab x
"(" s b
")," t
))
1158 (:printer fp-load
/store
((op #x09
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 0))
1159 `('FLDWS
,@cmplt-disp-print
:tab x
"(" s b
")," t
))
1161 (multiple-value-bind
1162 (result-encoding double-p
)
1163 (fp-reg-tn-encoding result
)
1166 (setf double-p nil
))
1167 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1168 (short-disp-encoding segment disp
) 0
1169 (if (eq modify
:before
) 1 0) 1 0 0
1170 (or side
0) (if modify
1 0) result-encoding
))))
1172 (define-instruction fsts
(segment value disp base
&key modify side
)
1173 (:declare
(type tn base value
)
1174 (type (signed-byte 5) disp
)
1175 (type (member :before
:after nil
) modify
)
1176 (type (member nil
0 1) side
))
1177 (:printer fp-load
/store
((op #x0b
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 1))
1178 `('FSTDS
,@cmplt-disp-print
:tab t
"," x
"(" s b
")"))
1179 (:printer fp-load
/store
((op #x09
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 1))
1180 `('FSTWS
,@cmplt-disp-print
:tab t
"," x
"(" s b
")"))
1182 (multiple-value-bind
1183 (value-encoding double-p
)
1184 (fp-reg-tn-encoding value
)
1187 (setf double-p nil
))
1188 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1189 (short-disp-encoding segment disp
) 0
1190 (if (eq modify
:before
) 1 0) 1 0 1
1191 (or side
0) (if modify
1 0) value-encoding
))))
1194 (define-bitfield-emitter emit-fp-class-0-inst
32
1195 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1196 (byte 3 6) (byte 1 5) (byte 5 0))
1198 (define-bitfield-emitter emit-fp-class-1-inst
32
1199 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1200 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1202 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1203 ;;; seperate emitters.
1205 (defconstant-eqx funops
'(:copy
:abs
:sqrt
:rnd
)
1211 (define-instruction funop
(segment op from to
)
1212 (:declare
(type funop op
)
1214 (:printer fp-class-0-inst
((op1 #x0C
) (op2 2) (x2 0))
1215 '('FCPY fmt
:tab r
"," t
))
1216 (:printer fp-class-0-inst
((op1 #x0C
) (op2 3) (x2 0))
1217 '('FABS fmt
:tab r
"," t
))
1218 (:printer fp-class-0-inst
((op1 #x0C
) (op2 4) (x2 0))
1219 '('FSQRT fmt
:tab r
"," t
))
1220 (:printer fp-class-0-inst
((op1 #x0C
) (op2 5) (x2 0))
1221 '('FRND fmt
:tab r
"," t
))
1223 (multiple-value-bind
1224 (from-encoding from-double-p
)
1225 (fp-reg-tn-encoding from
)
1226 (multiple-value-bind
1227 (to-encoding to-double-p
)
1228 (fp-reg-tn-encoding to
)
1229 (aver (eq from-double-p to-double-p
))
1230 (emit-fp-class-0-inst segment
#x0C from-encoding
0
1231 (+ 2 (or (position op funops
)
1232 (error "Bogus FUNOP: ~S" op
)))
1233 (if to-double-p
1 0) 0 0 0 to-encoding
)))))
1235 (macrolet ((define-class-1-fp-inst (name subcode
)
1236 `(define-instruction ,name
(segment from to
)
1237 (:declare
(type tn from to
))
1238 (:printer fp-class-1-inst
((op1 #x0C
) (x2 ,subcode
))
1239 '(:name sf df
:tab r
"," t
))
1241 (multiple-value-bind
1242 (from-encoding from-double-p
)
1243 (fp-reg-tn-encoding from
)
1244 (multiple-value-bind
1245 (to-encoding to-double-p
)
1246 (fp-reg-tn-encoding to
)
1247 (emit-fp-class-1-inst segment
#x0C from-encoding
0 ,subcode
1248 (if to-double-p
1 0) (if from-double-p
1 0)
1249 1 0 0 to-encoding
)))))))
1251 (define-class-1-fp-inst fcnvff
0)
1252 (define-class-1-fp-inst fcnvxf
1)
1253 (define-class-1-fp-inst fcnvfx
2)
1254 (define-class-1-fp-inst fcnvfxt
3))
1256 (define-instruction fcmp
(segment cond r1 r2
)
1257 (:declare
(type (unsigned-byte 5) cond
)
1259 (:printer fp-class-0-inst
((op1 #x0C
) (op2 0) (x2 2) (t nil
:type
'fcmp-cond
))
1260 '(:name fmt t
:tab r
"," x1
))
1262 (multiple-value-bind
1263 (r1-encoding r1-double-p
)
1264 (fp-reg-tn-encoding r1
)
1265 (multiple-value-bind
1266 (r2-encoding r2-double-p
)
1267 (fp-reg-tn-encoding r2
)
1268 (aver (eq r1-double-p r2-double-p
))
1269 (emit-fp-class-0-inst segment
#x0C r1-encoding r2-encoding
0
1270 (if r1-double-p
1 0) 2 0 0 cond
)))))
1272 (define-instruction ftest
(segment)
1273 (:printer fp-class-0-inst
((op1 #x0c
) (op2 1) (x2 2)) '(:name
))
1275 (emit-fp-class-0-inst segment
#x0C
0 0 1 0 2 0 1 0)))
1277 (defconstant-eqx fbinops
'(:add
:sub
:mpy
:div
)
1281 `(member ,@fbinops
))
1283 (define-instruction fbinop
(segment op r1 r2 result
)
1284 (:declare
(type fbinop op
)
1285 (type tn r1 r2 result
))
1286 (:printer fp-class-0-inst
((op1 #x0C
) (op2 0) (x2 3))
1287 '('FADD fmt
:tab r
"," x1
"," t
))
1288 (:printer fp-class-0-inst
((op1 #x0C
) (op2 1) (x2 3))
1289 '('FSUB fmt
:tab r
"," x1
"," t
))
1290 (:printer fp-class-0-inst
((op1 #x0C
) (op2 2) (x2 3))
1291 '('FMPY fmt
:tab r
"," x1
"," t
))
1292 (:printer fp-class-0-inst
((op1 #x0C
) (op2 3) (x2 3))
1293 '('FDIV fmt
:tab r
"," x1
"," t
))
1295 (multiple-value-bind
1296 (r1-encoding r1-double-p
)
1297 (fp-reg-tn-encoding r1
)
1298 (multiple-value-bind
1299 (r2-encoding r2-double-p
)
1300 (fp-reg-tn-encoding r2
)
1301 (aver (eq r1-double-p r2-double-p
))
1302 (multiple-value-bind
1303 (result-encoding result-double-p
)
1304 (fp-reg-tn-encoding result
)
1305 (aver (eq r1-double-p result-double-p
))
1306 (emit-fp-class-0-inst segment
#x0C r1-encoding r2-encoding
1307 (or (position op fbinops
)
1308 (error "Bogus FBINOP: ~S" op
))
1309 (if r1-double-p
1 0) 3 0 0
1310 result-encoding
))))))
1314 ;;;; Instructions built out of other insts.
1316 (define-instruction-macro move
(src dst
&optional cond
)
1317 `(inst or
,src zero-tn
,dst
,cond
))
1319 (define-instruction-macro nop
(&optional cond
)
1320 `(inst or zero-tn zero-tn zero-tn
,cond
))
1322 (define-instruction li
(segment value reg
)
1323 (:declare
(type tn reg
)
1324 (type (or fixup
(signed-byte 32) (unsigned-byte 32)) value
))
1327 (assemble (segment vop
)
1330 (inst ldil value reg
)
1331 (inst ldo value reg reg
))
1333 (inst ldo value zero-tn reg
))
1334 ((or (signed-byte 32) (unsigned-byte 32))
1335 (let ((hi (ldb (byte 21 11) value
))
1336 (lo (ldb (byte 11 0) value
)))
1339 (inst ldo lo reg reg
))))))))
1341 (define-instruction-macro sll
(src count result
&optional cond
)
1342 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1343 `(inst zdep
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1345 (define-instruction-macro sra
(src count result
&optional cond
)
1346 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1347 `(inst extrs
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1349 (define-instruction-macro srl
(src count result
&optional cond
)
1350 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1351 `(inst extru
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1353 (defun maybe-negate-cond (cond negate
)
1355 (multiple-value-bind
1357 (compare-condition cond
)
1359 (nth value compare-conditions
)
1360 (nth (+ value
8) compare-conditions
)))
1363 (define-instruction bc
(segment cond not-p r1 r2 target
)
1364 (:declare
(type compare-condition cond
)
1365 (type (member t nil
) not-p
)
1367 (type label target
))
1370 (emit-chooser segment
8 2
1371 #'(lambda (segment posn delta
)
1372 (let ((disp (label-relative-displacement target posn delta
)))
1373 (when (<= 0 disp
(1- (ash 1 11)))
1374 (assemble (segment vop
)
1375 (inst comb
(maybe-negate-cond cond not-p
) r1 r2 target
1378 #'(lambda (segment posn
)
1379 (let ((disp (label-relative-displacement target posn
)))
1380 (assemble (segment vop
)
1381 (cond ((<= (- (ash 1 11)) disp
(1- (ash 1 11)))
1382 (inst comb
(maybe-negate-cond cond not-p
) r1 r2 target
)
1385 (inst comclr r1 r2 zero-tn
1386 (maybe-negate-cond cond
(not not-p
)))
1387 (inst b target
:nullify t
)))))))))
1389 (define-instruction bci
(segment cond not-p imm reg target
)
1390 (:declare
(type compare-condition cond
)
1391 (type (member t nil
) not-p
)
1392 (type (signed-byte 11) imm
)
1394 (type label target
))
1397 (emit-chooser segment
8 2
1398 #'(lambda (segment posn delta-if-after
)
1399 (let ((disp (label-relative-displacement target posn delta-if-after
)))
1400 (when (and (<= 0 disp
(1- (ash 1 11)))
1401 (<= (- (ash 1 4)) imm
(1- (ash 1 4))))
1402 (assemble (segment vop
)
1403 (inst comib
(maybe-negate-cond cond not-p
) imm reg target
1406 #'(lambda (segment posn
)
1407 (let ((disp (label-relative-displacement target posn
)))
1408 (assemble (segment vop
)
1409 (cond ((and (<= (- (ash 1 11)) disp
(1- (ash 1 11)))
1410 (<= (- (ash 1 4)) imm
(1- (ash 1 4))))
1411 (inst comib
(maybe-negate-cond cond not-p
) imm reg target
)
1414 (inst comiclr imm reg zero-tn
1415 (maybe-negate-cond cond
(not not-p
)))
1416 (inst b target
:nullify t
)))))))))
1419 ;;;; Instructions to convert between code ptrs, functions, and lras.
1421 (defun emit-compute-inst (segment vop src label temp dst calc
)
1423 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1425 #'(lambda (segment posn delta-if-after
)
1426 (let ((delta (funcall calc label posn delta-if-after
)))
1427 (when (<= (- (ash 1 10)) delta
(1- (ash 1 10)))
1428 (emit-back-patch segment
4
1429 #'(lambda (segment posn
)
1430 (assemble (segment vop
)
1431 (inst addi
(funcall calc label posn
0) src
1434 #'(lambda (segment posn
)
1435 (let ((delta (funcall calc label posn
0)))
1436 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1437 ;; intermediate value would be tagged but pointing into space.
1438 (assemble (segment vop
)
1439 (inst ldil
(ldb (byte 21 11) delta
) temp
)
1440 (inst ldo
(ldb (byte 11 0) delta
) temp temp
)
1441 (inst add src temp dst
))))))
1443 ;; code = fn - header - label-offset + other-pointer-tag
1444 (define-instruction compute-code-from-fn
(segment src label temp dst
)
1445 (:declare
(type tn src dst temp
)
1449 (emit-compute-inst segment vop src label temp dst
1450 #'(lambda (label posn delta-if-after
)
1451 (- other-pointer-lowtag
1452 (label-position label posn delta-if-after
)
1453 (component-header-length))))))
1455 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1456 (define-instruction compute-code-from-lra
(segment src label temp dst
)
1457 (:declare
(type tn src dst temp
)
1461 (emit-compute-inst segment vop src label temp dst
1462 #'(lambda (label posn delta-if-after
)
1463 (- (+ (label-position label posn delta-if-after
)
1464 (component-header-length)))))))
1466 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1467 (define-instruction compute-lra-from-code
(segment src label temp dst
)
1468 (:declare
(type tn src dst temp
)
1472 (emit-compute-inst segment vop src label temp dst
1473 #'(lambda (label posn delta-if-after
)
1474 (+ (label-position label posn delta-if-after
)
1475 (component-header-length))))))
1478 ;;;; Data instructions.
1480 (define-instruction byte
(segment byte
)
1482 (emit-byte segment byte
)))
1484 (define-bitfield-emitter emit-halfword
16
1487 (define-instruction halfword
(segment halfword
)
1489 (emit-halfword segment halfword
)))
1491 (define-bitfield-emitter emit-word
32
1494 (define-instruction word
(segment word
)
1496 (emit-word segment word
)))
1498 (define-instruction fun-header-word
(segment)
1502 #'(lambda (segment posn
)
1504 (logior simple-fun-header-widetag
1505 (ash (+ posn
(component-header-length))
1506 (- n-widetag-bits word-shift
))))))))
1508 (define-instruction lra-header-word
(segment)
1512 #'(lambda (segment posn
)
1514 (logior return-pc-header-widetag
1515 (ash (+ posn
(component-header-length))
1516 (- n-widetag-bits word-shift
))))))))