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.
12 (in-package "SB!HPPA-ASM")
14 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
15 ;; Imports from this package into SB-VM
16 (import '(reg-tn-encoding) 'sb
!vm
)
17 ;; Imports from SB-VM into this package
18 (import '(sb!vm
::zero sb
!vm
::registers sb
!vm
::float-registers
19 sb
!vm
::single-reg sb
!vm
::double-reg
20 sb
!vm
::complex-single-reg sb
!vm
::complex-double-reg
21 sb
!vm
::fp-single-zero sb
!vm
::fp-double-zero
23 sb
!vm
::null-offset sb
!vm
::code-offset sb
!vm
::zero-offset
)))
25 ; normally assem-scheduler-p is t, and nil if debugging the assembler
26 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 (setf *assem-scheduler-p
* nil
))
28 (setf *assem-max-locations
* 68) ; see number-location
31 ;;;; Utility functions.
33 (defun reg-tn-encoding (tn)
34 (declare (type tn tn
))
39 (aver (eq (sb-name (sc-sb (tn-sc tn
))) 'registers
))
42 (defun fp-reg-tn-encoding (tn)
43 (declare (type tn tn
))
45 (fp-single-zero (values 0 nil
))
46 (single-reg (values (tn-offset tn
) nil
))
47 (fp-double-zero (values 0 t
))
48 (double-reg (values (tn-offset tn
) t
))
49 (complex-single-reg (values (tn-offset tn
) nil
))
50 (complex-double-reg (values (tn-offset tn
) t
))))
52 (defconstant-eqx compare-conditions
53 '(:never
:= :< :<= :<< :<<= :sv
:od
:tr
:<> :>= :> :>>= :>> :nsv
:ev
)
56 (deftype compare-condition
()
57 `(member nil
,@compare-conditions
))
59 (defun compare-condition (cond)
60 (declare (type compare-condition cond
))
62 (let ((result (or (position cond compare-conditions
:test
#'eq
)
63 (error "Bogus Compare/Subtract condition: ~S" cond
))))
64 (values (ldb (byte 3 0) result
)
68 (defconstant-eqx add-conditions
69 '(:never
:= :< :<= :nuv
:znv
:sv
:od
:tr
:<> :>= :> :uv
:vnz
:nsv
:ev
)
72 (deftype add-condition
()
73 `(member nil
,@add-conditions
))
75 (defun add-condition (cond)
76 (declare (type add-condition cond
))
78 (let ((result (or (position cond add-conditions
:test
#'eq
)
79 (error "Bogus Add condition: ~S" cond
))))
80 (values (ldb (byte 3 0) result
)
84 (defconstant-eqx logical-conditions
85 '(:never
:= :< :<= nil nil nil
:od
:tr
:<> :>= :> nil nil nil
:ev
)
88 (deftype logical-condition
()
89 `(member nil
,@(remove nil logical-conditions
)))
91 (defun logical-condition (cond)
92 (declare (type logical-condition cond
))
94 (let ((result (or (position cond logical-conditions
:test
#'eq
)
95 (error "Bogus Logical condition: ~S" cond
))))
96 (values (ldb (byte 3 0) result
)
100 (defconstant-eqx unit-conditions
101 '(:never nil
:sbz
:shz
:sdc
:sbc
:shc
:tr nil
:nbz
:nhz
:ndc
:nbc
:nhc
)
104 (deftype unit-condition
()
105 `(member nil
,@(remove nil unit-conditions
)))
107 (defun unit-condition (cond)
108 (declare (type unit-condition cond
))
110 (let ((result (or (position cond unit-conditions
:test
#'eq
)
111 (error "Bogus Unit condition: ~S" cond
))))
112 (values (ldb (byte 3 0) result
)
116 (defconstant-eqx extract
/deposit-conditions
117 '(:never
:= :< :od
:tr
:<> :>= :ev
)
120 (deftype extract
/deposit-condition
()
121 `(member nil
,@extract
/deposit-conditions
))
123 (defun extract/deposit-condition
(cond)
124 (declare (type extract
/deposit-condition cond
))
126 (or (position cond extract
/deposit-conditions
:test
#'eq
)
127 (error "Bogus Extract/Deposit condition: ~S" cond
))
131 (defun space-encoding (space)
132 (declare (type (unsigned-byte 3) space
))
133 (dpb (ldb (byte 2 0) space
)
135 (ldb (byte 1 2) space
)))
138 ;;;; Initial disassembler setup.
140 (setf *disassem-inst-alignment-bytes
* 4)
142 (defvar *disassem-use-lisp-reg-names
* t
)
144 ; In each define-instruction the form (:dependencies ...)
145 ; contains read and write howto that passed as LOC here.
146 ; Example: (:dependencies (reads src) (writes dst) (writes temp))
147 ; src, dst and temp is passed each in loc, and can be a register
148 ; immediate or anything else.
149 ; this routine will return an location-number
150 ; this number must be less than *assem-max-locations*
151 (defun location-number (loc)
158 (ecase (sb-name (sc-sb (tn-sc loc
)))
160 ;; Can happen if $ZERO or $NULL are passed in.
163 (unless (zerop (tn-offset loc
))
169 (defparameter reg-symbols
172 (cond ((null name
) nil
)
173 (t (make-symbol (concatenate 'string
"$" name
)))))
174 sb
!vm
::*register-names
*))
177 :printer
(lambda (value stream dstate
)
178 (declare (stream stream
) (fixnum value
))
179 (let ((regname (aref reg-symbols value
)))
180 (princ regname stream
)
181 (maybe-note-associated-storage-ref
187 (defparameter float-reg-symbols
189 (loop for n from
0 to
31 collect
(make-symbol (format nil
"$F~d" n
)))
192 (define-arg-type fp-reg
193 :printer
(lambda (value stream dstate
)
194 (declare (stream stream
) (fixnum value
))
195 (let ((regname (aref float-reg-symbols value
)))
196 (princ regname stream
)
197 (maybe-note-associated-storage-ref
203 (define-arg-type fp-fmt-0c
204 :printer
(lambda (value stream dstate
)
205 (declare (ignore dstate
) (stream stream
) (fixnum value
))
207 (0 (format stream
"~A" '\
,SGL
))
208 (1 (format stream
"~A" '\
,DBL
))
209 (3 (format stream
"~A" '\
,QUAD
)))))
211 (defun low-sign-extend (x n
)
212 (let ((normal (dpb x
(byte 1 (1- n
)) (ldb (byte (1- n
) 1) x
))))
214 (logior (ash -
1 (1- n
)) normal
)
217 (defun assemble-bits (x list
)
220 (dolist (e (reverse list
))
221 (setf result
(logior result
(ash (ldb e x
) offset
)))
222 (incf offset
(byte-size e
)))
225 (macrolet ((define-imx-decode (name bits
)
226 `(define-arg-type ,name
227 :printer
(lambda (value stream dstate
)
228 (declare (ignore dstate
) (stream stream
) (fixnum value
))
229 (format stream
"~S" (low-sign-extend value
,bits
))))))
230 (define-imx-decode im5
5)
231 (define-imx-decode im11
11)
232 (define-imx-decode im14
14))
235 :printer
(lambda (value stream dstate
)
236 (declare (ignore dstate
) (stream stream
) (fixnum value
))
237 (format stream
"~S" (assemble-bits value
`(,(byte 1 0)
240 (define-arg-type im21
241 :printer
(lambda (value stream dstate
)
242 (declare (ignore dstate
) (stream stream
) (fixnum value
))
244 (assemble-bits value
`(,(byte 1 0) ,(byte 11 1)
245 ,(byte 2 14) ,(byte 5 16)
249 :printer
(lambda (value stream dstate
)
250 (declare (ignore dstate
) (stream stream
) (fixnum value
))
251 (format stream
"~S" (- 31 value
))))
253 (define-arg-type clen
254 :printer
(lambda (value stream dstate
)
255 (declare (ignore dstate
) (stream stream
) (fixnum value
))
256 (format stream
"~S" (- 32 value
))))
258 (define-arg-type compare-condition
259 :printer
#("" \
,= \
,< \
,<= \
,<< \
,<<= \
,SV \
,OD \
,TR \
,<> \
,>=
260 \
,> \
,>>= \
,>> \
,NSV \
,EV
))
262 (define-arg-type compare-condition-false
263 :printer
#(\
,TR \
,<> \
,>= \
,> \
,>>= \
,>> \
,NSV \
,EV
264 "" \
,= \
,< \
,<= \
,<< \
,<<= \
,SV \
,OD
))
266 (define-arg-type add-condition
267 :printer
#("" \
,= \
,< \
,<= \
,NUV \
,ZNV \
,SV \
,OD \
,TR \
,<> \
,>= \
,> \
,UV
270 (define-arg-type add-condition-false
271 :printer
#(\
,TR \
,<> \
,>= \
,> \
,UV \
,VNZ \
,NSV \
,EV
272 "" \
,= \
,< \
,<= \
,NUV \
,ZNV \
,SV \
,OD
))
274 (define-arg-type logical-condition
275 :printer
#("" \
,= \
,< \
,<= "" "" "" \
,OD \
,TR \
,<> \
,>= \
,> "" "" "" \
,EV
))
277 (define-arg-type unit-condition
278 :printer
#("" "" \
,SBZ \
,SHZ \
,SDC \
,SBC \
,SHC \
,TR
"" \
,NBZ \
,NHZ \
,NDC
281 (define-arg-type extract
/deposit-condition
282 :printer
#("" \
,= \
,< \
,OD \
,TR \
,<> \
,>= \
,EV
))
284 (define-arg-type extract
/deposit-condition-false
285 :printer
#(\
,TR \
,<> \
,>= \
,EV
"" \
,= \
,< \
,OD
))
287 (define-arg-type nullify
290 (define-arg-type fcmp-cond
291 :printer
#(\FALSE? \FALSE
\? \
!<=> \
= \
=T
\?= \
!<> \
!?
>= \
< \?<
292 \
!>= \
!?
> \
<= \?<= \
!> \
!?
<= \
> \?>\ \
!<= \
!?
< \
>=
293 \?>= \
!< \
!?
= \
<> \
!= \
!=T \
!? \
<=> \TRUE? \TRUE
))
295 (define-arg-type integer
296 :printer
(lambda (value stream dstate
)
297 (declare (ignore dstate
) (stream stream
) (fixnum value
))
298 (format stream
"~S" value
)))
300 (define-arg-type space
301 :printer
#("" |
1,| |
2,| |
3,|
))
303 (define-arg-type memory-address-annotation
304 :printer
(lambda (value stream dstate
)
305 (declare (ignore stream
))
306 (destructuring-bind (reg raw-offset
) value
307 (let ((offset (low-sign-extend raw-offset
14)))
310 (note-code-constant offset dstate
))
312 (maybe-note-nil-indexed-object offset dstate
)))))))
315 ;;;; Define-instruction-formats for disassembler.
317 (define-instruction-format (load/store
32)
318 (op :field
(byte 6 26))
319 (b :field
(byte 5 21) :type
'reg
)
320 (t/r
:field
(byte 5 16) :type
'reg
)
321 (s :field
(byte 2 14) :type
'space
)
322 (im14 :field
(byte 14 0) :type
'im14
)
323 (memory-address-annotation :fields
(list (byte 5 21) (byte 14 0))
324 :type
'memory-address-annotation
))
326 (defconstant-eqx cmplt-index-print
'((:cond
((u :constant
1) '\
,S
))
327 (:cond
((m :constant
1) '\
,M
)))
330 (defconstant-eqx cmplt-disp-print
'((:cond
((m :constant
1)
331 (:cond
((s :constant
0) '\
,MA
)
335 (defconstant-eqx cmplt-store-print
'((:cond
((s :constant
0) '\
,B
)
337 (:cond
((m :constant
1) '\
,M
)))
340 (define-instruction-format (extended-load/store
32)
341 (op1 :field
(byte 6 26) :value
3)
342 (b :field
(byte 5 21) :type
'reg
)
343 (x/im5
/r
:field
(byte 5 16) :type
'reg
)
344 (s :field
(byte 2 14) :type
'space
)
345 (u :field
(byte 1 13))
346 (op2 :field
(byte 3 10))
347 (ext4/c
:field
(byte 4 6))
348 (m :field
(byte 1 5))
349 (t/im5
:field
(byte 5 0) :type
'reg
))
351 (define-instruction-format (ldil 32 :default-printer
'(:name
:tab im21
"," t
))
352 (op :field
(byte 6 26))
353 (t :field
(byte 5 21) :type
'reg
)
354 (im21 :field
(byte 21 0) :type
'im21
))
356 (define-instruction-format (branch17 32)
357 (op1 :field
(byte 6 26))
358 (t :field
(byte 5 21) :type
'reg
)
359 (w :fields
`(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
361 (lambda (value dstate
)
362 (declare (type disassem-state dstate
) (list value
))
363 (let ((x (logior (ash (first value
) 12) (ash (second value
) 1)
366 (assemble-bits x
`(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
367 ,(byte 10 2))) 17) 2)
368 (dstate-cur-addr dstate
) 8))))
369 (op2 :field
(byte 3 13))
370 (n :field
(byte 1 1) :type
'nullify
))
372 (define-instruction-format (branch12 32)
373 (op1 :field
(byte 6 26))
374 (r2 :field
(byte 5 21) :type
'reg
)
375 (r1 :field
(byte 5 16) :type
'reg
)
376 (w :fields
`(,(byte 11 2) ,(byte 1 0))
378 (lambda (value dstate
)
379 (declare (type disassem-state dstate
) (list value
))
380 (let ((x (logior (ash (first value
) 1) (second value
))))
382 (assemble-bits x
`(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
384 (dstate-cur-addr dstate
) 8))))
385 (c :field
(byte 3 13))
386 (n :field
(byte 1 1) :type
'nullify
))
388 (define-instruction-format (branch 32)
389 (op1 :field
(byte 6 26))
390 (t :field
(byte 5 21) :type
'reg
)
391 (x :field
(byte 5 16) :type
'reg
)
392 (op2 :field
(byte 3 13))
393 (x1 :field
(byte 11 2))
394 (n :field
(byte 1 1) :type
'nullify
)
395 (x2 :field
(byte 1 0)))
397 (define-instruction-format (r3-inst 32
398 :default-printer
'(:name c
:tab r1
"," r2
"," t
))
399 (r3 :field
(byte 6 26) :value
2)
400 (r2 :field
(byte 5 21) :type
'reg
)
401 (r1 :field
(byte 5 16) :type
'reg
)
402 (c :field
(byte 3 13))
403 (f :field
(byte 1 12))
404 (op :field
(byte 7 5))
405 (t :field
(byte 5 0) :type
'reg
))
407 (define-instruction-format (imm-inst 32
408 :default-printer
'(:name c
:tab im11
"," r
"," t
))
409 (op :field
(byte 6 26))
410 (r :field
(byte 5 21) :type
'reg
)
411 (t :field
(byte 5 16) :type
'reg
)
412 (c :field
(byte 3 13))
413 (f :field
(byte 1 12))
414 (o :field
(byte 1 11))
415 (im11 :field
(byte 11 0) :type
'im11
))
417 (define-instruction-format (extract/deposit-inst
32)
418 (op1 :field
(byte 6 26))
419 (r2 :field
(byte 5 21) :type
'reg
)
420 (r1 :field
(byte 5 16) :type
'reg
)
421 (c :field
(byte 3 13) :type
'extract
/deposit-condition
)
422 (op2 :field
(byte 3 10))
423 (cp :field
(byte 5 5) :type
'cp
)
424 (t/clen
:field
(byte 5 0) :type
'clen
))
426 (define-instruction-format (break 32
427 :default-printer
'(:name
:tab im13
"," im5
))
428 (op1 :field
(byte 6 26) :value
0)
429 (im13 :field
(byte 13 13))
430 (q2 :field
(byte 8 5) :value
0)
431 (im5 :field
(byte 5 0) :reader break-im5
))
433 (defun break-control (chunk inst stream dstate
)
434 (declare (ignore inst
))
435 (flet ((nt (x) (if stream
(note x dstate
))))
436 (case (break-im5 chunk dstate
)
439 (handle-break-args #'snarf-error-junk stream dstate
))
442 (handle-break-args #'snarf-error-junk stream dstate
))
444 (nt "Breakpoint trap"))
445 (#.pending-interrupt-trap
446 (nt "Pending interrupt trap"))
449 (#.fun-end-breakpoint-trap
450 (nt "Function end breakpoint trap"))
451 (#.single-step-around-trap
452 (nt "Single step around trap")))))
454 (define-instruction-format (system-inst 32)
455 (op1 :field
(byte 6 26) :value
0)
456 (r1 :field
(byte 5 21) :type
'reg
)
457 (r2 :field
(byte 5 16) :type
'reg
)
458 (s :field
(byte 3 13))
459 (op2 :field
(byte 8 5))
460 (r3 :field
(byte 5 0) :type
'reg
))
462 (define-instruction-format (fp-load/store
32)
463 (op :field
(byte 6 26))
464 (b :field
(byte 5 21) :type
'reg
)
465 (x :field
(byte 5 16) :type
'reg
)
466 (s :field
(byte 2 14) :type
'space
)
467 (u :field
(byte 1 13))
468 (x1 :field
(byte 1 12))
469 (x2 :field
(byte 2 10))
470 (x3 :field
(byte 1 9))
471 (x4 :field
(byte 3 6))
472 (m :field
(byte 1 5))
473 (t :field
(byte 5 0) :type
'fp-reg
))
475 (define-instruction-format (fp-class-0-inst 32)
476 (op1 :field
(byte 6 26))
477 (r :field
(byte 5 21) :type
'fp-reg
)
478 (x1 :field
(byte 5 16) :type
'fp-reg
)
479 (op2 :field
(byte 3 13))
480 (fmt :field
(byte 2 11) :type
'fp-fmt-0c
)
481 (x2 :field
(byte 2 9))
482 (x3 :field
(byte 3 6))
483 (x4 :field
(byte 1 5))
484 (t :field
(byte 5 0) :type
'fp-reg
))
486 (define-instruction-format (fp-class-1-inst 32)
487 (op1 :field
(byte 6 26))
488 (r :field
(byte 5 21) :type
'fp-reg
)
489 (x1 :field
(byte 4 17) :value
0)
490 (x2 :field
(byte 2 15))
491 (df :field
(byte 2 13) :type
'fp-fmt-0c
)
492 (sf :field
(byte 2 11) :type
'fp-fmt-0c
)
493 (x3 :field
(byte 2 9) :value
1)
494 (x4 :field
(byte 3 6) :value
0)
495 (x5 :field
(byte 1 5) :value
0)
496 (t :field
(byte 5 0) :type
'fp-reg
))
500 ;;;; Load and Store stuff.
502 (define-bitfield-emitter emit-load
/store
32
509 (defun encode-imm21 (segment value
)
510 (declare (type (or fixup
(signed-byte 32) (unsigned-byte 32)) value
))
511 (cond ((fixup-p value
)
512 (note-fixup segment
:hi value
)
513 (aver (or (null (fixup-offset value
)) (zerop (fixup-offset value
))))
516 (let ((hi (ldb (byte 21 11) value
)))
517 (logior (ash (ldb (byte 5 2) hi
) 16)
518 (ash (ldb (byte 2 7) hi
) 14)
519 (ash (ldb (byte 2 0) hi
) 12)
520 (ash (ldb (byte 11 9) hi
) 1)
521 (ldb (byte 1 20) hi
))))))
523 (defun encode-imm11 (value)
524 (declare (type (signed-byte 11) value
))
525 (dpb (ldb (byte 10 0) value
)
527 (ldb (byte 1 10) value
)))
529 (defun encode-imm11u (value)
530 (declare (type (or (signed-byte 32) (unsigned-byte 32)) value
))
531 (declare (type (unsigned-byte 11) value
))
532 (dpb (ldb (byte 11 0) value
)
536 (defun encode-imm14 (value)
537 (declare (type (signed-byte 14) value
))
538 (dpb (ldb (byte 13 0) value
)
540 (ldb (byte 1 13) value
)))
542 (defun encode-disp/fixup
(segment disp imm-bits
)
545 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
547 (note-fixup segment
:load11u disp
)
548 (note-fixup segment
:load disp
))
553 (encode-imm14 disp
)))))
555 ; LDO can be used in two ways: to load an 14bit-signed value
556 ; or load an 11bit-unsigned value. The latter is used for
557 ; example in an LDIL/LDO pair. The key :unsigned specifies this.
558 (macrolet ((define-load-inst (name opcode
&optional imm-bits
)
559 `(define-instruction ,name
(segment disp base reg
&key unsigned
)
560 (:declare
(type tn reg base
)
561 (type (member t nil
) unsigned
)
562 (type (or fixup
(signed-byte 14)) disp
))
564 (:printer load
/store
((op ,opcode
) (s 0))
565 '(:name
:tab im14
"(" s b
")," t
/r memory-address-annotation
))
566 (:dependencies
(reads base
) (reads :memory
) (writes reg
))
568 (emit-load/store segment
,opcode
569 (reg-tn-encoding base
) (reg-tn-encoding reg
) 0
571 (encode-disp/fixup segment disp t
)
572 (encode-disp/fixup segment disp nil
))))))
573 (define-store-inst (name opcode
&optional imm-bits
)
574 `(define-instruction ,name
(segment reg disp base
)
575 (:declare
(type tn reg base
)
576 (type (or fixup
(signed-byte 14)) disp
))
578 (:printer load
/store
((op ,opcode
) (s 0))
579 '(:name
:tab t
/r
"," im14
"(" s b
")" memory-address-annotation
))
580 (:dependencies
(reads base
) (reads reg
) (writes :memory
))
582 (emit-load/store segment
,opcode
583 (reg-tn-encoding base
) (reg-tn-encoding reg
) 0
584 (encode-disp/fixup segment disp
,imm-bits
))))))
585 (define-load-inst ldw
#x12
)
586 (define-load-inst ldh
#x11
)
587 (define-load-inst ldb
#x10
)
588 (define-load-inst ldwm
#x13
)
589 (define-load-inst ldo
#x0D
)
590 (define-store-inst stw
#x1A
)
591 (define-store-inst sth
#x19
)
592 (define-store-inst stb
#x18
)
593 (define-store-inst stwm
#x1B
))
595 (define-bitfield-emitter emit-extended-load
/store
32
596 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
597 (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
599 (macrolet ((define-load-indexed-inst (name opcode
)
600 `(define-instruction ,name
(segment index base reg
&key modify scale
)
601 (:declare
(type tn reg base index
)
602 (type (member t nil
) modify scale
))
604 (:dependencies
(reads index
) (reads base
) (writes reg
) (reads :memory
))
605 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'reg
)
607 `(:name
,@cmplt-index-print
:tab x
/im5
/r
610 (emit-extended-load/store
611 segment
#x03
(reg-tn-encoding base
) (reg-tn-encoding index
)
612 0 (if scale
1 0) 0 ,opcode
(if modify
1 0)
613 (reg-tn-encoding reg
))))))
614 (define-load-indexed-inst ldwx
2)
615 (define-load-indexed-inst ldhx
1)
616 (define-load-indexed-inst ldbx
0)
617 (define-load-indexed-inst ldcwx
7))
619 (defun short-disp-encoding (segment disp
)
620 (declare (type (or fixup
(signed-byte 5)) disp
))
621 (cond ((fixup-p disp
)
622 (note-fixup segment
:load-short disp
)
623 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
626 (dpb (ldb (byte 4 0) disp
)
628 (ldb (byte 1 4) disp
)))))
630 (macrolet ((define-load-short-inst (name opcode
)
631 `(define-instruction ,name
(segment base disp reg
&key modify
)
632 (:declare
(type tn base reg
)
633 (type (or fixup
(signed-byte 5)) disp
)
634 (type (member :before
:after nil
) modify
))
636 (:dependencies
(reads base
) (writes reg
) (reads :memory
))
637 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'im5
)
639 `(:name
,@cmplt-disp-print
:tab x
/im5
/r
646 (:after
(values 1 0))
647 (:before
(values 1 1)))
648 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
649 (short-disp-encoding segment disp
)
651 (reg-tn-encoding reg
))))))
652 (define-store-short-inst (name opcode
)
653 `(define-instruction ,name
(segment reg base disp
&key modify
)
654 (:declare
(type tn reg base
)
655 (type (or fixup
(signed-byte 5)) disp
)
656 (type (member :before
:after nil
) modify
))
658 (:dependencies
(reads base
) (reads reg
) (writes :memory
))
659 (:printer extended-load
/store
((ext4/c
,opcode
) (t/im5 nil
:type
'im5
)
661 `(:name
,@cmplt-disp-print
:tab x
/im5
/r
662 "," t
/im5
"(" s b
")"))
668 (:after
(values 1 0))
669 (:before
(values 1 1)))
670 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
671 (short-disp-encoding segment disp
)
673 (reg-tn-encoding reg
)))))))
674 (define-load-short-inst ldws
2)
675 (define-load-short-inst ldhs
1)
676 (define-load-short-inst ldbs
0)
677 (define-load-short-inst ldcws
7)
679 (define-store-short-inst stws
10)
680 (define-store-short-inst sths
9)
681 (define-store-short-inst stbs
8))
683 (define-instruction stbys
(segment reg base disp where
&key modify
)
684 (:declare
(type tn reg base
)
685 (type (signed-byte 5) disp
)
686 (type (member :begin
:end
) where
)
687 (type (member t nil
) modify
))
689 (:dependencies
(reads base
) (reads reg
) (writes :memory
))
690 (:printer extended-load
/store
((ext4/c
#xC
) (t/im5 nil
:type
'im5
) (op2 4))
691 `(:name
,@cmplt-store-print
:tab x
/im5
/r
"," t
/im5
"(" s b
")"))
693 (emit-extended-load/store segment
#x03
(reg-tn-encoding base
)
694 (reg-tn-encoding reg
) 0
695 (ecase where
(:begin
0) (:end
1))
696 4 #xC
(if modify
1 0)
697 (short-disp-encoding segment disp
))))
700 ;;;; Immediate 21-bit Instructions.
701 ;;; Note the heavy scrambling of the immediate value to instruction memory
703 (define-bitfield-emitter emit-imm21
32
708 (define-instruction ldil
(segment value reg
)
709 (:declare
(type tn reg
)
710 (type (or (signed-byte 32) (unsigned-byte 32) fixup
) value
))
712 (:dependencies
(writes reg
))
713 (:printer ldil
((op #x08
)))
715 (emit-imm21 segment
#x08
(reg-tn-encoding reg
)
716 (encode-imm21 segment value
))))
718 ; this one overwrites number stack ?
719 (define-instruction addil
(segment value reg
)
720 (:declare
(type tn reg
)
721 (type (or (signed-byte 32) (unsigned-byte 32) fixup
) value
))
723 (:dependencies
(writes reg
))
724 (:printer ldil
((op #x0A
)))
726 (emit-imm21 segment
#x0A
(reg-tn-encoding reg
)
727 (encode-imm21 segment value
))))
730 ;;;; Branch instructions.
732 (define-bitfield-emitter emit-branch
32
733 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
734 (byte 11 2) (byte 1 1) (byte 1 0))
736 (defun label-relative-displacement (label posn
&optional delta-if-after
)
737 (declare (type label label
) (type index posn
))
738 (ash (- (if delta-if-after
739 (label-position label posn delta-if-after
)
740 (label-position label
))
743 (defun decompose-branch-disp (segment disp
)
744 (declare (type (or fixup
(signed-byte 17)) disp
))
745 (cond ((fixup-p disp
)
746 (note-fixup segment
:branch disp
)
747 (aver (or (null (fixup-offset disp
)) (zerop (fixup-offset disp
))))
750 (values (ldb (byte 5 11) disp
)
751 (dpb (ldb (byte 10 0) disp
)
753 (ldb (byte 1 10) disp
))
754 (ldb (byte 1 16) disp
)))))
756 (defun emit-relative-branch (segment opcode link sub-opcode target nullify
)
757 (declare (type (unsigned-byte 6) opcode
)
758 (type (unsigned-byte 5) link
)
759 (type (unsigned-byte 1) sub-opcode
)
761 (type (member t nil
) nullify
))
762 (emit-back-patch segment
4
763 (lambda (segment posn
)
764 (let ((disp (label-relative-displacement target posn
)))
765 (aver (typep disp
'(signed-byte 17)))
768 (decompose-branch-disp segment disp
)
769 (emit-branch segment opcode link w1 sub-opcode w2
770 (if nullify
1 0) w
))))))
772 (define-instruction b
(segment target
&key nullify
)
773 (:declare
(type label target
) (type (member t nil
) nullify
))
776 (emit-relative-branch segment
#x3A
0 0 target nullify
)))
778 (define-instruction bl
(segment target reg
&key nullify
)
779 (:declare
(type tn reg
) (type label target
) (type (member t nil
) nullify
))
780 (:printer branch17
((op1 #x3A
) (op2 0)) '(:name n
:tab w
"," t
))
782 (:dependencies
(writes reg
))
784 (emit-relative-branch segment
#x3A
(reg-tn-encoding reg
) 0 target nullify
)))
786 (define-instruction gateway
(segment target reg
&key nullify
)
787 (:declare
(type tn reg
) (type label target
) (type (member t nil
) nullify
))
788 (:printer branch17
((op1 #x3A
) (op2 1)) '(:name n
:tab w
"," t
))
790 (:dependencies
(writes reg
))
792 (emit-relative-branch segment
#x3A
(reg-tn-encoding reg
) 1 target nullify
)))
794 ;;; BLR is useless because we have no way to generate the offset.
796 (define-instruction bv
(segment base
&key nullify offset
)
797 (:declare
(type tn base
)
798 (type (member t nil
) nullify
)
799 (type (or tn null
) offset
))
801 (:dependencies
(reads base
))
802 (:printer branch
((op1 #x3A
) (op2 6)) '(:name n
:tab x
"(" t
")"))
804 (emit-branch segment
#x3A
(reg-tn-encoding base
)
805 (if offset
(reg-tn-encoding offset
) 0)
806 6 0 (if nullify
1 0) 0)))
808 (define-instruction be
(segment disp space base
&key nullify
)
809 (:declare
(type (or fixup
(signed-byte 17)) disp
)
811 (type (unsigned-byte 3) space
)
812 (type (member t nil
) nullify
))
814 (:dependencies
(reads base
))
815 (:printer branch17
((op1 #x38
) (op2 nil
:type
'im3
))
816 '(:name n
:tab w
"(" op2
"," t
")"))
820 (decompose-branch-disp segment disp
)
821 (emit-branch segment
#x38
(reg-tn-encoding base
) w1
822 (space-encoding space
) w2
(if nullify
1 0) w
))))
824 (define-instruction ble
(segment disp space base
&key nullify
)
825 (:declare
(type (or fixup
(signed-byte 17)) disp
)
827 (type (unsigned-byte 3) space
)
828 (type (member t nil
) nullify
))
830 (:dependencies
(reads base
))
831 (:printer branch17
((op1 #x39
) (op2 nil
:type
'im3
))
832 '(:name n
:tab w
"(" op2
"," t
")"))
833 (:dependencies
(writes lip-tn
))
837 (decompose-branch-disp segment disp
)
838 (emit-branch segment
#x39
(reg-tn-encoding base
) w1
839 (space-encoding space
) w2
(if nullify
1 0) w
))))
841 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify
)
842 (emit-back-patch segment
4
843 (lambda (segment posn
)
844 (let ((disp (label-relative-displacement target posn
)))
845 ; emit-conditional-branch is used by instruction emitters: MOVB, COMB, ADDB and BB
846 ; which assembles an immediate of total 12 bits (including sign bit).
847 (aver (typep disp
'(signed-byte 12)))
848 (let ((w1 (logior (ash (ldb (byte 10 0) disp
) 1)
849 (ldb (byte 1 10) disp
)))
850 (w (ldb (byte 1 11) disp
))) ; take out the sign bit
851 (emit-branch segment opcode r2 r1 cond w1
(if nullify
1 0) w
))))))
853 (defun im5-encoding (value)
854 (declare (type (signed-byte 5) value
)
855 #+nil
(values (unsigned-byte 5)))
856 (dpb (ldb (byte 4 0) value
)
858 (ldb (byte 1 4) value
)))
860 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
862 (let* ((conditional (symbolicate cond-kind
"-CONDITION"))
863 (false-conditional (symbolicate conditional
"-FALSE")))
865 (define-instruction ,r-name
(segment cond r1 r2 target
&key nullify
)
866 (:declare
(type ,conditional cond
)
869 (type (member t nil
) nullify
))
873 '((:dependencies
(reads r1
) (reads r2
) (writes r2
))))
877 '((:dependencies
(reads r1
) (reads r2
)))))
879 ; '((:dependencies (reads r1) (reads r2) (writes r2)))
880 ; '((:dependencies (reads r1) (reads r2))))
881 (:printer branch12
((op1 ,r-opcode
) (c nil
:type
',conditional
))
882 '(:name c n
:tab r1
"," r2
"," w
))
883 ,@(unless (= r-opcode
#x32
)
884 `((:printer branch12
((op1 ,(+ 2 r-opcode
))
885 (c nil
:type
',false-conditional
))
886 '(:name c n
:tab r1
"," r2
"," w
))))
889 (cond-encoding false
)
891 (emit-conditional-branch
892 segment
(if false
,(+ r-opcode
2) ,r-opcode
)
893 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
894 cond-encoding target nullify
))))
895 (define-instruction ,i-name
(segment cond imm reg target
&key nullify
)
896 (:declare
(type ,conditional cond
)
897 (type (signed-byte 5) imm
)
899 (type (member t nil
) nullify
))
902 ; '((:dependencies (reads reg) (writes reg)))
903 ; '((:dependencies (reads reg))))
906 '((:dependencies
(reads r1
) (reads r2
) (writes r2
))))
910 '((:dependencies
(reads r1
) (reads r2
)))))
911 (:printer branch12
((op1 ,i-opcode
) (r1 nil
:type
'im5
)
912 (c nil
:type
',conditional
))
913 '(:name c n
:tab r1
"," r2
"," w
))
914 ,@(unless (= r-opcode
#x32
)
915 `((:printer branch12
((op1 ,(+ 2 i-opcode
)) (r1 nil
:type
'im5
)
916 (c nil
:type
',false-conditional
))
917 '(:name c n
:tab r1
"," r2
"," w
))))
920 (cond-encoding false
)
922 (emit-conditional-branch
923 segment
(if false
(+ ,i-opcode
2) ,i-opcode
)
924 (reg-tn-encoding reg
) (im5-encoding imm
)
925 cond-encoding target nullify
))))))))
926 (define-branch-inst movb
#x32 movib
#x33 extract
/deposit
:write-reg
)
927 (define-branch-inst comb
#x20 comib
#x21 compare
:pinned
)
928 (define-branch-inst addb
#x28 addib
#x29 add
:write-reg
))
930 (define-instruction bb
(segment cond reg posn target
&key nullify
)
931 (:declare
(type (member t nil
) cond nullify
)
933 (type (or (member :variable
) (unsigned-byte 5)) posn
))
935 (:dependencies
(reads reg
))
936 (:printer branch12
((op1 30) (c nil
:type
'extract
/deposit-condition
))
937 '('BVB c n
:tab r1
"," w
))
940 (opcode posn-encoding
)
941 (if (eq posn
:variable
)
944 (emit-conditional-branch segment opcode posn-encoding
945 (reg-tn-encoding reg
)
946 (if cond
2 6) target nullify
))))
949 ;;;; Computation Instructions
951 (define-bitfield-emitter emit-r3-inst
32
952 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
953 (byte 1 12) (byte 7 5) (byte 5 0))
955 (macrolet ((define-r3-inst (name cond-kind opcode
&optional pinned
)
956 `(define-instruction ,name
(segment r1 r2 res
&optional cond
)
957 (:declare
(type tn res r1 r2
))
961 '((:dependencies
(reads r1
) (reads r2
) (writes res
))))
962 (:printer r3-inst
((op ,opcode
) (c nil
:type
',(symbolicate
965 ,@(when (eq name
'or
)
966 `((:printer r3-inst
((op ,opcode
) (r2 0)
967 (c nil
:type
',(symbolicate cond-kind
969 `('COPY
:tab r1
"," t
))))
973 (,(symbolicate cond-kind
"-CONDITION") cond
)
974 (emit-r3-inst segment
#x02
(reg-tn-encoding r2
) (reg-tn-encoding r1
)
975 cond
(if false
1 0) ,opcode
976 (reg-tn-encoding res
)))))))
977 (define-r3-inst add add
#x30
)
978 (define-r3-inst addl add
#x50
)
979 (define-r3-inst addo add
#x70
)
980 (define-r3-inst addc add
#x38
)
981 (define-r3-inst addco add
#x78
)
982 (define-r3-inst sh1add add
#x32
)
983 (define-r3-inst sh1addl add
#x52
)
984 (define-r3-inst sh1addo add
#x72
)
985 (define-r3-inst sh2add add
#x34
)
986 (define-r3-inst sh2addl add
#x54
)
987 (define-r3-inst sh2addo add
#x74
)
988 (define-r3-inst sh3add add
#x36
)
989 (define-r3-inst sh3addl add
#x56
)
990 (define-r3-inst sh3addo add
#x76
)
991 (define-r3-inst sub compare
#x20
)
992 (define-r3-inst subo compare
#x60
)
993 (define-r3-inst subb compare
#x28
)
994 (define-r3-inst subbo compare
#x68
)
995 (define-r3-inst subt compare
#x26
)
996 (define-r3-inst subto compare
#x66
)
997 (define-r3-inst ds compare
#x22
)
998 (define-r3-inst comclr compare
#x44
)
999 (define-r3-inst or logical
#x12 t
) ; as a nop it must be pinned
1000 (define-r3-inst xor logical
#x14
)
1001 (define-r3-inst and logical
#x10
)
1002 (define-r3-inst andcm logical
#x00
)
1003 (define-r3-inst uxor unit
#x1C
)
1004 (define-r3-inst uaddcm unit
#x4C
)
1005 (define-r3-inst uaddcmt unit
#x4E
)
1006 (define-r3-inst dcor unit
#x5C
)
1007 (define-r3-inst idcor unit
#x5E
))
1009 (define-bitfield-emitter emit-imm-inst
32
1010 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1011 (byte 1 12) (byte 1 11) (byte 11 0))
1013 (macrolet ((define-imm-inst (name cond-kind opcode subcode
&optional pinned
)
1014 `(define-instruction ,name
(segment imm src dst
&optional cond
)
1015 (:declare
(type tn dst src
)
1016 (type (signed-byte 11) imm
))
1018 (:printer imm-inst
((op ,opcode
) (o ,subcode
)
1020 ',(symbolicate cond-kind
"-CONDITION"))))
1021 (:dependencies
(reads imm
) (reads src
) (writes dst
))
1023 (multiple-value-bind (cond false
)
1024 (,(symbolicate cond-kind
"-CONDITION") cond
)
1025 (emit-imm-inst segment
,opcode
(reg-tn-encoding src
)
1026 (reg-tn-encoding dst
) cond
1027 (if false
1 0) ,subcode
1028 (encode-imm11 imm
)))))))
1029 (define-imm-inst addi add
#x2D
0)
1030 (define-imm-inst addio add
#x2D
1)
1031 (define-imm-inst addit add
#x2C
0)
1032 (define-imm-inst addito add
#x2C
1)
1033 (define-imm-inst subi compare
#x25
0)
1034 (define-imm-inst subio compare
#x25
1)
1035 (define-imm-inst comiclr compare
#x24
0))
1037 (define-bitfield-emitter emit-extract
/deposit-inst
32
1038 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1039 (byte 3 10) (byte 5 5) (byte 5 0))
1041 (define-instruction shd
(segment r1 r2 count res
&optional cond
)
1042 (:declare
(type tn res r1 r2
)
1043 (type (or (member :variable
) (integer 0 31)) count
))
1046 (:printer extract
/deposit-inst
((op1 #x34
) (op2 2) (t/clen nil
:type
'reg
))
1047 '(:name c
:tab r1
"," r2
"," cp
"," t
/clen
))
1048 (:printer extract
/deposit-inst
((op1 #x34
) (op2 0) (t/clen nil
:type
'reg
))
1049 '('VSHD c
:tab r1
"," r2
"," t
/clen
))
1053 (emit-extract/deposit-inst segment
#x34
1054 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
1055 (extract/deposit-condition cond
)
1056 0 0 (reg-tn-encoding res
)))
1058 (emit-extract/deposit-inst segment
#x34
1059 (reg-tn-encoding r2
) (reg-tn-encoding r1
)
1060 (extract/deposit-condition cond
)
1062 (reg-tn-encoding res
))))))
1064 (macrolet ((define-extract-inst (name opcode
)
1065 `(define-instruction ,name
(segment src posn len res
&optional cond
)
1066 (:declare
(type tn res src
)
1067 (type (or (member :variable
) (integer 0 31)) posn
)
1068 (type (integer 1 32) len
))
1070 (:dependencies
(reads src
) (writes res
))
1071 (:printer extract
/deposit-inst
((op1 #x34
) (cp nil
:type
'integer
)
1073 '(:name c
:tab r2
"," cp
"," t
/clen
"," r1
))
1074 (:printer extract
/deposit-inst
((op1 #x34
) (op2 ,(- opcode
2)))
1075 '('V
:name c
:tab r2
"," t
/clen
"," r1
))
1079 (emit-extract/deposit-inst segment
#x34
(reg-tn-encoding src
)
1080 (reg-tn-encoding res
)
1081 (extract/deposit-condition cond
)
1082 ,(- opcode
2) 0 (- 32 len
)))
1084 (emit-extract/deposit-inst segment
#x34
(reg-tn-encoding src
)
1085 (reg-tn-encoding res
)
1086 (extract/deposit-condition cond
)
1087 ,opcode posn
(- 32 len
))))))))
1088 (define-extract-inst extru
6)
1089 (define-extract-inst extrs
7))
1091 (macrolet ((define-deposit-inst (name opcode
)
1092 `(define-instruction ,name
(segment src posn len res
&optional cond
)
1093 (:declare
(type tn res
)
1094 (type (or tn
(signed-byte 5)) src
)
1095 (type (or (member :variable
) (integer 0 31)) posn
)
1096 (type (integer 1 32) len
))
1098 (:dependencies
(reads src
) (writes res
))
1099 (:printer extract
/deposit-inst
((op1 #x35
) (op2 ,opcode
))
1100 ',(let ((base '('VDEP c
:tab r1
"," t
/clen
"," r2
)))
1101 (if (= opcode
0) (cons ''Z base
) base
)))
1102 (:printer extract
/deposit-inst
((op1 #x35
) (op2 ,(+ 2 opcode
)))
1103 ',(let ((base '('DEP c
:tab r1
"," cp
"," t
/clen
"," r2
)))
1104 (if (= opcode
0) (cons ''Z base
) base
)))
1105 (:printer extract
/deposit-inst
((op1 #x35
) (r1 nil
:type
'im5
)
1106 (op2 ,(+ 4 opcode
)))
1107 ',(let ((base '('VDEPI c
:tab r1
"," t
/clen
"," r2
)))
1108 (if (= opcode
0) (cons ''Z base
) base
)))
1109 (:printer extract
/deposit-inst
((op1 #x35
) (r1 nil
:type
'im5
)
1110 (op2 ,(+ 6 opcode
)))
1111 ',(let ((base '('DEPI c
:tab r1
"," cp
"," t
/clen
"," r2
)))
1112 (if (= opcode
0) (cons ''Z base
) base
)))
1114 (multiple-value-bind
1115 (opcode src-encoding
)
1118 (values ,opcode
(reg-tn-encoding src
)))
1120 (values ,(+ opcode
4) (im5-encoding src
))))
1121 (multiple-value-bind
1122 (opcode posn-encoding
)
1127 (values (+ opcode
2) (- 31 posn
))))
1128 (emit-extract/deposit-inst segment
#x35
(reg-tn-encoding res
)
1130 (extract/deposit-condition cond
)
1131 opcode posn-encoding
(- 32 len
))))))))
1133 (define-deposit-inst dep
1)
1134 (define-deposit-inst zdep
0))
1138 ;;;; System Control Instructions.
1140 (define-bitfield-emitter emit-break
32
1141 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1143 (define-instruction break
(segment &optional
(im5 0) (im13 0))
1144 (:declare
(type (unsigned-byte 13) im13
)
1145 (type (unsigned-byte 5) im5
))
1149 (:printer break
() :default
:control
#'break-control
)
1151 (emit-break segment
0 im13
0 im5
)))
1153 (define-bitfield-emitter emit-system-inst
32
1154 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1156 (define-instruction ldsid
(segment res base
&optional
(space 0))
1157 (:declare
(type tn res base
)
1158 (type (integer 0 3) space
))
1161 (:printer system-inst
((op2 #x85
) (c nil
:type
'space
)
1162 (s nil
:printer
#(0 0 1 1 2 2 3 3)))
1163 `(:name
:tab
"(" s r1
")," r3
))
1165 (emit-system-inst segment
0 (reg-tn-encoding base
) 0 (ash space
1) #x85
1166 (reg-tn-encoding res
))))
1168 (define-instruction mtsp
(segment reg space
)
1169 (:declare
(type tn reg
) (type (integer 0 7) space
))
1172 (:printer system-inst
((op2 #xC1
)) '(:name
:tab r2
"," s
))
1174 (emit-system-inst segment
0 0 (reg-tn-encoding reg
) (space-encoding space
)
1177 (define-instruction mfsp
(segment space reg
)
1178 (:declare
(type tn reg
) (type (integer 0 7) space
))
1181 (:printer system-inst
((op2 #x25
) (c nil
:type
'space
)) '(:name
:tab s r3
))
1183 (emit-system-inst segment
0 0 0 (space-encoding space
) #x25
1184 (reg-tn-encoding reg
))))
1186 (deftype control-reg
()
1187 '(or (unsigned-byte 5) (member :sar
)))
1189 (defun control-reg (reg)
1190 (declare (type control-reg reg
)
1191 #+nil
(values (unsigned-byte 32)))
1192 (if (typep reg
'(unsigned-byte 5))
1197 (define-instruction mtctl
(segment reg ctrl-reg
)
1198 (:declare
(type tn reg
) (type control-reg ctrl-reg
))
1201 (:printer system-inst
((op2 #xC2
)) '(:name
:tab r2
"," r1
))
1203 (emit-system-inst segment
0 (control-reg ctrl-reg
) (reg-tn-encoding reg
)
1206 (define-instruction mfctl
(segment ctrl-reg reg
)
1207 (:declare
(type tn reg
) (type control-reg ctrl-reg
))
1210 (:printer system-inst
((op2 #x45
)) '(:name
:tab r1
"," r3
))
1212 (emit-system-inst segment
0 (control-reg ctrl-reg
) 0 0 #x45
1213 (reg-tn-encoding reg
))))
1217 ;;;; Floating point instructions.
1219 (define-bitfield-emitter emit-fp-load
/store
32
1220 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1221 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1223 (define-instruction fldx
(segment index base result
&key modify scale side
)
1224 (:declare
(type tn index base result
)
1225 (type (member t nil
) modify scale
)
1226 (type (member nil
0 1) side
))
1229 (:printer fp-load
/store
((op #x0b
) (x1 0) (x2 0) (x3 0))
1230 `('FLDD
,@cmplt-index-print
:tab x
"(" s b
")" "," t
))
1231 (:printer fp-load
/store
((op #x09
) (x1 0) (x2 0) (x3 0))
1232 `('FLDW
,@cmplt-index-print
:tab x
"(" s b
")" "," t
))
1234 (multiple-value-bind
1235 (result-encoding double-p
)
1236 (fp-reg-tn-encoding result
)
1239 (setf double-p nil
))
1240 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1241 (reg-tn-encoding index
) 0 (if scale
1 0) 0 0 0
1242 (or side
0) (if modify
1 0) result-encoding
))))
1244 (define-instruction fstx
(segment value index base
&key modify scale side
)
1245 (:declare
(type tn index base value
)
1246 (type (member t nil
) modify scale
)
1247 (type (member nil
0 1) side
))
1250 (:printer fp-load
/store
((op #x0b
) (x1 0) (x2 0) (x3 1))
1251 `('FSTD
,@cmplt-index-print
:tab t
"," x
"(" s b
")"))
1252 (:printer fp-load
/store
((op #x09
) (x1 0) (x2 0) (x3 1))
1253 `('FSTW
,@cmplt-index-print
:tab t
"," x
"(" s b
")"))
1255 (multiple-value-bind
1256 (value-encoding double-p
)
1257 (fp-reg-tn-encoding value
)
1260 (setf double-p nil
))
1261 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1262 (reg-tn-encoding index
) 0 (if scale
1 0) 0 0 1
1263 (or side
0) (if modify
1 0) value-encoding
))))
1265 (define-instruction flds
(segment disp base result
&key modify side
)
1266 (:declare
(type tn base result
)
1267 (type (signed-byte 5) disp
)
1268 (type (member :before
:after nil
) modify
)
1269 (type (member nil
0 1) side
))
1272 (:printer fp-load
/store
((op #x0b
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 0))
1273 `('FLDD
,@cmplt-disp-print
:tab x
"(" s b
")," t
))
1274 (:printer fp-load
/store
((op #x09
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 0))
1275 `('FLDW
,@cmplt-disp-print
:tab x
"(" s b
")," t
))
1277 (multiple-value-bind
1278 (result-encoding double-p
)
1279 (fp-reg-tn-encoding result
)
1282 (setf double-p nil
))
1283 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1284 (short-disp-encoding segment disp
) 0
1285 (if (eq modify
:before
) 1 0) 1 0 0
1286 (or side
0) (if modify
1 0) result-encoding
))))
1288 (define-instruction fsts
(segment value disp base
&key modify side
)
1289 (:declare
(type tn base value
)
1290 (type (signed-byte 5) disp
)
1291 (type (member :before
:after nil
) modify
)
1292 (type (member nil
0 1) side
))
1295 (:printer fp-load
/store
((op #x0b
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 1))
1296 `('FSTD
,@cmplt-disp-print
:tab t
"," x
"(" s b
")"))
1297 (:printer fp-load
/store
((op #x09
) (x nil
:type
'im5
) (x1 1) (x2 0) (x3 1))
1298 `('FSTW
,@cmplt-disp-print
:tab t
"," x
"(" s b
")"))
1300 (multiple-value-bind
1301 (value-encoding double-p
)
1302 (fp-reg-tn-encoding value
)
1305 (setf double-p nil
))
1306 (emit-fp-load/store segment
(if double-p
#x0B
#x09
) (reg-tn-encoding base
)
1307 (short-disp-encoding segment disp
) 0
1308 (if (eq modify
:before
) 1 0) 1 0 1
1309 (or side
0) (if modify
1 0) value-encoding
))))
1312 (define-bitfield-emitter emit-fp-class-0-inst
32
1313 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1314 (byte 3 6) (byte 1 5) (byte 5 0))
1316 (define-bitfield-emitter emit-fp-class-1-inst
32
1317 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1318 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1320 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1321 ;;; seperate emitters.
1323 (defconstant-eqx funops
'(:copy
:abs
:sqrt
:rnd
)
1329 (define-instruction funop
(segment op from to
)
1330 (:declare
(type funop op
)
1334 (:printer fp-class-0-inst
((op1 #x0C
) (op2 2) (x2 0))
1335 '('FCPY fmt
:tab r
"," t
))
1336 (:printer fp-class-0-inst
((op1 #x0C
) (op2 3) (x2 0))
1337 '('FABS fmt
:tab r
"," t
))
1338 (:printer fp-class-0-inst
((op1 #x0C
) (op2 4) (x2 0))
1339 '('FSQRT fmt
:tab r
"," t
))
1340 (:printer fp-class-0-inst
((op1 #x0C
) (op2 5) (x2 0))
1341 '('FRND fmt
:tab r
"," t
))
1343 (multiple-value-bind
1344 (from-encoding from-double-p
)
1345 (fp-reg-tn-encoding from
)
1346 (multiple-value-bind
1347 (to-encoding to-double-p
)
1348 (fp-reg-tn-encoding to
)
1349 (aver (eq from-double-p to-double-p
))
1350 (emit-fp-class-0-inst segment
#x0C from-encoding
0
1351 (+ 2 (or (position op funops
)
1352 (error "Bogus FUNOP: ~S" op
)))
1353 (if to-double-p
1 0) 0 0 0 to-encoding
)))))
1355 (macrolet ((define-class-1-fp-inst (name subcode
)
1356 `(define-instruction ,name
(segment from to
)
1357 (:declare
(type tn from to
))
1359 (:printer fp-class-1-inst
((op1 #x0C
) (x2 ,subcode
))
1360 '(:name sf df
:tab r
"," t
))
1362 (multiple-value-bind
1363 (from-encoding from-double-p
)
1364 (fp-reg-tn-encoding from
)
1365 (multiple-value-bind
1366 (to-encoding to-double-p
)
1367 (fp-reg-tn-encoding to
)
1368 (emit-fp-class-1-inst segment
#x0C from-encoding
0 ,subcode
1369 (if to-double-p
1 0) (if from-double-p
1 0)
1370 1 0 0 to-encoding
)))))))
1372 (define-class-1-fp-inst fcnvff
0)
1373 (define-class-1-fp-inst fcnvxf
1)
1374 (define-class-1-fp-inst fcnvfx
2)
1375 (define-class-1-fp-inst fcnvfxt
3))
1377 (define-instruction fcmp
(segment cond r1 r2
)
1378 (:declare
(type (unsigned-byte 5) cond
)
1382 (:printer fp-class-0-inst
((op1 #x0C
) (op2 0) (x2 2) (t nil
:type
'fcmp-cond
))
1383 '(:name fmt t
:tab r
"," x1
))
1385 (multiple-value-bind
1386 (r1-encoding r1-double-p
)
1387 (fp-reg-tn-encoding r1
)
1388 (multiple-value-bind
1389 (r2-encoding r2-double-p
)
1390 (fp-reg-tn-encoding r2
)
1391 (aver (eq r1-double-p r2-double-p
))
1392 (emit-fp-class-0-inst segment
#x0C r1-encoding r2-encoding
0
1393 (if r1-double-p
1 0) 2 0 0 cond
)))))
1395 (define-instruction ftest
(segment)
1398 (:printer fp-class-0-inst
((op1 #x0c
) (op2 1) (x2 2)) '(:name
))
1400 (emit-fp-class-0-inst segment
#x0C
0 0 1 0 2 0 1 0)))
1402 (defconstant-eqx fbinops
'(:add
:sub
:mpy
:div
)
1406 `(member ,@fbinops
))
1408 (define-instruction fbinop
(segment op r1 r2 result
)
1409 (:declare
(type fbinop op
)
1410 (type tn r1 r2 result
))
1413 (:printer fp-class-0-inst
((op1 #x0C
) (op2 0) (x2 3))
1414 '('FADD fmt
:tab r
"," x1
"," t
))
1415 (:printer fp-class-0-inst
((op1 #x0C
) (op2 1) (x2 3))
1416 '('FSUB fmt
:tab r
"," x1
"," t
))
1417 (:printer fp-class-0-inst
((op1 #x0C
) (op2 2) (x2 3))
1418 '('FMPY fmt
:tab r
"," x1
"," t
))
1419 (:printer fp-class-0-inst
((op1 #x0C
) (op2 3) (x2 3))
1420 '('FDIV fmt
:tab r
"," x1
"," t
))
1422 (multiple-value-bind
1423 (r1-encoding r1-double-p
)
1424 (fp-reg-tn-encoding r1
)
1425 (multiple-value-bind
1426 (r2-encoding r2-double-p
)
1427 (fp-reg-tn-encoding r2
)
1428 (aver (eq r1-double-p r2-double-p
))
1429 (multiple-value-bind
1430 (result-encoding result-double-p
)
1431 (fp-reg-tn-encoding result
)
1432 (aver (eq r1-double-p result-double-p
))
1433 (emit-fp-class-0-inst segment
#x0C r1-encoding r2-encoding
1434 (or (position op fbinops
)
1435 (error "Bogus FBINOP: ~S" op
))
1436 (if r1-double-p
1 0) 3 0 0
1437 result-encoding
))))))
1441 ;;;; Instructions built out of other insts.
1443 (define-instruction-macro move
(src dst
&optional cond
)
1444 `(inst or
,src zero-tn
,dst
,cond
))
1446 (define-instruction-macro nop
(&optional cond
)
1447 `(inst or zero-tn zero-tn zero-tn
,cond
))
1449 (define-instruction li
(segment value reg
)
1450 (:declare
(type tn reg
)
1451 (type (or fixup
(signed-byte 32) (unsigned-byte 32)) value
))
1453 (:dependencies
(reads reg
))
1456 (assemble (segment vop
)
1459 (inst ldil value reg
)
1460 (inst ldo value reg reg
:unsigned t
))
1462 (inst ldo value zero-tn reg
))
1463 ((or (signed-byte 32) (unsigned-byte 32))
1464 (let ((lo (ldb (byte 11 0) value
)))
1465 (inst ldil value reg
)
1466 (inst ldo lo reg reg
:unsigned t
)))))))
1468 (define-instruction-macro sll
(src count result
&optional cond
)
1469 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1470 `(inst zdep
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1472 (define-instruction-macro sra
(src count result
&optional cond
)
1473 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1474 `(inst extrs
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1476 (define-instruction-macro srl
(src count result
&optional cond
)
1477 (once-only ((result result
) (src src
) (count count
) (cond cond
))
1478 `(inst extru
,src
(- 31 ,count
) (- 32 ,count
) ,result
,cond
)))
1480 (defun maybe-negate-cond (cond negate
)
1482 (multiple-value-bind
1484 (compare-condition cond
)
1486 (nth value compare-conditions
)
1487 (nth (+ value
8) compare-conditions
)))
1490 (define-instruction bc
(segment cond not-p r1 r2 target
)
1491 (:declare
(type compare-condition cond
)
1492 (type (member t nil
) not-p
)
1494 (type label target
))
1496 (:dependencies
(reads r1
) (reads r2
))
1499 (emit-chooser segment
8 2
1500 (lambda (segment posn delta
)
1501 (let ((disp (label-relative-displacement target posn delta
)))
1502 (when (<= 0 disp
(1- (ash 1 11)))
1503 (assemble (segment vop
)
1504 (inst comb
(maybe-negate-cond cond not-p
) r1 r2 target
1507 (lambda (segment posn
)
1508 (let ((disp (label-relative-displacement target posn
)))
1509 (assemble (segment vop
)
1510 (cond ((typep disp
'(signed-byte 12))
1511 (inst comb
(maybe-negate-cond cond not-p
) r1 r2 target
)
1512 (inst nop
)) ; FIXME-lav, cant nullify when backward branch
1514 (inst comclr r1 r2 zero-tn
1515 (maybe-negate-cond cond
(not not-p
)))
1516 (inst b target
:nullify t
)))))))))
1518 (define-instruction bci
(segment cond not-p imm reg target
)
1519 (:declare
(type compare-condition cond
)
1520 (type (member t nil
) not-p
)
1521 (type (signed-byte 11) imm
)
1523 (type label target
))
1525 (:dependencies
(reads reg
))
1528 (emit-chooser segment
8 2
1529 (lambda (segment posn delta-if-after
)
1530 (let ((disp (label-relative-displacement target posn delta-if-after
)))
1531 (when (and (<= 0 disp
(1- (ash 1 11)))
1532 (typep imm
'(signed-byte 5)))
1533 (assemble (segment vop
)
1534 (inst comib
(maybe-negate-cond cond not-p
) imm reg target
1537 (lambda (segment posn
)
1538 (let ((disp (label-relative-displacement target posn
)))
1539 (assemble (segment vop
)
1540 (cond ((and (typep disp
'(signed-byte 12))
1541 (typep imm
'(signed-byte 5)))
1542 (inst comib
(maybe-negate-cond cond not-p
) imm reg target
)
1545 (inst comiclr imm reg zero-tn
1546 (maybe-negate-cond cond
(not not-p
)))
1547 (inst b target
:nullify t
)))))))))
1550 ;;;; Instructions to convert between code ptrs, functions, and lras.
1552 (defun emit-header-data (segment type
)
1555 (lambda (segment posn
)
1558 (ash (+ posn
(component-header-length))
1559 (- n-widetag-bits word-shift
)))))))
1561 (define-instruction simple-fun-header-word
(segment)
1566 (emit-header-data segment simple-fun-header-widetag
)))
1568 (define-instruction lra-header-word
(segment)
1573 (emit-header-data segment return-pc-header-widetag
)))
1576 (defun emit-compute-inst (segment vop src label temp dst calc
)
1578 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1580 ;; This is the best-case that emits one instruction ( 4 bytes )
1581 (lambda (segment posn delta-if-after
)
1582 (let ((delta (funcall calc label posn delta-if-after
)))
1583 ;; WHEN, Why not AVER ?
1584 (when (typep delta
'(signed-byte 11))
1585 (emit-back-patch segment
4
1586 (lambda (segment posn
)
1587 (assemble (segment vop
)
1588 (inst addi
(funcall calc label posn
0) src
1591 ;; This is the worst-case that emits three instruction ( 12 bytes )
1592 (lambda (segment posn
)
1593 (let ((delta (funcall calc label posn
0)))
1594 ;; FIXME-lav: why do we hit below check ?
1595 ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1596 ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
1597 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1598 ;; intermediate value would be tagged but pointing into space.
1599 ;; Does above note mean that the intermediate value would be
1600 ;; a bogus pointer that would be GCed wrongly ?
1601 ;; Also what I can see addil would also overwrite NFP (r1) ???
1602 (assemble (segment vop
)
1603 ;; Three instructions (4 * 3) this is the reason for 12 bytes
1604 (inst ldil delta temp
)
1605 (inst ldo
(ldb (byte 11 0) delta
) temp temp
:unsigned t
)
1606 (inst add src temp dst
))))))
1608 (macrolet ((compute ((name) &body body
)
1609 `(define-instruction ,name
(segment src label temp dst
)
1610 (:declare
(type tn src dst temp
) (type label label
))
1611 (:attributes variable-length
)
1612 (:dependencies
(reads src
) (writes dst
) (writes temp
))
1616 (emit-compute-inst segment vop src label temp dst
1618 (compute (compute-code-from-lip)
1619 (lambda (label posn delta-if-after
)
1620 (- other-pointer-lowtag
1621 (label-position label posn delta-if-after
)
1622 (component-header-length))))
1623 (compute (compute-code-from-lra)
1624 (lambda (label posn delta-if-after
)
1625 (- (+ (label-position label posn delta-if-after
)
1626 (component-header-length)))))
1627 (compute (compute-lra-from-code)
1628 (lambda (label posn delta-if-after
)
1629 (+ (label-position label posn delta-if-after
)
1630 (component-header-length)))))
1632 ;;;; Data instructions.
1633 (define-bitfield-emitter emit-word
32
1636 (macrolet ((data (size type
)
1637 `(define-instruction ,size
(segment ,size
)
1638 (:declare
(type ,type
,size
))
1644 ,@(when (eq size
'word
)
1646 (note-fixup segment
:absolute word
)
1647 (emit-word segment
0))))
1649 (,(symbolicate "EMIT-" size
) segment
,size
)))))))
1650 (data byte
(or (unsigned-byte 8) (signed-byte 8)))
1651 (data short
(or (unsigned-byte 16) (signed-byte 16)))
1652 (data word
(or (unsigned-byte 32) (signed-byte 32) fixup
)))