3 ;;; (def-assembler-params
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (setf sb!assem:*assem-scheduler-p* nil))
9 ;;;; Utility functions.
11 (defun reg-tn-encoding (tn)
12 (declare (type tn tn))
17 (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
20 (defun fp-reg-tn-encoding (tn)
21 (declare (type tn tn))
23 (fp-single-zero (values 0 nil))
24 (single-reg (values (tn-offset tn) nil))
25 (fp-double-zero (values 0 t))
26 (double-reg (values (tn-offset tn) t))))
28 (defconstant-eqx compare-conditions
29 '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
32 (deftype compare-condition ()
33 `(member nil ,@compare-conditions))
35 (defun compare-condition (cond)
36 (declare (type compare-condition cond))
38 (let ((result (or (position cond compare-conditions :test #'eq)
39 (error "Bogus Compare/Subtract condition: ~S" cond))))
40 (values (ldb (byte 3 0) result)
44 (defconstant-eqx add-conditions
45 '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
48 (deftype add-condition ()
49 `(member nil ,@add-conditions))
51 (defun add-condition (cond)
52 (declare (type add-condition cond))
54 (let ((result (or (position cond add-conditions :test #'eq)
55 (error "Bogus Add condition: ~S" cond))))
56 (values (ldb (byte 3 0) result)
60 (defconstant-eqx logical-conditions
61 '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
64 (deftype logical-condition ()
65 `(member nil ,@(remove nil logical-conditions)))
67 (defun logical-condition (cond)
68 (declare (type logical-condition cond))
70 (let ((result (or (position cond logical-conditions :test #'eq)
71 (error "Bogus Logical condition: ~S" cond))))
72 (values (ldb (byte 3 0) result)
76 (defconstant-eqx unit-conditions
77 '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
80 (deftype unit-condition ()
81 `(member nil ,@(remove nil unit-conditions)))
83 (defun unit-condition (cond)
84 (declare (type unit-condition cond))
86 (let ((result (or (position cond unit-conditions :test #'eq)
87 (error "Bogus Unit condition: ~S" cond))))
88 (values (ldb (byte 3 0) result)
92 (defconstant-eqx extract/deposit-conditions
93 '(:never := :< :od :tr :<> :>= :ev)
96 (deftype extract/deposit-condition ()
97 `(member nil ,@extract/deposit-conditions))
99 (defun extract/deposit-condition (cond)
100 (declare (type extract/deposit-condition cond))
102 (or (position cond extract/deposit-conditions :test #'eq)
103 (error "Bogus Extract/Deposit condition: ~S" cond))
107 (defun space-encoding (space)
108 (declare (type (unsigned-byte 3) space))
109 (dpb (ldb (byte 2 0) space)
111 (ldb (byte 1 2) space)))
114 ;;;; Initial disassembler setup.
116 (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
118 (defvar *disassem-use-lisp-reg-names* t)
120 (defparameter reg-symbols
123 (cond ((null name) nil)
124 (t (make-symbol (concatenate 'string "$" name)))))
127 (sb!disassem:define-arg-type reg
128 :printer #'(lambda (value stream dstate)
129 (declare (stream stream) (fixnum value))
130 (let ((regname (aref reg-symbols value)))
131 (princ regname stream)
132 (sb!disassem:maybe-note-associated-storage-ref
138 (defparameter float-reg-symbols
140 (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
143 (sb!disassem:define-arg-type fp-reg
144 :printer #'(lambda (value stream dstate)
145 (declare (stream stream) (fixnum value))
146 (let ((regname (aref float-reg-symbols value)))
147 (princ regname stream)
148 (sb!disassem:maybe-note-associated-storage-ref
154 (sb!disassem:define-arg-type fp-fmt-0c
155 :printer #'(lambda (value stream dstate)
156 (declare (ignore dstate) (stream stream) (fixnum value))
158 (0 (format stream "~A" '\,SGL))
159 (1 (format stream "~A" '\,DBL))
160 (3 (format stream "~A" '\,QUAD)))))
162 (defun low-sign-extend (x n)
163 (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
165 (logior (ash -1 (1- n)) normal)
168 (defun sign-extend (x n)
169 (if (logbitp (1- n) x)
170 (logior (ash -1 (1- n)) x)
173 (defun assemble-bits (x list)
176 (dolist (e (reverse list))
177 (setf result (logior result (ash (ldb e x) offset)))
178 (incf offset (byte-size e)))
181 (defmacro define-imx-decode (name bits)
182 `(sb!disassem:define-arg-type ,name
183 :printer #'(lambda (value stream dstate)
184 (declare (ignore dstate) (stream stream) (fixnum value))
185 (format stream "~S" (low-sign-extend value ,bits)))))
187 (define-imx-decode im5 5)
188 (define-imx-decode im11 11)
189 (define-imx-decode im14 14)
191 (sb!disassem:define-arg-type im3
192 :printer #'(lambda (value stream dstate)
193 (declare (ignore dstate) (stream stream) (fixnum value))
194 (format stream "~S" (assemble-bits value `(,(byte 1 0)
197 (sb!disassem:define-arg-type im21
198 :printer #'(lambda (value stream dstate)
199 (declare (ignore dstate) (stream stream) (fixnum value))
201 (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
202 ,(byte 2 14) ,(byte 5 16)
205 (sb!disassem:define-arg-type cp
206 :printer #'(lambda (value stream dstate)
207 (declare (ignore dstate) (stream stream) (fixnum value))
208 (format stream "~S" (- 31 value))))
210 (sb!disassem:define-arg-type clen
211 :printer #'(lambda (value stream dstate)
212 (declare (ignore dstate) (stream stream) (fixnum value))
213 (format stream "~S" (- 32 value))))
215 (sb!disassem:define-arg-type compare-condition
216 :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
217 \,> \,>>= \,>> \,NSV \,EV))
219 (sb!disassem:define-arg-type compare-condition-false
220 :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
221 "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
223 (sb!disassem:define-arg-type add-condition
224 :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
227 (sb!disassem:define-arg-type add-condition-false
228 :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
229 "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
231 (sb!disassem:define-arg-type logical-condition
232 :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
234 (sb!disassem:define-arg-type unit-condition
235 :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
238 (sb!disassem:define-arg-type extract/deposit-condition
239 :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
241 (sb!disassem:define-arg-type extract/deposit-condition-false
242 :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
244 (sb!disassem:define-arg-type nullify
247 (sb!disassem:define-arg-type fcmp-cond
248 :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
249 \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
250 \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
252 (sb!disassem:define-arg-type integer
253 :printer #'(lambda (value stream dstate)
254 (declare (ignore dstate) (stream stream) (fixnum value))
255 (format stream "~S" value)))
257 (sb!disassem:define-arg-type space
258 :printer #("" |1,| |2,| |3,|))
261 ;;;; Define-instruction-formats for disassembler.
263 (sb!disassem:define-instruction-format
265 (op :field (byte 6 26))
266 (b :field (byte 5 21) :type 'reg)
267 (t/r :field (byte 5 16) :type 'reg)
268 (s :field (byte 2 14) :type 'space)
269 (im14 :field (byte 14 0) :type 'im14))
271 (defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
272 (:cond ((m :constant 1) '\,M)))
275 (defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
276 (:cond ((s :constant 0) '\,MA)
280 (defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
282 (:cond ((m :constant 1) '\,M)))
285 (sb!disassem:define-instruction-format
286 (extended-load/store 32)
287 (op1 :field (byte 6 26) :value 3)
288 (b :field (byte 5 21) :type 'reg)
289 (x/im5/r :field (byte 5 16) :type 'reg)
290 (s :field (byte 2 14) :type 'space)
291 (u :field (byte 1 13))
292 (op2 :field (byte 3 10))
293 (ext4/c :field (byte 4 6))
294 (m :field (byte 1 5))
295 (t/im5 :field (byte 5 0) :type 'reg))
297 (sb!disassem:define-instruction-format
298 (ldil 32 :default-printer '(:name :tab im21 "," t))
299 (op :field (byte 6 26))
300 (t :field (byte 5 21) :type 'reg)
301 (im21 :field (byte 21 0) :type 'im21))
303 (sb!disassem:define-instruction-format
305 (op1 :field (byte 6 26))
306 (t :field (byte 5 21) :type 'reg)
307 (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
309 #'(lambda (value dstate)
310 (declare (type sb!disassem:disassem-state dstate) (list value))
311 (let ((x (logior (ash (first value) 12) (ash (second value) 1)
314 (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
315 ,(byte 10 2))) 17) 2)
316 (sb!disassem:dstate-cur-addr dstate) 8))))
317 (op2 :field (byte 3 13))
318 (n :field (byte 1 1) :type 'nullify))
320 (sb!disassem:define-instruction-format
322 (op1 :field (byte 6 26))
323 (r2 :field (byte 5 21) :type 'reg)
324 (r1 :field (byte 5 16) :type 'reg)
325 (w :fields `(,(byte 11 2) ,(byte 1 0))
327 #'(lambda (value dstate)
328 (declare (type sb!disassem:disassem-state dstate) (list value))
329 (let ((x (logior (ash (first value) 1) (second value))))
331 (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
333 (sb!disassem:dstate-cur-addr dstate) 8))))
334 (c :field (byte 3 13))
335 (n :field (byte 1 1) :type 'nullify))
337 (sb!disassem:define-instruction-format
339 (op1 :field (byte 6 26))
340 (t :field (byte 5 21) :type 'reg)
341 (x :field (byte 5 16) :type 'reg)
342 (op2 :field (byte 3 13))
343 (x1 :field (byte 11 2))
344 (n :field (byte 1 1) :type 'nullify)
345 (x2 :field (byte 1 0)))
347 (sb!disassem:define-instruction-format
348 (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
349 (r3 :field (byte 6 26) :value 2)
350 (r2 :field (byte 5 21) :type 'reg)
351 (r1 :field (byte 5 16) :type 'reg)
352 (c :field (byte 3 13))
353 (f :field (byte 1 12))
354 (op :field (byte 7 5))
355 (t :field (byte 5 0) :type 'reg))
357 (sb!disassem:define-instruction-format
358 (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
359 (op :field (byte 6 26))
360 (r :field (byte 5 21) :type 'reg)
361 (t :field (byte 5 16) :type 'reg)
362 (c :field (byte 3 13))
363 (f :field (byte 1 12))
364 (o :field (byte 1 11))
365 (im11 :field (byte 11 0) :type 'im11))
367 (sb!disassem:define-instruction-format
368 (extract/deposit-inst 32)
369 (op1 :field (byte 6 26))
370 (r2 :field (byte 5 21) :type 'reg)
371 (r1 :field (byte 5 16) :type 'reg)
372 (c :field (byte 3 13) :type 'extract/deposit-condition)
373 (op2 :field (byte 3 10))
374 (cp :field (byte 5 5) :type 'cp)
375 (t/clen :field (byte 5 0) :type 'clen))
377 (sb!disassem:define-instruction-format
378 (break 32 :default-printer '(:name :tab im13 "," im5))
379 (op1 :field (byte 6 26) :value 0)
380 (im13 :field (byte 13 13))
381 (q2 :field (byte 8 5) :value 0)
382 (im5 :field (byte 5 0)))
384 (defun snarf-error-junk (sap offset &optional length-only)
385 (let* ((length (sb!sys:sap-ref-8 sap offset))
386 (vector (make-array length :element-type '(unsigned-byte 8))))
387 (declare (type sb!sys:system-area-pointer sap)
388 (type (unsigned-byte 8) length)
389 (type (simple-array (unsigned-byte 8) (*)) vector))
391 (values 0 (1+ length) nil nil))
393 (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
394 vector (* n-word-bits
396 (* length n-byte-bits))
397 (collect ((sc-offsets)
399 (lengths 1) ; the length byte
401 (error-number (sb!c:read-var-integer vector index)))
404 (when (>= index length)
406 (let ((old-index index))
407 (sc-offsets (sb!c:read-var-integer vector index))
408 (lengths (- index old-index))))
414 (defun break-control (chunk inst stream dstate)
415 (declare (ignore inst))
416 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
417 (case (break-im5 chunk dstate)
420 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
423 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
424 (#.sb!vm:breakpoint-trap
425 (nt "Breakpoint trap"))
426 (#.sb!vm:pending-interrupt-trap
427 (nt "Pending interrupt trap"))
430 (#.sb!vm:fun-end-breakpoint-trap
431 (nt "Function end breakpoint trap"))
434 (sb!disassem:define-instruction-format
436 (op1 :field (byte 6 26) :value 0)
437 (r1 :field (byte 5 21) :type 'reg)
438 (r2 :field (byte 5 16) :type 'reg)
439 (s :field (byte 3 13))
440 (op2 :field (byte 8 5))
441 (r3 :field (byte 5 0) :type 'reg))
443 (sb!disassem:define-instruction-format
445 (op :field (byte 6 26))
446 (b :field (byte 5 21) :type 'reg)
447 (x :field (byte 5 16) :type 'reg)
448 (s :field (byte 2 14) :type 'space)
449 (u :field (byte 1 13))
450 (x1 :field (byte 1 12))
451 (x2 :field (byte 2 10))
452 (x3 :field (byte 1 9))
453 (x4 :field (byte 3 6))
454 (m :field (byte 1 5))
455 (t :field (byte 5 0) :type 'fp-reg))
457 (sb!disassem:define-instruction-format
459 (op1 :field (byte 6 26))
460 (r :field (byte 5 21) :type 'fp-reg)
461 (x1 :field (byte 5 16) :type 'fp-reg)
462 (op2 :field (byte 3 13))
463 (fmt :field (byte 2 11) :type 'fp-fmt-0c)
464 (x2 :field (byte 2 9))
465 (x3 :field (byte 3 6))
466 (x4 :field (byte 1 5))
467 (t :field (byte 5 0) :type 'fp-reg))
469 (sb!disassem:define-instruction-format
471 (op1 :field (byte 6 26))
472 (r :field (byte 5 21) :type 'fp-reg)
473 (x1 :field (byte 4 17) :value 0)
474 (x2 :field (byte 2 15))
475 (df :field (byte 2 13) :type 'fp-fmt-0c)
476 (sf :field (byte 2 11) :type 'fp-fmt-0c)
477 (x3 :field (byte 2 9) :value 1)
478 (x4 :field (byte 3 6) :value 0)
479 (x5 :field (byte 1 5) :value 0)
480 (t :field (byte 5 0) :type 'fp-reg))
484 ;;;; Load and Store stuff.
486 (define-bitfield-emitter emit-load/store 32
494 (defun im14-encoding (segment disp)
495 (declare (type (or fixup (signed-byte 14))))
496 (cond ((fixup-p disp)
497 (note-fixup segment :load disp)
498 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
501 (dpb (ldb (byte 13 0) disp)
503 (ldb (byte 1 13) disp)))))
505 (macrolet ((define-load-inst (name opcode)
506 `(define-instruction ,name (segment disp base reg)
507 (:declare (type tn reg base)
508 (type (or fixup (signed-byte 14)) disp))
509 (:printer load/store ((op ,opcode) (s 0))
510 '(:name :tab im14 "(" s b ")," t/r))
512 (emit-load/store segment ,opcode
513 (reg-tn-encoding base) (reg-tn-encoding reg) 0
514 (im14-encoding segment disp)))))
515 (define-store-inst (name opcode)
516 `(define-instruction ,name (segment reg disp base)
517 (:declare (type tn reg base)
518 (type (or fixup (signed-byte 14)) disp))
519 (:printer load/store ((op ,opcode) (s 0))
520 '(:name :tab t/r "," im14 "(" s b ")"))
522 (emit-load/store segment ,opcode
523 (reg-tn-encoding base) (reg-tn-encoding reg) 0
524 (im14-encoding segment disp))))))
525 (define-load-inst ldw #x12)
526 (define-load-inst ldh #x11)
527 (define-load-inst ldb #x10)
528 (define-load-inst ldwm #x13)
529 (define-load-inst ldo #x0D)
531 (define-store-inst stw #x1A)
532 (define-store-inst sth #x19)
533 (define-store-inst stb #x18)
534 (define-store-inst stwm #x1B))
536 (define-bitfield-emitter emit-extended-load/store 32
537 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
538 (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
540 (macrolet ((define-load-indexed-inst (name opcode)
541 `(define-instruction ,name (segment index base reg &key modify scale)
542 (:declare (type tn reg base index)
543 (type (member t nil) modify scale))
544 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
546 `(:name ,@cmplt-index-print :tab x/im5/r
549 (emit-extended-load/store
550 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
551 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
552 (reg-tn-encoding reg))))))
553 (define-load-indexed-inst ldwx 2)
554 (define-load-indexed-inst ldhx 1)
555 (define-load-indexed-inst ldbx 0)
556 (define-load-indexed-inst ldcwx 7))
558 (defun short-disp-encoding (segment disp)
559 (declare (type (or fixup (signed-byte 5)) disp))
560 (cond ((fixup-p disp)
561 (note-fixup segment :load-short disp)
562 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
565 (dpb (ldb (byte 4 0) disp)
567 (ldb (byte 1 4) disp)))))
569 (macrolet ((define-load-short-inst (name opcode)
570 `(define-instruction ,name (segment base disp reg &key modify)
571 (:declare (type tn base reg)
572 (type (or fixup (signed-byte 5)) disp)
573 (type (member :before :after nil) modify))
574 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
576 `(:name ,@cmplt-disp-print :tab x/im5/r
583 (:after (values 1 0))
584 (:before (values 1 1)))
585 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
586 (short-disp-encoding segment disp)
588 (reg-tn-encoding reg))))))
589 (define-store-short-inst (name opcode)
590 `(define-instruction ,name (segment reg base disp &key modify)
591 (:declare (type tn reg base)
592 (type (or fixup (signed-byte 5)) disp)
593 (type (member :before :after nil) modify))
594 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
596 `(:name ,@cmplt-disp-print :tab x/im5/r
597 "," t/im5 "(" s b ")"))
603 (:after (values 1 0))
604 (:before (values 1 1)))
605 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
606 (short-disp-encoding segment disp)
608 (reg-tn-encoding reg)))))))
609 (define-load-short-inst ldws 2)
610 (define-load-short-inst ldhs 1)
611 (define-load-short-inst ldbs 0)
612 (define-load-short-inst ldcws 7)
614 (define-store-short-inst stws 10)
615 (define-store-short-inst sths 9)
616 (define-store-short-inst stbs 8))
618 (define-instruction stbys (segment reg base disp where &key modify)
619 (:declare (type tn reg base)
620 (type (signed-byte 5) disp)
621 (type (member :begin :end) where)
622 (type (member t nil) modify))
623 (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
624 `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
626 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
627 (reg-tn-encoding reg) 0
628 (ecase where (:begin 0) (:end 1))
629 4 #xC (if modify 1 0)
630 (short-disp-encoding segment disp))))
633 ;;;; Immediate Instructions.
635 (define-bitfield-emitter emit-ldil 32
640 (defun immed-21-encoding (segment value)
641 (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
642 (cond ((fixup-p value)
643 (note-fixup segment :hi value)
644 (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
647 (logior (ash (ldb (byte 5 2) value) 16)
648 (ash (ldb (byte 2 7) value) 14)
649 (ash (ldb (byte 2 0) value) 12)
650 (ash (ldb (byte 11 9) value) 1)
651 (ldb (byte 1 20) value)))))
653 (define-instruction ldil (segment value reg)
654 (:declare (type tn reg)
655 (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
656 (:printer ldil ((op #x08)))
658 (emit-ldil segment #x08 (reg-tn-encoding reg)
659 (immed-21-encoding segment value))))
661 (define-instruction addil (segment value reg)
662 (:declare (type tn reg)
663 (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
664 (:printer ldil ((op #x0A)))
666 (emit-ldil segment #x0A (reg-tn-encoding reg)
667 (immed-21-encoding segment value))))
670 ;;;; Branch instructions.
672 (define-bitfield-emitter emit-branch 32
673 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
674 (byte 11 2) (byte 1 1) (byte 1 0))
676 (defun label-relative-displacement (label posn &optional delta-if-after)
677 (declare (type label label) (type index posn))
678 (ash (- (if delta-if-after
679 (label-position label posn delta-if-after)
680 (label-position label))
683 (defun decompose-branch-disp (segment disp)
684 (declare (type (or fixup (signed-byte 17)) disp))
685 (cond ((fixup-p disp)
686 (note-fixup segment :branch disp)
687 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
690 (values (ldb (byte 5 11) disp)
691 (dpb (ldb (byte 10 0) disp)
693 (ldb (byte 1 10) disp))
694 (ldb (byte 1 16) disp)))))
696 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
697 (declare (type (unsigned-byte 6) opcode)
698 (type (unsigned-byte 5) link)
699 (type (unsigned-byte 1) sub-opcode)
701 (type (member t nil) nullify))
702 (emit-back-patch segment 4
703 #'(lambda (segment posn)
704 (let ((disp (label-relative-displacement target posn)))
705 (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
708 (decompose-branch-disp segment disp)
709 (emit-branch segment opcode link w1 sub-opcode w2
710 (if nullify 1 0) w))))))
712 (define-instruction b (segment target &key nullify)
713 (:declare (type label target) (type (member t nil) nullify))
715 (emit-relative-branch segment #x3A 0 0 target nullify)))
717 (define-instruction bl (segment target reg &key nullify)
718 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
719 (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
721 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
723 (define-instruction gateway (segment target reg &key nullify)
724 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
725 (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
727 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
729 ;;; BLR is useless because we have no way to generate the offset.
731 (define-instruction bv (segment base &key nullify offset)
732 (:declare (type tn base)
733 (type (member t nil) nullify)
734 (type (or tn null) offset))
735 (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
737 (emit-branch segment #x3A (reg-tn-encoding base)
738 (if offset (reg-tn-encoding offset) 0)
739 6 0 (if nullify 1 0) 0)))
741 (define-instruction be (segment disp space base &key nullify)
742 (:declare (type (or fixup (signed-byte 17)) disp)
744 (type (unsigned-byte 3) space)
745 (type (member t nil) nullify))
746 (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
747 '(:name n :tab w "(" op2 "," t ")"))
751 (decompose-branch-disp segment disp)
752 (emit-branch segment #x38 (reg-tn-encoding base) w1
753 (space-encoding space) w2 (if nullify 1 0) w))))
755 (define-instruction ble (segment disp space base &key nullify)
756 (:declare (type (or fixup (signed-byte 17)) disp)
758 (type (unsigned-byte 3) space)
759 (type (member t nil) nullify))
760 (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
761 '(:name n :tab w "(" op2 "," t ")"))
765 (decompose-branch-disp segment disp)
766 (emit-branch segment #x39 (reg-tn-encoding base) w1
767 (space-encoding space) w2 (if nullify 1 0) w))))
769 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
770 (emit-back-patch segment 4
771 #'(lambda (segment posn)
772 (let ((disp (label-relative-displacement target posn)))
773 (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
774 (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
775 (ldb (byte 1 10) disp)))
776 (w (ldb (byte 1 11) disp)))
777 (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
779 (defun im5-encoding (value)
780 (declare (type (signed-byte 5) value)
781 #+nil (values (unsigned-byte 5)))
782 (dpb (ldb (byte 4 0) value)
784 (ldb (byte 1 4) value)))
786 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
787 (let* ((conditional (symbolicate cond-kind "-CONDITION"))
788 (false-conditional (symbolicate conditional "-FALSE")))
790 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
791 (:declare (type ,conditional cond)
794 (type (member t nil) nullify))
795 (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
796 '(:name c n :tab r1 "," r2 "," w))
797 ,@(unless (= r-opcode #x32)
798 `((:printer branch12 ((op1 ,(+ 2 r-opcode))
799 (c nil :type ',false-conditional))
800 '(:name c n :tab r1 "," r2 "," w))))
803 (cond-encoding false)
805 (emit-conditional-branch
806 segment (if false ,(+ r-opcode 2) ,r-opcode)
807 (reg-tn-encoding r2) (reg-tn-encoding r1)
808 cond-encoding target nullify))))
809 (define-instruction ,i-name (segment cond imm reg target &key nullify)
810 (:declare (type ,conditional cond)
811 (type (signed-byte 5) imm)
813 (type (member t nil) nullify))
814 (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
815 (c nil :type ',conditional))
816 '(:name c n :tab r1 "," r2 "," w))
817 ,@(unless (= r-opcode #x32)
818 `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
819 (c nil :type ',false-conditional))
820 '(:name c n :tab r1 "," r2 "," w))))
823 (cond-encoding false)
825 (emit-conditional-branch
826 segment (if false (+ ,i-opcode 2) ,i-opcode)
827 (reg-tn-encoding reg) (im5-encoding imm)
828 cond-encoding target nullify))))))))
829 (define-branch-inst movb #x32 movib #x33 extract/deposit)
830 (define-branch-inst comb #x20 comib #x21 compare)
831 (define-branch-inst addb #x28 addib #x29 add))
833 (define-instruction bb (segment cond reg posn target &key nullify)
834 (:declare (type (member t nil) cond nullify)
836 (type (or (member :variable) (unsigned-byte 5)) posn))
837 (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
838 '('BVB c n :tab r1 "," w))
841 (opcode posn-encoding)
842 (if (eq posn :variable)
845 (emit-conditional-branch segment opcode posn-encoding
846 (reg-tn-encoding reg)
847 (if cond 2 6) target nullify))))
850 ;;;; Computation Instructions
852 (define-bitfield-emitter emit-r3-inst 32
853 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
854 (byte 1 12) (byte 7 5) (byte 5 0))
856 (macrolet ((define-r3-inst (name cond-kind opcode)
857 `(define-instruction ,name (segment r1 r2 res &optional cond)
858 (:declare (type tn res r1 r2))
859 (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
862 ,@(when (= opcode #x12)
863 `((:printer r3-inst ((op ,opcode) (r2 0)
864 (c nil :type ',(symbolicate cond-kind
866 `('COPY :tab r1 "," t))))
870 (,(symbolicate cond-kind "-CONDITION") cond)
871 (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
872 cond (if false 1 0) ,opcode
873 (reg-tn-encoding res)))))))
874 (define-r3-inst add add #x30)
875 (define-r3-inst addl add #x50)
876 (define-r3-inst addo add #x70)
877 (define-r3-inst addc add #x38)
878 (define-r3-inst addco add #x78)
879 (define-r3-inst sh1add add #x32)
880 (define-r3-inst sh1addl add #x52)
881 (define-r3-inst sh1addo add #x72)
882 (define-r3-inst sh2add add #x34)
883 (define-r3-inst sh2addl add #x54)
884 (define-r3-inst sh2addo add #x74)
885 (define-r3-inst sh3add add #x36)
886 (define-r3-inst sh3addl add #x56)
887 (define-r3-inst sh3addo add #x76)
888 (define-r3-inst sub compare #x20)
889 (define-r3-inst subo compare #x60)
890 (define-r3-inst subb compare #x28)
891 (define-r3-inst subbo compare #x68)
892 (define-r3-inst subt compare #x26)
893 (define-r3-inst subto compare #x66)
894 (define-r3-inst ds compare #x22)
895 (define-r3-inst comclr compare #x44)
896 (define-r3-inst or logical #x12)
897 (define-r3-inst xor logical #x14)
898 (define-r3-inst and logical #x10)
899 (define-r3-inst andcm logical #x00)
900 (define-r3-inst uxor unit #x1C)
901 (define-r3-inst uaddcm unit #x4C)
902 (define-r3-inst uaddcmt unit #x4E)
903 (define-r3-inst dcor unit #x5C)
904 (define-r3-inst idcor unit #x5E))
906 (define-bitfield-emitter emit-imm-inst 32
907 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
908 (byte 1 12) (byte 1 11) (byte 11 0))
910 (defun im11-encoding (value)
911 (declare (type (signed-byte 11) value)
912 #+nil (values (unsigned-byte 11)))
913 (dpb (ldb (byte 10 0) value)
915 (ldb (byte 1 10) value)))
917 (macrolet ((define-imm-inst (name cond-kind opcode subcode)
918 `(define-instruction ,name (segment imm src dst &optional cond)
919 (:declare (type tn dst src)
920 (type (signed-byte 11) imm))
921 (:printer imm-inst ((op ,opcode) (o ,subcode)
923 ',(symbolicate cond-kind "-CONDITION"))))
927 (,(symbolicate cond-kind "-CONDITION") cond)
928 (emit-imm-inst segment ,opcode (reg-tn-encoding src)
929 (reg-tn-encoding dst) cond
930 (if false 1 0) ,subcode
931 (im11-encoding imm)))))))
932 (define-imm-inst addi add #x2D 0)
933 (define-imm-inst addio add #x2D 1)
934 (define-imm-inst addit add #x2C 0)
935 (define-imm-inst addito add #x2C 1)
936 (define-imm-inst subi compare #x25 0)
937 (define-imm-inst subio compare #x25 1)
938 (define-imm-inst comiclr compare #x24 0))
940 (define-bitfield-emitter emit-extract/deposit-inst 32
941 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
942 (byte 3 10) (byte 5 5) (byte 5 0))
944 (define-instruction shd (segment r1 r2 count res &optional cond)
945 (:declare (type tn res r1 r2)
946 (type (or (member :variable) (integer 0 31)) count))
947 (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
948 '(:name c :tab r1 "," r2 "," cp "," t/clen))
949 (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
950 '('VSHD c :tab r1 "," r2 "," t/clen))
954 (emit-extract/deposit-inst segment #x34
955 (reg-tn-encoding r2) (reg-tn-encoding r1)
956 (extract/deposit-condition cond)
957 0 0 (reg-tn-encoding res)))
959 (emit-extract/deposit-inst segment #x34
960 (reg-tn-encoding r2) (reg-tn-encoding r1)
961 (extract/deposit-condition cond)
963 (reg-tn-encoding res))))))
965 (macrolet ((define-extract-inst (name opcode)
966 `(define-instruction ,name (segment src posn len res &optional cond)
967 (:declare (type tn res src)
968 (type (or (member :variable) (integer 0 31)) posn)
969 (type (integer 1 32) len))
970 (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
972 '(:name c :tab r2 "," cp "," t/clen "," r1))
973 (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
974 '('V :name c :tab r2 "," t/clen "," r1))
978 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
979 (reg-tn-encoding res)
980 (extract/deposit-condition cond)
981 ,(- opcode 2) 0 (- 32 len)))
983 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
984 (reg-tn-encoding res)
985 (extract/deposit-condition cond)
986 ,opcode posn (- 32 len))))))))
987 (define-extract-inst extru 6)
988 (define-extract-inst extrs 7))
990 (macrolet ((define-deposit-inst (name opcode)
991 `(define-instruction ,name (segment src posn len res &optional cond)
992 (:declare (type tn res)
993 (type (or tn (signed-byte 5)) src)
994 (type (or (member :variable) (integer 0 31)) posn)
995 (type (integer 1 32) len))
996 (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
997 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
998 (if (= opcode 0) (cons ''Z base) base)))
999 (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1000 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1001 (if (= opcode 0) (cons ''Z base) base)))
1002 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1003 (op2 ,(+ 4 opcode)))
1004 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1005 (if (= opcode 0) (cons ''Z base) base)))
1006 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1007 (op2 ,(+ 6 opcode)))
1008 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1009 (if (= opcode 0) (cons ''Z base) base)))
1011 (multiple-value-bind
1012 (opcode src-encoding)
1015 (values ,opcode (reg-tn-encoding src)))
1017 (values ,(+ opcode 4) (im5-encoding src))))
1018 (multiple-value-bind
1019 (opcode posn-encoding)
1024 (values (+ opcode 2) (- 31 posn))))
1025 (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1027 (extract/deposit-condition cond)
1028 opcode posn-encoding (- 32 len))))))))
1030 (define-deposit-inst dep 1)
1031 (define-deposit-inst zdep 0))
1035 ;;;; System Control Instructions.
1037 (define-bitfield-emitter emit-break 32
1038 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1040 (define-instruction break (segment &optional (im5 0) (im13 0))
1041 (:declare (type (unsigned-byte 13) im13)
1042 (type (unsigned-byte 5) im5))
1043 (:printer break () :default :control #'break-control)
1045 (emit-break segment 0 im13 0 im5)))
1047 (define-bitfield-emitter emit-system-inst 32
1048 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1050 (define-instruction ldsid (segment res base &optional (space 0))
1051 (:declare (type tn res base)
1052 (type (integer 0 3) space))
1053 (:printer system-inst ((op2 #x85) (c nil :type 'space)
1054 (s nil :printer #(0 0 1 1 2 2 3 3)))
1055 `(:name :tab "(" s r1 ")," r3))
1057 (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1058 (reg-tn-encoding res))))
1060 (define-instruction mtsp (segment reg space)
1061 (:declare (type tn reg) (type (integer 0 7) space))
1062 (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1064 (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1067 (define-instruction mfsp (segment space reg)
1068 (:declare (type tn reg) (type (integer 0 7) space))
1069 (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1071 (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1072 (reg-tn-encoding reg))))
1074 (deftype control-reg ()
1075 '(or (unsigned-byte 5) (member :sar)))
1077 (defun control-reg (reg)
1078 (declare (type control-reg reg)
1079 #+nil (values (unsigned-byte 32)))
1080 (if (typep reg '(unsigned-byte 5))
1085 (define-instruction mtctl (segment reg ctrl-reg)
1086 (:declare (type tn reg) (type control-reg ctrl-reg))
1087 (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1089 (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1092 (define-instruction mfctl (segment ctrl-reg reg)
1093 (:declare (type tn reg) (type control-reg ctrl-reg))
1094 (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1096 (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1097 (reg-tn-encoding reg))))
1101 ;;;; Floating point instructions.
1103 (define-bitfield-emitter emit-fp-load/store 32
1104 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1105 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1107 (define-instruction fldx (segment index base result &key modify scale side)
1108 (:declare (type tn index base result)
1109 (type (member t nil) modify scale)
1110 (type (member nil 0 1) side))
1111 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1112 `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1113 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1114 `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
1116 (multiple-value-bind
1117 (result-encoding double-p)
1118 (fp-reg-tn-encoding result)
1121 (setf double-p nil))
1122 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1123 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1124 (or side 0) (if modify 1 0) result-encoding))))
1126 (define-instruction fstx (segment value index base &key modify scale side)
1127 (:declare (type tn index base value)
1128 (type (member t nil) modify scale)
1129 (type (member nil 0 1) side))
1130 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1131 `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1132 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1133 `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
1135 (multiple-value-bind
1136 (value-encoding double-p)
1137 (fp-reg-tn-encoding value)
1140 (setf double-p nil))
1141 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1142 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1143 (or side 0) (if modify 1 0) value-encoding))))
1145 (define-instruction flds (segment disp base result &key modify side)
1146 (:declare (type tn base result)
1147 (type (signed-byte 5) disp)
1148 (type (member :before :after nil) modify)
1149 (type (member nil 0 1) side))
1150 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1151 `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
1152 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1153 `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
1155 (multiple-value-bind
1156 (result-encoding double-p)
1157 (fp-reg-tn-encoding result)
1160 (setf double-p nil))
1161 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1162 (short-disp-encoding segment disp) 0
1163 (if (eq modify :before) 1 0) 1 0 0
1164 (or side 0) (if modify 1 0) result-encoding))))
1166 (define-instruction fsts (segment value disp base &key modify side)
1167 (:declare (type tn base value)
1168 (type (signed-byte 5) disp)
1169 (type (member :before :after nil) modify)
1170 (type (member nil 0 1) side))
1171 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1172 `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1173 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1174 `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1176 (multiple-value-bind
1177 (value-encoding double-p)
1178 (fp-reg-tn-encoding value)
1181 (setf double-p nil))
1182 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1183 (short-disp-encoding segment disp) 0
1184 (if (eq modify :before) 1 0) 1 0 1
1185 (or side 0) (if modify 1 0) value-encoding))))
1188 (define-bitfield-emitter emit-fp-class-0-inst 32
1189 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1190 (byte 3 6) (byte 1 5) (byte 5 0))
1192 (define-bitfield-emitter emit-fp-class-1-inst 32
1193 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1194 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1196 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1197 ;;; seperate emitters.
1199 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1205 (define-instruction funop (segment op from to)
1206 (:declare (type funop op)
1208 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1209 '('FCPY fmt :tab r "," t))
1210 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1211 '('FABS fmt :tab r "," t))
1212 (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1213 '('FSQRT fmt :tab r "," t))
1214 (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1215 '('FRND fmt :tab r "," t))
1217 (multiple-value-bind
1218 (from-encoding from-double-p)
1219 (fp-reg-tn-encoding from)
1220 (multiple-value-bind
1221 (to-encoding to-double-p)
1222 (fp-reg-tn-encoding to)
1223 (assert (eq from-double-p to-double-p))
1224 (emit-fp-class-0-inst segment #x0C from-encoding 0
1225 (+ 2 (or (position op funops)
1226 (error "Bogus FUNOP: ~S" op)))
1227 (if to-double-p 1 0) 0 0 0 to-encoding)))))
1229 (macrolet ((define-class-1-fp-inst (name subcode)
1230 `(define-instruction ,name (segment from to)
1231 (:declare (type tn from to))
1232 (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1233 '(:name sf df :tab r "," t))
1235 (multiple-value-bind
1236 (from-encoding from-double-p)
1237 (fp-reg-tn-encoding from)
1238 (multiple-value-bind
1239 (to-encoding to-double-p)
1240 (fp-reg-tn-encoding to)
1241 (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1242 (if to-double-p 1 0) (if from-double-p 1 0)
1243 1 0 0 to-encoding)))))))
1245 (define-class-1-fp-inst fcnvff 0)
1246 (define-class-1-fp-inst fcnvxf 1)
1247 (define-class-1-fp-inst fcnvfx 2)
1248 (define-class-1-fp-inst fcnvfxt 3))
1250 (define-instruction fcmp (segment cond r1 r2)
1251 (:declare (type (unsigned-byte 5) cond)
1253 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1254 '(:name fmt t :tab r "," x1))
1256 (multiple-value-bind
1257 (r1-encoding r1-double-p)
1258 (fp-reg-tn-encoding r1)
1259 (multiple-value-bind
1260 (r2-encoding r2-double-p)
1261 (fp-reg-tn-encoding r2)
1262 (assert (eq r1-double-p r2-double-p))
1263 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1264 (if r1-double-p 1 0) 2 0 0 cond)))))
1266 (define-instruction ftest (segment)
1267 (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1269 (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1271 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1275 `(member ,@fbinops))
1277 (define-instruction fbinop (segment op r1 r2 result)
1278 (:declare (type fbinop op)
1279 (type tn r1 r2 result))
1280 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1281 '('FADD fmt :tab r "," x1 "," t))
1282 (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1283 '('FSUB fmt :tab r "," x1 "," t))
1284 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1285 '('FMPY fmt :tab r "," x1 "," t))
1286 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1287 '('FDIV fmt :tab r "," x1 "," t))
1289 (multiple-value-bind
1290 (r1-encoding r1-double-p)
1291 (fp-reg-tn-encoding r1)
1292 (multiple-value-bind
1293 (r2-encoding r2-double-p)
1294 (fp-reg-tn-encoding r2)
1295 (assert (eq r1-double-p r2-double-p))
1296 (multiple-value-bind
1297 (result-encoding result-double-p)
1298 (fp-reg-tn-encoding result)
1299 (assert (eq r1-double-p result-double-p))
1300 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1301 (or (position op fbinops)
1302 (error "Bogus FBINOP: ~S" op))
1303 (if r1-double-p 1 0) 3 0 0
1304 result-encoding))))))
1308 ;;;; Instructions built out of other insts.
1310 (define-instruction-macro move (src dst &optional cond)
1311 `(inst or ,src zero-tn ,dst ,cond))
1313 (define-instruction-macro nop (&optional cond)
1314 `(inst or zero-tn zero-tn zero-tn ,cond))
1316 (define-instruction li (segment value reg)
1317 (:declare (type tn reg)
1318 (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1321 (assemble (segment vop)
1324 (inst ldil value reg)
1325 (inst ldo value reg reg))
1327 (inst ldo value zero-tn reg))
1328 ((or (signed-byte 32) (unsigned-byte 32))
1329 (let ((hi (ldb (byte 21 11) value))
1330 (lo (ldb (byte 11 0) value)))
1333 (inst ldo lo reg reg))))))))
1335 (define-instruction-macro sll (src count result &optional cond)
1336 (once-only ((result result) (src src) (count count) (cond cond))
1337 `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1339 (define-instruction-macro sra (src count result &optional cond)
1340 (once-only ((result result) (src src) (count count) (cond cond))
1341 `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1343 (define-instruction-macro srl (src count result &optional cond)
1344 (once-only ((result result) (src src) (count count) (cond cond))
1345 `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1347 (defun maybe-negate-cond (cond negate)
1349 (multiple-value-bind
1351 (compare-condition cond)
1353 (nth value compare-conditions)
1354 (nth (+ value 8) compare-conditions)))
1357 (define-instruction bc (segment cond not-p r1 r2 target)
1358 (:declare (type compare-condition cond)
1359 (type (member t nil) not-p)
1361 (type label target))
1364 (emit-chooser segment 8 2
1365 #'(lambda (segment posn delta)
1366 (let ((disp (label-relative-displacement target posn delta)))
1367 (when (<= 0 disp (1- (ash 1 11)))
1368 (assemble (segment vop)
1369 (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1372 #'(lambda (segment posn)
1373 (let ((disp (label-relative-displacement target posn)))
1374 (assemble (segment vop)
1375 (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1376 (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1379 (inst comclr r1 r2 zero-tn
1380 (maybe-negate-cond cond (not not-p)))
1381 (inst b target :nullify t)))))))))
1383 (define-instruction bci (segment cond not-p imm reg target)
1384 (:declare (type compare-condition cond)
1385 (type (member t nil) not-p)
1386 (type (signed-byte 11) imm)
1388 (type label target))
1391 (emit-chooser segment 8 2
1392 #'(lambda (segment posn delta-if-after)
1393 (let ((disp (label-relative-displacement target posn delta-if-after)))
1394 (when (and (<= 0 disp (1- (ash 1 11)))
1395 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1396 (assemble (segment vop)
1397 (inst comib (maybe-negate-cond cond not-p) imm reg target
1400 #'(lambda (segment posn)
1401 (let ((disp (label-relative-displacement target posn)))
1402 (assemble (segment vop)
1403 (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1404 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1405 (inst comib (maybe-negate-cond cond not-p) imm reg target)
1408 (inst comiclr imm reg zero-tn
1409 (maybe-negate-cond cond (not not-p)))
1410 (inst b target :nullify t)))))))))
1413 ;;;; Instructions to convert between code ptrs, functions, and lras.
1415 (defun emit-compute-inst (segment vop src label temp dst calc)
1417 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1419 #'(lambda (segment posn delta-if-after)
1420 (let ((delta (funcall calc label posn delta-if-after)))
1421 (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1422 (emit-back-patch segment 4
1423 #'(lambda (segment posn)
1424 (assemble (segment vop)
1425 (inst addi (funcall calc label posn 0) src
1428 #'(lambda (segment posn)
1429 (let ((delta (funcall calc label posn 0)))
1430 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1431 ;; intermediate value would be tagged but pointing into space.
1432 (assemble (segment vop)
1433 (inst ldil (ldb (byte 21 11) delta) temp)
1434 (inst ldo (ldb (byte 11 0) delta) temp temp)
1435 (inst add src temp dst))))))
1437 ;; code = fn - header - label-offset + other-pointer-tag
1438 (define-instruction compute-code-from-fn (segment src label temp dst)
1439 (:declare (type tn src dst temp)
1443 (emit-compute-inst segment vop src label temp dst
1444 #'(lambda (label posn delta-if-after)
1445 (- other-pointer-lowtag
1446 (label-position label posn delta-if-after)
1447 (component-header-length))))))
1449 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1450 (define-instruction compute-code-from-lra (segment src label temp dst)
1451 (:declare (type tn src dst temp)
1455 (emit-compute-inst segment vop src label temp dst
1456 #'(lambda (label posn delta-if-after)
1457 (- (+ (label-position label posn delta-if-after)
1458 (component-header-length)))))))
1460 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1461 (define-instruction compute-lra-from-code (segment src label temp dst)
1462 (:declare (type tn src dst temp)
1466 (emit-compute-inst segment vop src label temp dst
1467 #'(lambda (label posn delta-if-after)
1468 (+ (label-position label posn delta-if-after)
1469 (component-header-length))))))
1472 ;;;; Data instructions.
1474 (define-instruction byte (segment byte)
1476 (emit-byte segment byte)))
1478 (define-bitfield-emitter emit-halfword 16
1481 (define-instruction halfword (segment halfword)
1483 (emit-halfword segment halfword)))
1485 (define-bitfield-emitter emit-word 32
1488 (define-instruction word (segment word)
1490 (emit-word segment word)))
1492 (define-instruction fun-header-word (segment)
1496 #'(lambda (segment posn)
1498 (logior simple-fun-header-widetag
1499 (ash (+ posn (component-header-length))
1500 (- n-widetag-bits word-shift))))))))
1502 (define-instruction lra-header-word (segment)
1506 #'(lambda (segment posn)
1508 (logior return-pc-header-widetag
1509 (ash (+ posn (component-header-length))
1510 (- n-widetag-bits word-shift))))))))