Support building without PSEUDO-ATOMIC on POSIX safepoints
[sbcl.git] / src / compiler / sparc / insts.lisp
1 ;;;; the instruction set definition for the Sparc
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15   (setf sb!assem:*assem-scheduler-p* t)
16   (setf sb!assem:*assem-max-locations* 100))
17 \f
18 ;;; Constants, types, conversion functions, some disassembler stuff.
19 (defun reg-tn-encoding (tn)
20   (declare (type tn tn))
21   (sc-case tn
22     (zero zero-offset)
23     (null null-offset)
24     (t
25      (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
26          (tn-offset tn)
27          (error "~S isn't a register." tn)))))
28
29 (defun fp-reg-tn-encoding (tn)
30   (declare (type tn tn))
31   (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
32     (error "~S isn't a floating-point register." tn))
33   (let ((offset (tn-offset tn)))
34     (cond ((> offset 31)
35            (aver (member :sparc-v9 *backend-subfeatures*))
36            ;; No single register encoding greater than reg 31.
37            (aver (zerop (mod offset 2)))
38            ;; Upper bit of the register number is encoded in the low bit.
39            (1+ (- offset 32)))
40           (t
41            (tn-offset tn)))))
42
43 ;;;(sb!disassem:set-disassem-params :instruction-alignment 32
44 ;;;                              :opcode-column-width 11)
45
46 (defvar *disassem-use-lisp-reg-names* t
47   #!+sb-doc
48   "If non-NIL, print registers using the Lisp register names.
49 Otherwise, use the Sparc register names")
50
51 (!def-vm-support-routine location-number (loc)
52   (etypecase loc
53     (null)
54     (number)
55     (fixup)
56     (tn
57      (ecase (sb-name (sc-sb (tn-sc loc)))
58        (registers
59         (unless (zerop (tn-offset loc))
60           (tn-offset loc)))
61        (float-registers
62         (sc-case loc
63           (single-reg
64            (+ (tn-offset loc) 32))
65           (double-reg
66            (let ((offset (tn-offset loc)))
67              (aver (zerop (mod offset 2)))
68              (values (+ offset 32) 2)))
69           #!+long-float
70           (long-reg
71            (let ((offset (tn-offset loc)))
72              (aver (zerop (mod offset 4)))
73              (values (+ offset 32) 4)))))
74        (control-registers
75         96)
76        (immediate-constant
77         nil)))
78     (symbol
79      (ecase loc
80        (:memory 0)
81        (:psr 97)
82        (:fsr 98)
83        (:y 99)))))
84
85 ;;; symbols used for disassembly printing
86 (defparameter reg-symbols
87   (map 'vector
88        (lambda (name)
89            (cond ((null name) nil)
90                  (t (make-symbol (concatenate 'string "%" name)))))
91        *register-names*)
92   #!+sb-doc "The Lisp names for the Sparc integer registers")
93
94 (defparameter sparc-reg-symbols
95   #("%G0" "%G1" "%G2" "%G3" "%G4" "%G5" NIL NIL
96     "%O0" "%O1" "%O2" "%O3" "%O4" "%O5" "%O6" "%O7"
97     "%L0" "%L1" "%L2" "%L3" "%L4" "%L5" "%L6" "%L7"
98     "%I0" "%I1" "%I2" "%I3" "%I4" "%I5" NIL "%I7")
99   #!+sb-doc "The standard names for the Sparc integer registers")
100
101 (defun get-reg-name (index)
102   (if *disassem-use-lisp-reg-names*
103       (aref reg-symbols index)
104       (aref sparc-reg-symbols index)))
105
106 (defvar *note-sethi-inst* nil
107   "An alist for the disassembler indicating the target register and
108 value used in a SETHI instruction.  This is used to make annotations
109 about function addresses and register values.")
110
111 (defvar *pseudo-atomic-set* nil)
112
113 (defun sign-extend-immed-value (val)
114   ;; val is a 13-bit signed number.  Extend the sign appropriately.
115   (if (logbitp 12 val)
116       (- val (ash 1 13))
117       val))
118
119 ;; Look at the current instruction and see if we can't add some notes
120 ;; about what's happening.
121
122 (defun maybe-add-notes (reg dstate)
123   (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
124                                       (sb!disassem::dstate-cur-offs dstate)
125                                       n-word-bytes
126                                       (sb!disassem::dstate-byte-order dstate)))
127          (format (ldb (byte 2 30) word))
128          (op3 (ldb (byte 6 19) word))
129          (rs1 (ldb (byte 5 14) word))
130          (rd (ldb (byte 5 25) word))
131          (immed-p (not (zerop (ldb (byte 1 13) word))))
132          (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
133     (declare (ignore immed-p))
134     ;; Only the value of format and rd are guaranteed to be correct
135     ;; because the disassembler is trying to print out the value of a
136     ;; register.  The other values may not be right.
137     (case format
138       (2
139        (case op3
140          (#b000000
141           (when (= reg rs1)
142             (handle-add-inst rs1 immed-val rd dstate)))
143          (#b111000
144           (when (= reg rs1)
145             (handle-jmpl-inst rs1 immed-val rd dstate)))
146          (#b010001
147           (when (= reg rs1)
148             (handle-andcc-inst rs1 immed-val rd dstate)))))
149       (3
150        (case op3
151          ((#b000000 #b000100)
152           (when (= reg rs1)
153             (handle-ld/st-inst rs1 immed-val rd dstate))))))
154     ;; If this is not a SETHI instruction, and RD is the same as some
155     ;; register used by SETHI, we delete the entry.  (In case we have
156     ;; a SETHI without any additional instruction because the low bits
157     ;; were zero.)
158     (unless (and (zerop format) (= #b100 (ldb (byte 3 22) word)))
159       (let ((sethi (assoc rd *note-sethi-inst*)))
160         (when sethi
161           (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))
162
163 (defun handle-add-inst (rs1 immed-val rd dstate)
164   (let* ((sethi (assoc rs1 *note-sethi-inst*)))
165     (cond
166       (sethi
167        ;; RS1 was used in a SETHI instruction.  Assume that
168        ;; this is the offset part of the SETHI instruction for
169        ;; a full 32-bit address of something.  Make a note
170        ;; about this usage as a Lisp assembly routine or
171        ;; foreign routine, if possible.  If not, just note the
172        ;; final value.
173        (let ((addr (+ immed-val (ash (cdr sethi) 10))))
174          (or (sb!disassem::note-code-constant-absolute addr dstate)
175              (sb!disassem:maybe-note-assembler-routine addr t dstate)
176              (sb!disassem:note (format nil "~A = #x~8,'0X"
177                                      (get-reg-name rd) addr)
178                              dstate)))
179        (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
180       ((= rs1 null-offset)
181        ;; We have an ADD %NULL, <n>, RD instruction.  This is a
182        ;; reference to a static symbol.
183        (sb!disassem:maybe-note-nil-indexed-object immed-val
184                                                dstate))
185       ((= rs1 alloc-offset)
186        ;; ADD %ALLOC, n.  This must be some allocation or
187        ;; pseudo-atomic stuff
188        (cond ((and (= immed-val 4) (= rd alloc-offset)
189                    (not *pseudo-atomic-set*))
190               ;; "ADD 4, %ALLOC" sets the flag
191               (sb!disassem::note "Set pseudo-atomic flag" dstate)
192               (setf *pseudo-atomic-set* t))
193              ((= rd alloc-offset)
194               ;; "ADD n, %ALLOC" is reseting the flag, with extra
195               ;; allocation.
196               (sb!disassem:note
197                (format nil "Reset pseudo-atomic, allocated ~D bytes"
198                        (+ immed-val 4)) dstate)
199               (setf *pseudo-atomic-set* nil))))
200       #+nil ((and (= rs1 zero-offset) *pseudo-atomic-set*)
201        ;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very
202        ;; likely loading up a header word.  Make a note to that
203        ;; effect.
204        (let ((type (second (assoc (logand immed-val #xff) header-word-type-alist)))
205              (size (ldb (byte 24 8) immed-val)))
206          (when type
207            (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
208                           dstate)))))))
209
210 (defun handle-jmpl-inst (rs1 immed-val rd dstate)
211   (declare (ignore rd))
212   (let* ((sethi (assoc rs1 *note-sethi-inst*)))
213     (when sethi
214       ;; RS1 was used in a SETHI instruction.  Assume that
215       ;; this is the offset part of the SETHI instruction for
216       ;; a full 32-bit address of something.  Make a note
217       ;; about this usage as a Lisp assembly routine or
218       ;; foreign routine, if possible.  If not, just note the
219       ;; final value.
220       (let ((addr (+ immed-val (ash (cdr sethi) 10))))
221         (sb!disassem:maybe-note-assembler-routine addr t dstate)
222         (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))
223
224 (defun handle-ld/st-inst (rs1 immed-val rd dstate)
225   (declare (ignore rd))
226   ;; Got an LDUW/LD or STW instruction, with immediate offset.
227   (case rs1
228     (29
229      ;; A reference to a code constant (reg = %CODE)
230      (sb!disassem:note-code-constant immed-val dstate))
231     (2
232      ;; A reference to a static symbol or static function (reg =
233      ;; %NULL)
234      (or (sb!disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
235                                                       dstate)
236          #+nil (sb!disassem::maybe-note-static-function immed-val dstate)))
237     (t
238      (let ((sethi (assoc rs1 *note-sethi-inst*)))
239        (when sethi
240          (let ((addr (+ immed-val (ash (cdr sethi) 10))))
241            (sb!disassem:maybe-note-assembler-routine addr nil dstate)
242            (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))
243
244 (defun handle-andcc-inst (rs1 immed-val rd dstate)
245   ;; ANDCC %ALLOC, 3, %ZERO instruction
246   (when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3))
247     (sb!disassem:note "pseudo-atomic interrupted?" dstate)))
248
249 (sb!disassem:define-arg-type reg
250   :printer (lambda (value stream dstate)
251                (declare (stream stream) (fixnum value))
252                (let ((regname (get-reg-name value)))
253                  (princ regname stream)
254                  (sb!disassem:maybe-note-associated-storage-ref value
255                                                                 'registers
256                                                                 regname
257                                                                 dstate)
258                  (maybe-add-notes value dstate))))
259
260 (defparameter float-reg-symbols
261   #.(coerce
262      (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
263      'vector))
264
265 (sb!disassem:define-arg-type fp-reg
266   :printer (lambda (value stream dstate)
267                (declare (stream stream) (fixnum value))
268                (let ((regname (aref float-reg-symbols value)))
269                  (princ regname stream)
270                  (sb!disassem:maybe-note-associated-storage-ref
271                   value
272                   'float-registers
273                   regname
274                   dstate))))
275
276 ;;; The extended 6 bit floating point register encoding for the double
277 ;;; and long instructions of the sparc v9.
278 (sb!disassem:define-arg-type fp-ext-reg
279   :printer (lambda (value stream dstate)
280                (declare (stream stream) (fixnum value))
281                (let* (;; Decode the register number.
282                       (value (if (oddp value) (+ value 31) value))
283                       (regname (aref float-reg-symbols value)))
284                  (princ regname stream)
285                  (sb!disassem:maybe-note-associated-storage-ref
286                   value
287                   'float-registers
288                   regname
289                   dstate))))
290
291 (sb!disassem:define-arg-type relative-label
292   :sign-extend t
293   :use-label (lambda (value dstate)
294                (declare (type (signed-byte 22) value)
295                         (type sb!disassem:disassem-state dstate))
296                (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
297
298 (defconstant-eqx branch-conditions
299   '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
300   #'equalp)
301
302 ;;; Note that these aren't the standard names for branch-conditions, I
303 ;;; think they're a bit more readable (e.g., "eq" instead of "e").
304 ;;; You could just put a vector of the normal ones here too.
305
306 (sb!disassem:define-arg-type branch-condition
307   :printer (coerce branch-conditions 'vector))
308
309 (deftype branch-condition ()
310   `(member ,@branch-conditions))
311
312 (defun branch-condition (condition)
313   (or (position condition branch-conditions)
314       (error "Unknown branch condition: ~S~%Must be one of: ~S"
315              condition branch-conditions)))
316
317 (def!constant branch-cond-true
318   #b1000)
319
320 (defconstant-eqx branch-fp-conditions
321   '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)
322   #'equalp)
323
324 (sb!disassem:define-arg-type branch-fp-condition
325   :printer (coerce branch-fp-conditions 'vector))
326
327 (sb!disassem:define-arg-type call-fixup :use-label t)
328
329 (deftype fp-branch-condition ()
330   `(member ,@branch-fp-conditions))
331
332 (defun fp-branch-condition (condition)
333   (or (position condition branch-fp-conditions)
334       (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
335              condition branch-fp-conditions)))
336
337 \f
338 ;;;; dissassem:define-instruction-formats
339
340 (sb!disassem:define-instruction-format
341     (format-1 32 :default-printer '(:name :tab disp))
342   (op   :field (byte 2 30) :value 1)
343   (disp :field (byte 30 0)))
344
345 (sb!disassem:define-instruction-format
346     (format-2-immed 32 :default-printer '(:name :tab immed ", " rd))
347   (op    :field (byte 2 30) :value 0)
348   (rd    :field (byte 5 25) :type 'reg)
349   (op2   :field (byte 3 22))
350   (immed :field (byte 22 0)))
351
352
353
354 (sb!disassem:define-instruction-format
355     (format-2-branch 32 :default-printer `(:name (:unless (:constant ,branch-cond-true) cond)
356                                            (:unless (a :constant 0) "," 'A)
357                                            :tab
358                                            disp))
359   (op   :field (byte 2 30) :value 0)
360   (a    :field (byte 1 29) :value 0)
361   (cond :field (byte 4 25) :type 'branch-condition)
362   (op2  :field (byte 3 22))
363   (disp :field (byte 22 0) :type 'relative-label))
364
365 ;; Branch with prediction instruction for V9
366
367 ;; Currently only %icc and %xcc are used of the four possible values
368
369 (defconstant-eqx integer-condition-registers
370   '(:icc :reserved :xcc :reserved)
371   #'equalp)
372
373 (defconstant-eqx integer-cond-reg-name-vec
374   (coerce integer-condition-registers 'vector)
375   #'equalp)
376
377 (deftype integer-condition-register ()
378   `(member ,@(remove :reserved integer-condition-registers)))
379
380 (defparameter integer-condition-reg-symbols
381   (map 'vector
382        (lambda (name)
383            (make-symbol (concatenate 'string "%" (string name))))
384        integer-condition-registers))
385
386 (sb!disassem:define-arg-type integer-condition-register
387     :printer (lambda (value stream dstate)
388                  (declare (stream stream) (fixnum value) (ignore dstate))
389                  (let ((regname (aref integer-condition-reg-symbols value)))
390                    (princ regname stream))))
391
392 (defconstant-eqx branch-predictions
393   '(:pn :pt)
394   #'equalp)
395
396 (sb!disassem:define-arg-type branch-prediction
397     :printer (coerce branch-predictions 'vector))
398
399 (defun integer-condition (condition-reg)
400   (declare (type (member :icc :xcc) condition-reg))
401   (or (position condition-reg integer-condition-registers)
402       (error "Unknown integer condition register:  ~S~%"
403              condition-reg)))
404
405 (defun branch-prediction (pred)
406   (or (position pred branch-predictions)
407       (error "Unknown branch prediction:  ~S~%Must be one of: ~S~%"
408              pred branch-predictions)))
409
410 (defconstant-eqx branch-pred-printer
411   `(:name (:unless (:constant ,branch-cond-true) cond)
412           (:unless (a :constant 0) "," 'A)
413           (:unless (p :constant 1) "," 'pn)
414           :tab
415           cc
416           ", "
417           disp)
418   #'equalp)
419
420 (sb!disassem:define-instruction-format
421     (format-2-branch-pred 32 :default-printer branch-pred-printer)
422   (op   :field (byte 2 30) :value 0)
423   (a    :field (byte 1 29) :value 0)
424   (cond :field (byte 4 25) :type 'branch-condition)
425   (op2  :field (byte 3 22))
426   (cc   :field (byte 2 20) :type 'integer-condition-register)
427   (p    :field (byte 1 19))
428   (disp :field (byte 19 0) :type 'relative-label))
429
430 (defconstant-eqx fp-condition-registers
431   '(:fcc0 :fcc1 :fcc2 :fcc3)
432   #'equalp)
433
434 (defconstant-eqx fp-cond-reg-name-vec
435   (coerce fp-condition-registers 'vector)
436   #'equalp)
437
438 (defparameter fp-condition-reg-symbols
439   (map 'vector
440        (lambda (name)
441            (make-symbol (concatenate 'string "%" (string name))))
442        fp-condition-registers))
443
444 (sb!disassem:define-arg-type fp-condition-register
445     :printer (lambda (value stream dstate)
446                  (declare (stream stream) (fixnum value) (ignore dstate))
447                  (let ((regname (aref fp-condition-reg-symbols value)))
448                    (princ regname stream))))
449
450 (sb!disassem:define-arg-type fp-condition-register-shifted
451     :printer (lambda (value stream dstate)
452                  (declare (stream stream) (fixnum value) (ignore dstate))
453                  (let ((regname (aref fp-condition-reg-symbols (ash value -1))))
454                    (princ regname stream))))
455
456 (defun fp-condition (condition-reg)
457   (or (position condition-reg fp-condition-registers)
458       (error "Unknown integer condition register:  ~S~%"
459              condition-reg)))
460
461 (defconstant-eqx fp-branch-pred-printer
462   `(:name (:unless (:constant ,branch-cond-true) cond)
463           (:unless (a :constant 0) "," 'A)
464           (:unless (p :constant 1) "," 'pn)
465           :tab
466           fcc
467           ", "
468           disp)
469   #'equalp)
470
471 (sb!disassem:define-instruction-format
472     (format-2-fp-branch-pred 32 :default-printer fp-branch-pred-printer)
473   (op   :field (byte 2 30) :value 0)
474   (a    :field (byte 1 29) :value 0)
475   (cond :field (byte 4 25) :type 'branch-fp-condition)
476   (op2  :field (byte 3 22))
477   (fcc  :field (byte 2 20) :type 'fp-condition-register)
478   (p    :field (byte 1 19))
479   (disp :field (byte 19 0) :type 'relative-label))
480
481
482
483 (sb!disassem:define-instruction-format
484     (format-2-unimp 32 :default-printer '(:name :tab data))
485   (op     :field (byte 2 30) :value 0)
486   (ignore :field (byte 5 25) :value 0)
487   (op2    :field (byte 3 22) :value 0)
488   (data   :field (byte 22 0)))
489
490 (defconstant-eqx f3-printer
491   '(:name :tab
492           (:unless (:same-as rd) rs1 ", ")
493           (:choose rs2 immed) ", "
494           rd)
495   #'equalp)
496
497 (sb!disassem:define-instruction-format
498     (format-3-reg 32 :default-printer f3-printer)
499   (op  :field (byte 2 30))
500   (rd  :field (byte 5 25) :type 'reg)
501   (op3 :field (byte 6 19))
502   (rs1 :field (byte 5 14) :type 'reg)
503   (i   :field (byte 1 13) :value 0)
504   (asi :field (byte 8 5)  :value 0)
505   (rs2 :field (byte 5 0)  :type 'reg))
506
507 (sb!disassem:define-instruction-format
508     (format-3-immed 32 :default-printer f3-printer)
509   (op    :field (byte 2 30))
510   (rd    :field (byte 5 25) :type 'reg)
511   (op3   :field (byte 6 19))
512   (rs1   :field (byte 5 14) :type 'reg)
513   (i     :field (byte 1 13) :value 1)
514   (immed :field (byte 13 0) :sign-extend t))    ; usually sign extended
515
516 (sb!disassem:define-instruction-format
517     (format-binary-fpop 32
518      :default-printer '(:name :tab rs1 ", " rs2 ", " rd))
519   (op   :field (byte 2 30))
520   (rd   :field (byte 5 25) :type 'fp-reg)
521   (op3  :field (byte 6 19))
522   (rs1  :field (byte 5 14) :type 'fp-reg)
523   (opf  :field (byte 9 5))
524   (rs2  :field (byte 5 0) :type 'fp-reg))
525
526 ;;; Floating point load/save instructions encoding.
527 (sb!disassem:define-instruction-format
528     (format-unary-fpop 32 :default-printer '(:name :tab rs2 ", " rd))
529   (op   :field (byte 2 30))
530   (rd   :field (byte 5 25) :type 'fp-reg)
531   (op3  :field (byte 6 19))
532   (rs1  :field (byte 5 14) :value 0)
533   (opf  :field (byte 9 5))
534   (rs2  :field (byte 5 0) :type 'fp-reg))
535
536 ;;; Floating point comparison instructions encoding.
537
538 ;; This is a merge of the instructions for FP comparison and FP
539 ;; conditional moves available in the Sparc V9.  The main problem is
540 ;; that the new instructions use part of the opcode space used by the
541 ;; comparison instructions.  In particular, the OPF field is arranged
542 ;; as so:
543 ;;
544 ;; Bit          1       0
545 ;;              3       5
546 ;; FMOVcc       0nn0000xx       %fccn
547 ;;              1000000xx       %icc
548 ;;              1100000xx       %xcc
549 ;; FMOVR        0ccc001yy
550 ;; FCMP         001010zzz
551 ;;
552 ;; So we see that if we break up the OPF field into 4 pieces, opf0,
553 ;; opf1, opf2, and opf3, we can distinguish between these
554 ;; instructions. So bit 9 (opf2) can be used to distinguish between
555 ;; FCMP and the rest.  Also note that the nn field overlaps with the
556 ;; ccc.  We need to take this into account as well.
557 ;;
558 (sb!disassem:define-instruction-format
559     (format-fpop2 32
560                   :default-printer #!-sparc-v9 '(:name :tab rs1 ", " rs2)
561                                    #!+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2))
562   (op   :field (byte 2 30))
563   (rd   :field (byte 5 25) :value 0)
564   (op3  :field (byte 6 19))
565   (rs1  :field (byte 5 14))
566   (opf0 :field (byte 1 13))
567   (opf1 :field (byte 3 10))
568   (opf2 :field (byte 1 9))
569   (opf3 :field (byte 4 5))
570   (rs2  :field (byte 5 0) :type 'fp-reg))
571
572 ;;; Shift instructions
573 (sb!disassem:define-instruction-format
574     (format-3-shift-reg 32 :default-printer f3-printer)
575   (op   :field (byte 2 30))
576   (rd    :field (byte 5 25) :type 'reg)
577   (op3  :field (byte 6 19))
578   (rs1   :field (byte 5 14) :type 'reg)
579   (i     :field (byte 1 13) :value 0)
580   (x     :field (byte 1 12))
581   (asi   :field (byte 7 5) :value 0)
582   (rs2   :field (byte 5 0) :type 'reg))
583
584 (sb!disassem:define-instruction-format
585     (format-3-shift-immed 32 :default-printer f3-printer)
586   (op   :field (byte 2 30))
587   (rd    :field (byte 5 25) :type 'reg)
588   (op3  :field (byte 6 19))
589   (rs1   :field (byte 5 14) :type 'reg)
590   (i     :field (byte 1 13) :value 1)
591   (x     :field (byte 1 12))
592   (immed :field (byte 12 0) :sign-extend nil))
593
594 \f
595 ;;; Conditional moves (only available for Sparc V9 architectures)
596
597 ;; The names of all of the condition registers on the V9: 4 FP
598 ;; conditions, the original integer condition register and the new
599 ;; extended register.  The :reserved register is reserved on the V9.
600
601 (defconstant-eqx cond-move-condition-registers
602   '(:fcc0 :fcc1 :fcc2 :fcc3 :icc :reserved :xcc :reserved)
603   #'equalp)
604
605 (defconstant-eqx cond-move-cond-reg-name-vec
606   (coerce cond-move-condition-registers 'vector)
607   #'equalp)
608
609 (deftype cond-move-condition-register ()
610     `(member ,@(remove :reserved cond-move-condition-registers)))
611
612 (defparameter cond-move-condition-reg-symbols
613   (map 'vector
614        (lambda (name)
615            (make-symbol (concatenate 'string "%" (string name))))
616        cond-move-condition-registers))
617
618 (sb!disassem:define-arg-type cond-move-condition-register
619     :printer (lambda (value stream dstate)
620                  (declare (stream stream) (fixnum value) (ignore dstate))
621                  (let ((regname (aref cond-move-condition-reg-symbols value)))
622                    (princ regname stream))))
623
624 ;; From the given condition register, figure out what the cc2, cc1,
625 ;; and cc0 bits should be.  Return cc2 and cc1/cc0 concatenated.
626 (defun cond-move-condition-parts (condition-reg)
627   (let ((posn (position condition-reg cond-move-condition-registers)))
628     (if posn
629         (truncate posn 4)
630         (error "Unknown conditional move condition register:  ~S~%"
631                condition-reg))))
632
633 (defun cond-move-condition (condition-reg)
634   (or (position condition-reg cond-move-condition-registers)
635       (error "Unknown conditional move condition register:  ~S~%"
636              condition-reg)))
637
638 (defconstant-eqx cond-move-printer
639   `(:name cond :tab
640           cc ", " (:choose immed rs2) ", " rd)
641   #'equalp)
642
643 ;; Conditional move integer register on integer or FP condition code
644 (sb!disassem:define-instruction-format
645     (format-4-cond-move 32 :default-printer cond-move-printer)
646   (op   :field (byte 2 30))
647   (rd    :field (byte 5 25) :type 'reg)
648   (op3  :field (byte 6 19))
649   (cc2   :field (byte 1 18) :value 1)
650   (cond  :field (byte 4 14) :type 'branch-condition)
651   (i     :field (byte 1 13) :value 0)
652   (cc    :field (byte 2 11) :type 'integer-condition-register)
653   (empty :field (byte 6 5) :value 0)
654   (rs2   :field (byte 5 0) :type 'reg))
655
656 (sb!disassem:define-instruction-format
657     (format-4-cond-move-immed 32 :default-printer cond-move-printer)
658   (op    :field (byte 2 30))
659   (rd    :field (byte 5 25) :type 'reg)
660   (op3   :field (byte 6 19))
661   (cc2   :field (byte 1 18) :value 1)
662   (cond  :field (byte 4 14) :type 'branch-condition)
663   (i     :field (byte 1 13) :value 1)
664   (cc    :field (byte 2 11) :type 'integer-condition-register)
665   (immed :field (byte 11 0) :sign-extend t))
666
667 ;; Floating-point versions of the above integer conditional moves
668 (defconstant-eqx cond-fp-move-printer
669   `(:name rs1 :tab opf1 ", " rs2 ", " rd)
670   #'equalp)
671
672 ;;; Conditional move on integer register condition (only on Sparc
673 ;;; V9). That is, move an integer register if some other integer
674 ;;; register satisfies some condition.
675
676 (defconstant-eqx cond-move-integer-conditions
677   '(:reserved :z :lez :lz :reserved :nz :gz :gez)
678   #'equalp)
679
680 (defconstant-eqx cond-move-integer-condition-vec
681   (coerce cond-move-integer-conditions 'vector)
682   #'equalp)
683
684 (deftype cond-move-integer-condition ()
685   `(member ,@(remove :reserved cond-move-integer-conditions)))
686
687 (sb!disassem:define-arg-type register-condition
688     :printer (lambda (value stream dstate)
689                  (declare (stream stream) (fixnum value) (ignore dstate))
690                  (let ((regname (aref cond-move-integer-condition-vec value)))
691                    (princ regname stream))))
692
693 (defconstant-eqx cond-move-integer-printer
694   `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)
695   #'equalp)
696
697 (defun register-condition (rcond)
698   (or (position rcond cond-move-integer-conditions)
699       (error "Unknown register condition:  ~S~%" rcond)))
700
701 (sb!disassem:define-instruction-format
702     (format-4-cond-move-integer 32 :default-printer cond-move-integer-printer)
703   (op    :field (byte 2 30))
704   (rd    :field (byte 5 25) :type 'reg)
705   (op3   :field (byte 6 19))
706   (rs1   :field (byte 5 14) :type 'reg)
707   (i     :field (byte 1 13) :value 0)
708   (rcond :field (byte 3 10) :type 'register-condition)
709   (opf   :field (byte 5 5))
710   (rs2   :field (byte 5 0) :type 'reg))
711
712 (sb!disassem:define-instruction-format
713     (format-4-cond-move-integer-immed 32 :default-printer cond-move-integer-printer)
714   (op    :field (byte 2 30))
715   (rd    :field (byte 5 25) :type 'reg)
716   (op3   :field (byte 6 19))
717   (rs1   :field (byte 5 14) :type 'reg)
718   (i     :field (byte 1 13) :value 1)
719   (rcond :field (byte 3 10) :type 'register-condition)
720   (immed :field (byte 10 0) :sign-extend t))
721
722 (defconstant-eqx trap-printer
723   `(:name rd :tab cc ", " immed)
724   #'equalp)
725
726 (sb!disassem:define-instruction-format
727     (format-4-trap 32 :default-printer trap-printer)
728   (op    :field (byte 2 30))
729   (rd    :field (byte 5 25) :type 'reg)
730   (op3   :field (byte 6 19))
731   (rs1   :field (byte 5 14) :type 'reg)
732   (i     :field (byte 1 13) :value 1)
733   (cc    :field (byte 2 11) :type 'integer-condition-register)
734   (immed :field (byte 11 0) :sign-extend t))    ; usually sign extended
735
736
737 (defconstant-eqx cond-fp-move-integer-printer
738   `(:name opf1 :tab rs1 ", " rs2 ", " rd)
739   #'equalp)
740
741 \f
742 ;;;; Primitive emitters.
743
744 (define-bitfield-emitter emit-word 32
745   (byte 32 0))
746
747 (define-bitfield-emitter emit-short 16
748   (byte 16 0))
749
750 (define-bitfield-emitter emit-format-1 32
751   (byte 2 30) (byte 30 0))
752
753 (define-bitfield-emitter emit-format-2-immed 32
754   (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
755
756 (define-bitfield-emitter emit-format-2-branch 32
757   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
758
759 ;; Integer and FP branches with prediction for V9
760 (define-bitfield-emitter emit-format-2-branch-pred 32
761   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
762 (define-bitfield-emitter emit-format-2-fp-branch-pred 32
763   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
764
765 (define-bitfield-emitter emit-format-2-unimp 32
766   (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
767
768 (define-bitfield-emitter emit-format-3-reg 32
769   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
770   (byte 5 0))
771
772 (define-bitfield-emitter emit-format-3-immed 32
773   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
774
775 (define-bitfield-emitter emit-format-3-fpop 32
776   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
777
778 (define-bitfield-emitter emit-format-3-fpop2 32
779   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14)
780   (byte 1 13) (byte 3 10) (byte 1 9) (byte 4 5)
781   (byte 5 0))
782
783 ;;; Shift instructions
784
785 (define-bitfield-emitter emit-format-3-shift-reg 32
786   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 7 5)
787   (byte 5 0))
788
789 (define-bitfield-emitter emit-format-3-shift-immed 32
790   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 12 0))
791
792 ;;; Conditional moves
793
794 ;; Conditional move in condition code
795 (define-bitfield-emitter emit-format-4-cond-move 32
796   (byte 2 30) (byte 5 25) (byte 6 19) (byte 1 18) (byte 4 14) (byte 1 13) (byte 2 11)
797   (byte 11 0))
798
799 ;; Conditional move on integer condition
800 (define-bitfield-emitter emit-format-4-cond-move-integer 32
801   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) (byte 5 5)
802   (byte 5 0))
803
804 (define-bitfield-emitter emit-format-4-cond-move-integer-immed 32
805   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10)
806   (byte 10 0))
807
808 (define-bitfield-emitter emit-format-4-trap 32
809   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11)
810   (byte 11 0))
811
812 \f
813 ;;;; Most of the format-3-instructions.
814
815 (defun emit-format-3-inst (segment op op3 dst src1 src2
816                                    &key load-store fixup dest-kind)
817   (unless src2
818     (cond ((and (typep src1 'tn) load-store)
819            (setf src2 0))
820           (t
821            (setf src2 src1)
822            (setf src1 dst))))
823   (etypecase src2
824     (tn
825      (emit-format-3-reg segment op
826                         (if dest-kind
827                             (fp-reg-tn-encoding dst)
828                             (reg-tn-encoding dst))
829                         op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
830     (integer
831      (emit-format-3-immed segment op
832                           (if dest-kind
833                               (fp-reg-tn-encoding dst)
834                               (reg-tn-encoding dst))
835                           op3 (reg-tn-encoding src1) 1 src2))
836     (fixup
837      (unless (or load-store fixup)
838        (error "Fixups aren't allowed."))
839      (note-fixup segment :add src2)
840      (emit-format-3-immed segment op
841                           (if dest-kind
842                               (fp-reg-tn-encoding dst)
843                               (reg-tn-encoding dst))
844                           op3 (reg-tn-encoding src1) 1 0))))
845
846 ;;; Shift instructions because an extra bit is used in Sparc V9's to
847 ;;; indicate whether the shift is a 32-bit or 64-bit shift.
848 ;;;
849 (defun emit-format-3-shift-inst (segment op op3 dst src1 src2 &key extended)
850   (unless src2
851     (setf src2 src1)
852     (setf src1 dst))
853   (etypecase src2
854     (tn
855      (emit-format-3-shift-reg segment op (reg-tn-encoding dst)
856                               op3 (reg-tn-encoding src1) 0 (if extended 1 0)
857                               0 (reg-tn-encoding src2)))
858     (integer
859      (emit-format-3-shift-immed segment op (reg-tn-encoding dst)
860                                 op3 (reg-tn-encoding src1) 1
861                                 (if extended 1 0) src2))))
862
863
864 (eval-when (:compile-toplevel :execute)
865
866 ;;; have to do this because def!constant is evalutated in the null lex env.
867 (defmacro with-ref-format (printer)
868   `(let* ((addend
869            '(:choose (:plus-integer immed) ("+" rs2)))
870           (ref-format
871            `("[" rs1 (:unless (:constant 0) ,addend) "]"
872              (:choose (:unless (:constant 0) asi) nil))))
873      ,printer))
874
875 (defconstant-eqx load-printer
876   (with-ref-format `(:NAME :TAB ,ref-format ", " rd))
877   #'equalp)
878
879 (defconstant-eqx store-printer
880   (with-ref-format `(:NAME :TAB rd ", " ,ref-format))
881   #'equalp)
882
883 ) ; EVAL-WHEN
884
885 (macrolet ((define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
886                                  (printer :default) reads writes flushable print-name)
887   (let ((printer
888          (if (eq printer :default)
889              (case load-store
890                ((nil) :default)
891                ((:load t) 'load-printer)
892                (:store 'store-printer))
893              printer)))
894     (when (and (atom reads) (not (null reads)))
895       (setf reads (list reads)))
896     (when (and (atom writes) (not (null writes)))
897        (setf writes (list writes)))
898     `(define-instruction ,name (segment dst src1 &optional src2)
899        (:declare (type tn dst)
900                  ,(if (or fixup load-store)
901                       '(type (or tn (signed-byte 13) null fixup) src1 src2)
902                       '(type (or tn (signed-byte 13) null) src1 src2)))
903        (:printer format-3-reg
904                  ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
905                  ,printer
906                  ,@(when print-name `(:print-name ,print-name)))
907        (:printer format-3-immed
908                  ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
909                  ,printer
910                  ,@(when print-name `(:print-name ,print-name)))
911        ,@(when flushable
912            '((:attributes flushable)))
913        (:dependencies
914         (reads src1)
915         ,@(let ((reads-list nil))
916             (dolist (read reads)
917               (push (list 'reads read) reads-list))
918             reads-list)
919         ,@(cond ((eq load-store :store)
920                  '((reads dst)
921                    (if src2 (reads src2))))
922                  ((eq load-store t)
923                   '((reads :memory)
924                     (reads dst)
925                     (if src2 (reads src2))))
926                 ((eq load-store :load)
927                  '((reads :memory)
928                    (if src2 (reads src2) (reads dst))))
929                 (t
930                  '((if src2 (reads src2) (reads dst)))))
931         ,@(let ((writes-list nil))
932             (dolist (write writes)
933               (push (list 'writes write) writes-list))
934             writes-list)
935         ,@(cond ((eq load-store :store)
936                  '((writes :memory :partially t)))
937                 ((eq load-store t)
938                  '((writes :memory :partially t)
939                    (writes dst)))
940                 ((eq load-store :load)
941                  '((writes dst)))
942                 (t
943                  '((writes dst)))))
944        (:delay 0)
945        (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
946                                      :load-store ,load-store
947                                      :fixup ,fixup
948                                      :dest-kind (not (eq ',dest-kind 'reg)))))))
949
950            (define-f3-shift-inst (name op op3 &key extended)
951                `(define-instruction ,name (segment dst src1 &optional src2)
952                  (:declare (type tn dst)
953                   (type (or tn (unsigned-byte 6) null) src1 src2))
954                  (:printer format-3-shift-reg
955                   ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
956                  (:printer format-3-shift-immed
957                   ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
958                  (:dependencies
959                   (reads src1)
960                   (if src2 (reads src2) (reads dst))
961                   (writes dst))
962                  (:delay 0)
963                  (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
964                             :extended ,extended)))))
965
966   (define-f3-inst ldsb #b11 #b001001 :load-store :load)
967   (define-f3-inst ldsh #b11 #b001010 :load-store :load)
968   (define-f3-inst ldub #b11 #b000001 :load-store :load)
969   (define-f3-inst lduh #b11 #b000010 :load-store :load)
970
971   ;; This instruction is called lduw for V9 , but looks exactly like ld
972   ;; on previous architectures.
973   (define-f3-inst ld #b11 #b000000 :load-store :load
974                   #!+sparc-v9 :print-name #!+sparc-v9 'lduw)
975
976   (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9
977
978   ;; ldd is deprecated on the Sparc V9.
979   (define-f3-inst ldd #b11 #b000011 :load-store :load)
980
981   (define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9
982
983   (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
984   (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
985   (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-reg :load-store :load)       ; v9
986   (define-f3-inst stb #b11 #b000101 :load-store :store)
987   (define-f3-inst sth #b11 #b000110 :load-store :store)
988   (define-f3-inst st #b11 #b000100 :load-store :store)
989
990   ;; std is deprecated on the Sparc V9.
991   (define-f3-inst std #b11 #b000111 :load-store :store)
992
993   (define-f3-inst stx #b11 #b001110 :load-store :store) ; v9
994
995   (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
996   (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
997   (define-f3-inst stqf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9
998   (define-f3-inst ldstub #b11 #b001101 :load-store t)
999
1000   ;; swap is deprecated on the Sparc V9
1001   (define-f3-inst swap #b11 #b001111 :load-store t)
1002
1003   (define-f3-inst add #b10 #b000000 :fixup t)
1004   (define-f3-inst addcc #b10 #b010000 :writes :psr)
1005   (define-f3-inst addx #b10 #b001000 :reads :psr)
1006   (define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr)
1007   (define-f3-inst taddcc #b10 #b100000 :writes :psr)
1008
1009   ;; taddcctv is deprecated on the Sparc V9.  Use taddcc and bpvs or
1010   ;; taddcc and trap to get a similar effect.  (Requires changing the C
1011   ;; code though!)
1012   ;;(define-f3-inst taddcctv #b10 #b100010 :writes :psr)
1013
1014   (define-f3-inst sub #b10 #b000100)
1015   (define-f3-inst subcc #b10 #b010100 :writes :psr)
1016   (define-f3-inst subx #b10 #b001100 :reads :psr)
1017   (define-f3-inst subxcc #b10 #b011100 :reads :psr :writes :psr)
1018   (define-f3-inst tsubcc #b10 #b100001 :writes :psr)
1019
1020   ;; tsubcctv is deprecated on the Sparc V9.  Use tsubcc and bpvs or
1021   ;; tsubcc and trap to get a similar effect.  (Requires changing the C
1022   ;; code though!)
1023   ;;(define-f3-inst tsubcctv #b10 #b100011 :writes :psr)
1024
1025   (define-f3-inst mulscc #b10 #b100100 :reads :y :writes (:psr :y))
1026   (define-f3-inst and #b10 #b000001)
1027   (define-f3-inst andcc #b10 #b010001 :writes :psr)
1028   (define-f3-inst andn #b10 #b000101)
1029   (define-f3-inst andncc #b10 #b010101 :writes :psr)
1030   (define-f3-inst or #b10 #b000010)
1031   (define-f3-inst orcc #b10 #b010010 :writes :psr)
1032   (define-f3-inst orn #b10 #b000110)
1033   (define-f3-inst orncc #b10 #b010110 :writes :psr)
1034   (define-f3-inst xor #b10 #b000011)
1035   (define-f3-inst xorcc #b10 #b010011 :writes :psr)
1036   (define-f3-inst xnor #b10 #b000111)
1037   (define-f3-inst xnorcc #b10 #b010111 :writes :psr)
1038
1039   (define-f3-shift-inst sll #b10 #b100101)
1040   (define-f3-shift-inst srl #b10 #b100110)
1041   (define-f3-shift-inst sra #b10 #b100111)
1042   (define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9
1043   (define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9
1044   (define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9
1045
1046   (define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
1047   (define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)
1048
1049   ;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are
1050   ;; deprecated on the Sparc V9.  Use mulx, sdivx, and udivx instead.
1051   (define-f3-inst smul #b10 #b001011 :writes :y)                        ; v8
1052   (define-f3-inst smulcc #b10 #b011011 :writes (:psr :y))               ; v8
1053   (define-f3-inst umul #b10 #b001010 :writes :y)                        ; v8
1054   (define-f3-inst umulcc #b10 #b011010 :writes (:psr :y))               ; v8
1055   (define-f3-inst sdiv #b10 #b001111 :reads :y)                 ; v8
1056   (define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr)  ; v8
1057   (define-f3-inst udiv #b10 #b001110 :reads :y)                 ; v8
1058   (define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr)  ; v8
1059
1060   (define-f3-inst mulx #b10 #b001001)   ; v9 for both signed and unsigned
1061   (define-f3-inst sdivx #b10 #b101101)  ; v9
1062   (define-f3-inst udivx #b10 #b001101)  ; v9
1063
1064   (define-f3-inst popc #b10 #b101110)   ; v9: count one bits
1065
1066 ) ; MACROLET
1067
1068 \f
1069 ;;;; Random instructions.
1070
1071 ;; ldfsr is deprecated on the Sparc V9.  Use ldxfsr instead
1072 (define-instruction ldfsr (segment src1 src2)
1073   (:declare (type tn src1) (type (signed-byte 13) src2))
1074   (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 0)))
1075   :pinned
1076   (:delay 0)
1077   (:emitter (emit-format-3-immed segment #b11 0 #b100001
1078                                  (reg-tn-encoding src1) 1 src2)))
1079
1080 #!+sparc-64
1081 (define-instruction ldxfsr (segment src1 src2)
1082   (:declare (type tn src1) (type (signed-byte 13) src2))
1083   (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1))
1084             '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
1085             :print-name 'ldx)
1086   :pinned
1087   (:delay 0)
1088   (:emitter (emit-format-3-immed segment #b11 1 #b100001
1089                                  (reg-tn-encoding src1) 1 src2)))
1090
1091 ;; stfsr is deprecated on the Sparc V9.  Use stxfsr instead.
1092 (define-instruction stfsr (segment src1 src2)
1093   (:declare (type tn src1) (type (signed-byte 13) src2))
1094   (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0)))
1095   :pinned
1096   (:delay 0)
1097   (:emitter (emit-format-3-immed segment #b11 0 #b100101
1098                                  (reg-tn-encoding src1) 1 src2)))
1099
1100 #!+sparc-64
1101 (define-instruction stxfsr (segment src1 src2)
1102   (:declare (type tn src1) (type (signed-byte 13) src2))
1103   (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1))
1104             '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
1105             :print-name 'stx)
1106   :pinned
1107   (:delay 0)
1108   (:emitter (emit-format-3-immed segment #b11 1 #b100101
1109                                  (reg-tn-encoding src1) 1 src2)))
1110
1111 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
1112   (defun sethi-arg-printer (value stream dstate)
1113     (format stream "%hi(#x~8,'0x)" (ash value 10))
1114     ;; Save the immediate value and the destination register from this
1115     ;; sethi instruction.  This is used later to print some possible
1116     ;; notes about the value loaded by sethi.
1117     (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
1118                                            (sb!disassem::dstate-cur-offs dstate)
1119                                            n-word-bytes
1120                                            (sb!disassem::dstate-byte-order dstate)))
1121            (imm22 (ldb (byte 22 0) word))
1122            (rd (ldb (byte 5 25) word)))
1123       (push (cons rd imm22) *note-sethi-inst*)))
1124 ) ; EVAL-WHEN
1125
1126
1127 (define-instruction sethi (segment dst src1)
1128   (:declare (type tn dst)
1129             (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
1130   (:printer format-2-immed
1131             ((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
1132   (:dependencies (writes dst))
1133   (:delay 0)
1134   (:emitter
1135    (etypecase src1
1136      (integer
1137       (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
1138                                  src1))
1139      (fixup
1140       (note-fixup segment :sethi src1)
1141       (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
1142
1143 ;; rdy is deprecated on the Sparc V9.  It's not needed with 64-bit
1144 ;; registers.
1145 (define-instruction rdy (segment dst)
1146   (:declare (type tn dst))
1147   (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
1148             '('RD :tab '%Y ", " rd))
1149   (:dependencies (reads :y) (writes dst))
1150   (:delay 0)
1151   (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b101000
1152                                0 0 0 0)))
1153
1154 (defconstant-eqx wry-printer
1155   '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
1156   #'equalp)
1157
1158 ;; wry is deprecated on the Sparc V9.  It's not needed with 64-bit
1159 ;; registers.
1160 (define-instruction wry (segment src1 &optional src2)
1161   (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
1162   (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
1163   (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
1164   (:dependencies (reads src1) (if src2 (reads src2)) (writes :y))
1165   (:delay 3)
1166   (:emitter
1167    (etypecase src2
1168      (null
1169       (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
1170      (tn
1171       (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
1172                          (reg-tn-encoding src2)))
1173      (integer
1174       (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
1175                            src2)))))
1176
1177 (defun snarf-error-junk (sap offset &optional length-only)
1178   (let* ((length (sb!sys:sap-ref-8 sap offset))
1179          (vector (make-array length :element-type '(unsigned-byte 8))))
1180     (declare (type sb!sys:system-area-pointer sap)
1181              (type (unsigned-byte 8) length)
1182              (type (simple-array (unsigned-byte 8) (*)) vector))
1183     (cond (length-only
1184            (values 0 (1+ length) nil nil))
1185           (t
1186            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
1187                                                 vector 0 length)
1188            (collect ((sc-offsets)
1189                      (lengths))
1190              (lengths 1)                ; the length byte
1191              (let* ((index 0)
1192                     (error-number (sb!c:read-var-integer vector index)))
1193                (lengths index)
1194                (loop
1195                  (when (>= index length)
1196                    (return))
1197                  (let ((old-index index))
1198                    (sc-offsets (sb!c:read-var-integer vector index))
1199                    (lengths (- index old-index))))
1200                (values error-number
1201                        (1+ length)
1202                        (sc-offsets)
1203                        (lengths))))))))
1204
1205 (defun unimp-control (chunk inst stream dstate)
1206   (declare (ignore inst))
1207   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1208     (case (format-2-unimp-data chunk dstate)
1209       (#.error-trap
1210        (nt "Error trap")
1211        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1212       (#.cerror-trap
1213        (nt "Cerror trap")
1214        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1215       (#.object-not-list-trap
1216        (nt "Object not list trap"))
1217       (#.breakpoint-trap
1218        (nt "Breakpoint trap"))
1219       (#.pending-interrupt-trap
1220        (nt "Pending interrupt trap"))
1221       (#.halt-trap
1222        (nt "Halt trap"))
1223       (#.fun-end-breakpoint-trap
1224        (nt "Function end breakpoint trap"))
1225       (#.object-not-instance-trap
1226        (nt "Object not instance trap"))
1227     )))
1228
1229 (define-instruction unimp (segment data)
1230   (:declare (type (unsigned-byte 22) data))
1231   (:printer format-2-unimp () :default :control #'unimp-control
1232             :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
1233   (:delay 0)
1234   (:emitter (emit-format-2-unimp segment 0 0 0 data)))
1235
1236
1237 \f
1238 ;;;; Branch instructions.
1239
1240 ;; The branch instruction is deprecated on the Sparc V9.  Use the
1241 ;; branch with prediction instructions instead.
1242 (defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
1243   (emit-back-patch segment 4
1244     (lambda (segment posn)
1245         (unless target
1246           (setf target cond-or-target)
1247           (setf cond-or-target :t))
1248         (emit-format-2-branch
1249           segment #b00 a
1250           (if fp
1251               (fp-branch-condition cond-or-target)
1252               (branch-condition cond-or-target))
1253           op2
1254           (let ((offset (ash (- (label-position target) posn) -2)))
1255             (when (and (= a 1) (> 0 offset))
1256               (error "Offset of BA must be positive"))
1257             offset)))))
1258
1259 (defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
1260   (declare (type integer-condition-register cc))
1261   (aver (member :sparc-v9 *backend-subfeatures*))
1262   (emit-back-patch segment 4
1263     (lambda (segment posn)
1264         (unless target
1265           (setf target cond-or-target)
1266           (setf cond-or-target :t))
1267         (emit-format-2-branch-pred
1268           segment #b00 a
1269           (branch-condition cond-or-target)
1270           op2
1271           (integer-condition cc)
1272           (branch-prediction pred)
1273           (let ((offset (ash (- (label-position target) posn) -2)))
1274             (when (and (= a 1) (> 0 offset))
1275               (error "Offset of BA must be positive"))
1276             offset)))))
1277
1278 (defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
1279   (aver (member :sparc-v9 *backend-subfeatures*))
1280   (emit-back-patch segment 4
1281     (lambda (segment posn)
1282         (unless target
1283           (setf target cond-or-target)
1284           (setf cond-or-target :t))
1285         (emit-format-2-branch-pred
1286           segment #b00 a
1287           (fp-branch-condition cond-or-target)
1288           op2
1289           (fp-condition cc)
1290           (branch-prediction pred)
1291           (let ((offset (ash (- (label-position target) posn) -2)))
1292             (when (and (= a 1) (> 0 offset))
1293               (error "Offset of BA must be positive"))
1294             offset)))))
1295
1296 ;; So that I don't have to go change the syntax of every single use of
1297 ;; branches, I'm keeping the Lisp instruction names the same.  They
1298 ;; just get translated to the branch with prediction
1299 ;; instructions. However, the disassembler uses the correct V9
1300 ;; mnemonic.
1301 (define-instruction b (segment cond-or-target &rest args)
1302   (:declare (type (or label branch-condition) cond-or-target))
1303   (:printer format-2-branch ((op #b00) (op2 #b010)))
1304   (:attributes branch)
1305   (:dependencies (reads :psr))
1306   (:delay 1)
1307   (:emitter
1308    (cond
1309      ((member :sparc-v9 *backend-subfeatures*)
1310       (destructuring-bind (&optional target pred cc) args
1311         (declare (type (or label null) target))
1312         (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1313      (t
1314       (destructuring-bind (&optional target) args
1315         (declare (type (or label null) target))
1316         (emit-relative-branch segment 0 #b010 cond-or-target target))))))
1317
1318 (define-instruction bp (segment cond-or-target &optional target pred cc)
1319   (:declare (type (or label branch-condition) cond-or-target)
1320             (type (or label null) target))
1321   (:printer format-2-branch-pred ((op #b00) (op2 #b001))
1322             branch-pred-printer
1323             :print-name 'bp)
1324   (:attributes branch)
1325   (:dependencies (reads :psr))
1326   (:delay 1)
1327   (:emitter
1328    (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1329
1330 (define-instruction ba (segment cond-or-target &rest args)
1331   (:declare (type (or label branch-condition) cond-or-target))
1332   (:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
1333             nil
1334             :print-name 'b)
1335   (:attributes branch)
1336   (:dependencies (reads :psr))
1337   (:delay 0)
1338   (:emitter
1339    (cond
1340      ((member :sparc-v9 *backend-subfeatures*)
1341       (destructuring-bind (&optional target pred cc) args
1342         (declare (type (or label null) target))
1343         (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1344      (t
1345       (destructuring-bind (&optional target) args
1346         (declare (type (or label null) target))
1347         (emit-relative-branch segment 1 #b010 cond-or-target target))))))
1348
1349 (define-instruction bpa (segment cond-or-target &optional target pred cc)
1350   (:declare (type (or label branch-condition) cond-or-target)
1351             (type (or label null) target))
1352   (:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
1353             nil
1354             :print-name 'bp)
1355   (:attributes branch)
1356   (:dependencies (reads :psr))
1357   (:delay 0)
1358   (:emitter
1359    (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1360
1361 ;; This doesn't cover all of the possible formats for the trap
1362 ;; instruction.  We really only want a trap with a immediate trap
1363 ;; value and with RS1 = register 0.  Also, the Sparc Compliance
1364 ;; Definition 2.4.1 says only trap numbers 16-31 are allowed for user
1365 ;; code.  All other trap numbers have other uses.  The restriction on
1366 ;; target will prevent us from using bad trap numbers by mistake.
1367
1368 (define-instruction t (segment condition target &optional cc)
1369   (:declare (type branch-condition condition)
1370             ;; KLUDGE: see comments in vm.lisp regarding
1371             ;; pseudo-atomic-trap.
1372             #!-linux
1373             (type (integer 16 31) target))
1374   (:printer format-3-immed ((op #b10)
1375                             (rd nil :type 'branch-condition)
1376                             (op3 #b111010)
1377                             (rs1 0))
1378             '(:name rd :tab immed))
1379   (:attributes branch)
1380   (:dependencies (reads :psr))
1381   (:delay 0)
1382   (:emitter
1383    (cond
1384      ((member :sparc-v9 *backend-subfeatures*)
1385       (unless cc
1386         (setf cc :icc))
1387       (emit-format-4-trap segment
1388                           #b10
1389                           (branch-condition condition)
1390                           #b111010 0 1
1391                           (integer-condition cc)
1392                           target))
1393      (t
1394       (aver (null cc))
1395       (emit-format-3-immed segment #b10 (branch-condition condition)
1396                            #b111010 0 1 target)))))
1397
1398 ;;; KLUDGE: we leave this commented out, as these two (T and TCC)
1399 ;;; operations are actually indistinguishable from their bitfields,
1400 ;;; breaking the disassembler if these are left in. The printer isn't
1401 ;;; terribly smart, but the emitted code is right. - CSR, 2002-08-04
1402 #+nil
1403 (define-instruction tcc (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
1404   (:declare (type branch-condition condition)
1405             ;; KLUDGE: see above.
1406             #!-linux
1407             (type (integer 16 31) target)
1408             (type integer-condition-register cc))
1409   (:printer format-4-trap ((op #b10)
1410                             (rd nil :type 'branch-condition)
1411                             (op3 #b111010)
1412                             (rs1 0))
1413             trap-printer)
1414   (:attributes branch)
1415   (:dependencies (reads :psr))
1416   (:delay 0)
1417   (:emitter (emit-format-4-trap segment
1418                                 #b10
1419                                 (branch-condition condition)
1420                                 #b111010 0 1
1421                                 (integer-condition cc)
1422                                 target)))
1423
1424 ;; Same as for the branch instructions.  On the Sparc V9, we will use
1425 ;; the FP branch with prediction instructions instead.
1426
1427 (define-instruction fb (segment condition target &rest args)
1428   (:declare (type fp-branch-condition condition) (type label target))
1429   (:printer format-2-branch ((op #B00)
1430                              (cond nil :type 'branch-fp-condition)
1431                              (op2 #b110)))
1432   (:attributes branch)
1433   (:dependencies (reads :fsr))
1434   (:delay 1)
1435   (:emitter
1436    (cond
1437      ((member :sparc-v9 *backend-subfeatures*)
1438       (destructuring-bind (&optional fcc pred) args
1439         (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
1440      (t
1441       (aver (null args))
1442       (emit-relative-branch segment 0 #b110 condition target t)))))
1443
1444 (define-instruction fbp (segment condition target &optional fcc pred)
1445   (:declare (type fp-branch-condition condition) (type label target))
1446   (:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
1447             fp-branch-pred-printer
1448             :print-name 'fbp)
1449   (:attributes branch)
1450   (:dependencies (reads :fsr))
1451   (:delay 1)
1452   (:emitter
1453    (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
1454
1455 (defconstant-eqx jal-printer
1456   '(:name :tab
1457           (:choose (rs1 (:unless (:constant 0) (:plus-integer immed)))
1458                    (:cond ((rs2 :constant 0) rs1)
1459                           ((rs1 :constant 0) rs2)
1460                           (t rs1 "+" rs2)))
1461           (:unless (:constant 0) ", " rd))
1462   #'equalp)
1463
1464 (define-instruction jal (segment dst src1 &optional src2)
1465   (:declare (type tn dst)
1466             (type (or tn integer) src1)
1467             (type (or null fixup tn (signed-byte 13)) src2))
1468   (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer)
1469   (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
1470   (:attributes branch)
1471   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
1472   (:delay 1)
1473   (:emitter
1474    (unless src2
1475      (setf src2 src1)
1476      (setf src1 0))
1477    (etypecase src2
1478      (tn
1479       (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
1480                          (if (integerp src1)
1481                              src1
1482                              (reg-tn-encoding src1))
1483                          0 0 (reg-tn-encoding src2)))
1484      (integer
1485       (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
1486                            (reg-tn-encoding src1) 1 src2))
1487      (fixup
1488       (note-fixup segment :add src2)
1489       (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
1490                            #b111000 (reg-tn-encoding src1) 1 0)))))
1491
1492 (define-instruction j (segment src1 &optional src2)
1493   (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
1494   (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
1495   (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
1496   (:attributes branch)
1497   (:dependencies (reads src1) (if src2 (reads src2)))
1498   (:delay 1)
1499   (:emitter
1500    (etypecase src2
1501      (null
1502       (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
1503      (tn
1504       (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
1505                          (reg-tn-encoding src2)))
1506      (integer
1507       (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
1508                            src2))
1509      (fixup
1510       (note-fixup segment :add src2)
1511       (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
1512                            0)))))
1513
1514
1515 \f
1516 ;;;; Unary and binary fp insts.
1517
1518 (macrolet ((define-unary-fp-inst (name opf &key reads extended)
1519   `(define-instruction ,name (segment dst src)
1520      (:declare (type tn dst src))
1521      (:printer format-unary-fpop
1522        ((op #b10) (op3 #b110100) (opf ,opf)
1523         (rs1 0)
1524         (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1525         (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
1526      (:dependencies
1527       ,@(when reads
1528           `((reads ,reads)))
1529       (reads dst)
1530       (reads src)
1531       (writes dst))
1532      (:delay 0)
1533      (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
1534                 #b110100 0 ,opf (fp-reg-tn-encoding src)))))
1535
1536            (define-binary-fp-inst (name opf &key (op3 #b110100)
1537                                       reads writes delay extended)
1538   `(define-instruction ,name (segment dst src1 src2)
1539      (:declare (type tn dst src1 src2))
1540      (:printer format-binary-fpop
1541       ((op #b10) (op3 ,op3) (opf ,opf)
1542        (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1543        (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1544        (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1545        ))
1546      (:dependencies
1547       ,@(when reads
1548           `((reads ,reads)))
1549       (reads src1)
1550       (reads src2)
1551       ,@(when writes
1552           `((writes ,writes)))
1553       (writes dst))
1554      ,@(if delay
1555            `((:delay ,delay))
1556            '((:delay 0)))
1557      (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
1558                 ,op3 (fp-reg-tn-encoding src1) ,opf
1559                 (fp-reg-tn-encoding src2)))))
1560
1561            (define-cmp-fp-inst (name opf &key extended)
1562                (let ((opf0 #b0)
1563                      (opf1 #b010)
1564                      (opf2 #b1))
1565                  `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
1566                    (:declare (type tn src1 src2)
1567                     (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
1568        (:printer format-fpop2
1569                  ((op #b10)
1570                   (op3 #b110101)
1571                   (opf0 ,opf0)
1572                   (opf1 ,opf1)
1573                   (opf2 ,opf2)
1574                   (opf3 ,opf)
1575                   (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1576                   (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1577                   #!-sparc-v9
1578                   (rd 0)
1579                   #!+sparc-v9
1580                   (rd nil :type 'fp-condition-register))
1581         )
1582      (:dependencies
1583       (reads src1)
1584       (reads src2)
1585       (writes :fsr))
1586      ;; The Sparc V9 doesn't need a delay after a FP compare.
1587      ;;
1588      ;; KLUDGE FIXME YAARGH -- how to express that? I guess for now we
1589      ;; do the worst case, and hope to fix it.
1590      ;; (:delay #-sparc-v9 1 #+sparc-v9 0)
1591      (:delay 1)
1592        (:emitter
1593         (emit-format-3-fpop2 segment #b10
1594                              (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
1595                                  0)
1596                              #b110101
1597                              (fp-reg-tn-encoding src1)
1598                              ,opf0 ,opf1 ,opf2 ,opf
1599                              (fp-reg-tn-encoding src2)))))))
1600
1601   (define-unary-fp-inst fitos #b011000100 :reads :fsr)
1602   (define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t)
1603   (define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t)      ; v8
1604
1605   (define-unary-fp-inst fxtos #b010000100 :reads :fsr)                    ; v9
1606   (define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t)        ; v9
1607   (define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t)      ; v9
1608
1609
1610   ;; I (Raymond Toy) don't think these f{sd}toir instructions exist on
1611   ;; any Ultrasparc, but I only have a V9 manual. The code in
1612   ;; float.lisp seems to indicate that they only existed on non-sun4
1613   ;; machines (sun3 68K machines?).
1614   (define-unary-fp-inst fstoir #b011000001 :reads :fsr)
1615   (define-unary-fp-inst fdtoir #b011000010 :reads :fsr)
1616
1617   (define-unary-fp-inst fstoi #b011010001)
1618   (define-unary-fp-inst fdtoi #b011010010 :extended t)
1619   (define-unary-fp-inst fqtoi #b011010011 :extended t)  ; v8
1620
1621   (define-unary-fp-inst fstox #b010000001)                ; v9
1622   (define-unary-fp-inst fdtox #b010000010 :extended t)    ; v9
1623   (define-unary-fp-inst fqtox #b010000011 :extended t)  ; v9
1624
1625   (define-unary-fp-inst fstod #b011001001 :reads :fsr)
1626   (define-unary-fp-inst fstoq #b011001101 :reads :fsr)  ; v8
1627   (define-unary-fp-inst fdtos #b011000110 :reads :fsr)
1628   (define-unary-fp-inst fdtoq #b011001110 :reads :fsr)  ; v8
1629   (define-unary-fp-inst fqtos #b011000111 :reads :fsr)  ; v8
1630   (define-unary-fp-inst fqtod #b011001011 :reads :fsr)  ; v8
1631
1632   (define-unary-fp-inst fmovs #b000000001)
1633   (define-unary-fp-inst fmovd #b000000010 :extended t)  ; v9
1634   (define-unary-fp-inst fmovq #b000000011 :extended t)  ; v9
1635
1636   (define-unary-fp-inst fnegs #b000000101)
1637   (define-unary-fp-inst fnegd #b000000110 :extended t)  ; v9
1638   (define-unary-fp-inst fnegq #b000000111 :extended t)  ; v9
1639
1640   (define-unary-fp-inst fabss #b000001001)
1641   (define-unary-fp-inst fabsd #b000001010 :extended t)  ; v9
1642   (define-unary-fp-inst fabsq #b000001011 :extended t)  ; v9
1643
1644   (define-unary-fp-inst fsqrts #b000101001 :reads :fsr)         ; V7
1645   (define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t)     ; V7
1646   (define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t)     ; v8
1647
1648   (define-binary-fp-inst fadds #b001000001)
1649   (define-binary-fp-inst faddd #b001000010 :extended t)
1650   (define-binary-fp-inst faddq #b001000011 :extended t) ; v8
1651   (define-binary-fp-inst fsubs #b001000101)
1652   (define-binary-fp-inst fsubd #b001000110 :extended t)
1653   (define-binary-fp-inst fsubq #b001000111 :extended t) ; v8
1654
1655   (define-binary-fp-inst fmuls #b001001001)
1656   (define-binary-fp-inst fmuld #b001001010 :extended t)
1657   (define-binary-fp-inst fmulq #b001001011 :extended t) ; v8
1658   (define-binary-fp-inst fdivs #b001001101)
1659   (define-binary-fp-inst fdivd #b001001110 :extended t)
1660   (define-binary-fp-inst fdivq #b001001111 :extended t) ; v8
1661
1662 ;;; Float comparison instructions.
1663 ;;;
1664   (define-cmp-fp-inst fcmps #b0001)
1665   (define-cmp-fp-inst fcmpd #b0010 :extended t)
1666   (define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8
1667   (define-cmp-fp-inst fcmpes #b0101)
1668   (define-cmp-fp-inst fcmped #b0110 :extended t)
1669   (define-cmp-fp-inst fcmpeq #b0111 :extended t)        ; v8
1670
1671 ) ; MACROLET
1672 \f
1673 ;;;; li, jali, ji, nop, cmp, not, neg, move, and more
1674
1675 (defun %li (reg value)
1676   (etypecase value
1677     ((signed-byte 13)
1678      (inst add reg zero-tn value))
1679     ((or (signed-byte 32) (unsigned-byte 32))
1680      (let ((hi (ldb (byte 22 10) value))
1681            (lo (ldb (byte 10 0) value)))
1682        (inst sethi reg hi)
1683        (unless (zerop lo)
1684          (inst add reg lo))))
1685     (fixup
1686      (inst sethi reg value)
1687      (inst add reg value))))
1688
1689 (define-instruction-macro li (reg value)
1690   `(%li ,reg ,value))
1691
1692 ;;; Jal to a full 32-bit address.  Tmpreg is trashed.
1693 (define-instruction jali (segment link tmpreg value)
1694   (:declare (type tn link tmpreg)
1695             (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
1696                       fixup) value))
1697   (:attributes variable-length)
1698   (:vop-var vop)
1699   (:attributes branch)
1700   (:dependencies (writes link) (writes tmpreg))
1701   (:delay 1)
1702   (:emitter
1703    (assemble (segment vop)
1704      (etypecase value
1705        ((signed-byte 13)
1706         (inst jal link zero-tn value))
1707        ((or (signed-byte 32) (unsigned-byte 32))
1708         (let ((hi (ldb (byte 22 10) value))
1709               (lo (ldb (byte 10 0) value)))
1710           (inst sethi tmpreg hi)
1711           (inst jal link tmpreg lo)))
1712        (fixup
1713         (inst sethi tmpreg value)
1714         (inst jal link tmpreg value))))))
1715
1716 ;;; Jump to a full 32-bit address.  Tmpreg is trashed.
1717 (define-instruction ji (segment tmpreg value)
1718   (:declare (type tn tmpreg)
1719             (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
1720                       fixup) value))
1721   (:attributes variable-length)
1722   (:vop-var vop)
1723   (:attributes branch)
1724   (:dependencies (writes tmpreg))
1725   (:delay 1)
1726   (:emitter
1727    (assemble (segment vop)
1728              (inst jali zero-tn tmpreg value))))
1729
1730 (define-instruction nop (segment)
1731   (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name))
1732   (:attributes flushable)
1733   (:delay 0)
1734   (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
1735
1736 (!def-vm-support-routine emit-nop (segment)
1737   (emit-format-2-immed segment 0 0 #b100 0))
1738
1739 (define-instruction cmp (segment src1 &optional src2)
1740   (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
1741   (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0))
1742             '(:name :tab rs1 ", " rs2))
1743   (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0))
1744             '(:name :tab rs1 ", " immed))
1745   (:dependencies (reads src1) (if src2 (reads src2)) (writes :psr))
1746   (:delay 0)
1747   (:emitter
1748    (etypecase src2
1749      (null
1750       (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
1751      (tn
1752       (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
1753                          (reg-tn-encoding src2)))
1754      (integer
1755       (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
1756                            src2)))))
1757
1758 (define-instruction not (segment dst &optional src1)
1759   (:declare (type tn dst) (type (or tn null) src1))
1760   (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0))
1761             '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd))
1762   (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
1763   (:delay 0)
1764   (:emitter
1765    (unless src1
1766      (setf src1 dst))
1767    (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
1768                       (reg-tn-encoding src1) 0 0 0)))
1769
1770 (define-instruction neg (segment dst &optional src1)
1771   (:declare (type tn dst) (type (or tn null) src1))
1772   (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0))
1773             '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd))
1774   (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
1775   (:delay 0)
1776   (:emitter
1777    (unless src1
1778      (setf src1 dst))
1779    (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
1780                       0 0 0 (reg-tn-encoding src1))))
1781
1782 (define-instruction move (segment dst src1)
1783   (:declare (type tn dst src1))
1784   (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0))
1785             '(:name :tab rs2 ", " rd)
1786             :print-name 'mov)
1787   (:attributes flushable)
1788   (:dependencies (reads src1) (writes dst))
1789   (:delay 0)
1790   (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
1791                                0 0 0 (reg-tn-encoding src1))))
1792
1793
1794 \f
1795 ;;;; Instructions for dumping data and header objects.
1796
1797 (define-instruction word (segment word)
1798   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
1799   :pinned
1800   (:delay 0)
1801   (:emitter
1802    (emit-word segment word)))
1803
1804 (define-instruction short (segment short)
1805   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
1806   :pinned
1807   (:delay 0)
1808   (:emitter
1809    (emit-short segment short)))
1810
1811 (define-instruction byte (segment byte)
1812   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
1813   :pinned
1814   (:delay 0)
1815   (:emitter
1816    (emit-byte segment byte)))
1817
1818 (define-bitfield-emitter emit-header-object 32
1819   (byte 24 8) (byte 8 0))
1820
1821 (defun emit-header-data (segment type)
1822   (emit-back-patch
1823    segment 4
1824    (lambda (segment posn)
1825        (emit-word segment
1826                   (logior type
1827                           (ash (+ posn (component-header-length))
1828                                (- n-widetag-bits word-shift)))))))
1829
1830 (define-instruction simple-fun-header-word (segment)
1831   :pinned
1832   (:delay 0)
1833   (:emitter
1834    (emit-header-data segment simple-fun-header-widetag)))
1835
1836 (define-instruction lra-header-word (segment)
1837   :pinned
1838   (:delay 0)
1839   (:emitter
1840    (emit-header-data segment return-pc-header-widetag)))
1841
1842 \f
1843 ;;;; Instructions for converting between code objects, functions, and lras.
1844
1845 (defun emit-compute-inst (segment vop dst src label temp calc)
1846   (emit-chooser
1847    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
1848    segment 12 3
1849    (lambda (segment posn delta-if-after)
1850        (let ((delta (funcall calc label posn delta-if-after)))
1851          (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
1852            (emit-back-patch segment 4
1853                             (lambda (segment posn)
1854                                 (assemble (segment vop)
1855                                           (inst add dst src
1856                                                 (funcall calc label posn 0)))))
1857            t)))
1858    (lambda (segment posn)
1859        (let ((delta (funcall calc label posn 0)))
1860          (assemble (segment vop)
1861                    (inst sethi temp (ldb (byte 22 10) delta))
1862                    (inst or temp (ldb (byte 10 0) delta))
1863                    (inst add dst src temp))))))
1864
1865 ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
1866 (define-instruction compute-code-from-fn (segment dst src label temp)
1867   (:declare (type tn dst src temp) (type label label))
1868   (:attributes variable-length)
1869   (:dependencies (reads src) (writes dst) (writes temp))
1870   (:delay 0)
1871   (:vop-var vop)
1872   (:emitter
1873    (emit-compute-inst segment vop dst src label temp
1874                       (lambda (label posn delta-if-after)
1875                           (- other-pointer-lowtag
1876                              fun-pointer-lowtag
1877                              (label-position label posn delta-if-after)
1878                              (component-header-length))))))
1879
1880 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1881 ;;      = lra - (header + label-offset)
1882 (define-instruction compute-code-from-lra (segment dst src label temp)
1883   (:declare (type tn dst src temp) (type label label))
1884   (:attributes variable-length)
1885   (:dependencies (reads src) (writes dst) (writes temp))
1886   (:delay 0)
1887   (:vop-var vop)
1888   (:emitter
1889    (emit-compute-inst segment vop dst src label temp
1890                       (lambda (label posn delta-if-after)
1891                           (- (+ (label-position label posn delta-if-after)
1892                                 (component-header-length)))))))
1893
1894 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1895 ;;     = code + header + label-offset
1896 (define-instruction compute-lra-from-code (segment dst src label temp)
1897   (:declare (type tn dst src temp) (type label label))
1898   (:attributes variable-length)
1899   (:dependencies (reads src) (writes dst) (writes temp))
1900   (:delay 0)
1901   (:vop-var vop)
1902   (:emitter
1903    (emit-compute-inst segment vop dst src label temp
1904                       (lambda (label posn delta-if-after)
1905                           (+ (label-position label posn delta-if-after)
1906                              (component-header-length))))))
1907 \f
1908 ;;; Sparc V9 additions
1909
1910
1911
1912 ;; Conditional move integer on condition code
1913 (define-instruction cmove (segment condition dst src &optional (ccreg :icc))
1914   (:declare (type (or branch-condition fp-branch-condition) condition)
1915             (type cond-move-condition-register ccreg)
1916             (type tn dst)
1917             (type (or (signed-byte 13) tn) src))
1918   (:printer format-4-cond-move
1919             ((op #b10)
1920              (op3 #b101100)
1921              (cc2 #b1)
1922              (i 0)
1923              (cc nil :type 'integer-condition-register))
1924              cond-move-printer
1925              :print-name 'mov)
1926   (:printer format-4-cond-move-immed
1927             ((op #b10)
1928              (op3 #b101100)
1929              (cc2 #b1)
1930              (i 1)
1931              (cc nil :type 'integer-condition-register))
1932              cond-move-printer
1933              :print-name 'mov)
1934   (:printer format-4-cond-move
1935             ((op #b10)
1936              (op3 #b101100)
1937              (cc2 #b0)
1938              (cond nil :type 'branch-fp-condition)
1939              (i 0)
1940              (cc nil :type 'fp-condition-register))
1941              cond-move-printer
1942              :print-name 'mov)
1943   (:printer format-4-cond-move-immed
1944             ((op #b10)
1945              (op3 #b101100)
1946              (cc2 #b0)
1947              (cond nil :type 'branch-fp-condition)
1948              (i 1)
1949              (cc nil :type 'fp-condition-register))
1950              cond-move-printer
1951              :print-name 'mov)
1952   (:delay 0)
1953   (:dependencies
1954    (if (member ccreg '(:icc :xcc))
1955        (reads :psr)
1956        (reads :fsr))
1957    (reads src)
1958    (reads dst)
1959    (writes dst))
1960   (:emitter
1961    (let ((op #b10)
1962          (op3 #b101100))
1963      (multiple-value-bind (cc2 cc01)
1964          (cond-move-condition-parts ccreg)
1965        (etypecase src
1966          (tn
1967           (emit-format-4-cond-move segment
1968                                    op
1969                                    (reg-tn-encoding dst)
1970                                    op3
1971                                    cc2
1972                                    (if (member ccreg '(:icc :xcc))
1973                                        (branch-condition condition)
1974                                        (fp-branch-condition condition))
1975                                    0
1976                                    cc01
1977                                    (reg-tn-encoding src)))
1978          (integer
1979           (emit-format-4-cond-move segment
1980                                    op
1981                                    (reg-tn-encoding dst)
1982                                    op3
1983                                    cc2
1984                                    (if (member ccreg '(:icc :xcc))
1985                                        (branch-condition condition)
1986                                        (fp-branch-condition condition))
1987                                    1
1988                                    cc01
1989                                    src)))))))
1990
1991 ;; Conditional move floating-point on condition codes
1992 (macrolet ((define-cond-fp-move (name print-name op op3 opf_low &key extended)
1993   `(define-instruction ,name (segment condition dst src &optional (ccreg :fcc0))
1994      (:declare (type (or branch-condition fp-branch-condition) condition)
1995                (type cond-move-condition-register ccreg)
1996                (type tn dst src))
1997      (:printer format-fpop2
1998                ((op ,op)
1999                 (op3 ,op3)
2000                 (opf0 0)
2001                 (opf1 nil :type 'fp-condition-register-shifted)
2002                 (opf2 0)
2003                 (opf3 ,opf_low)
2004                 (rs1 nil :type 'branch-fp-condition)
2005                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2006                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
2007                 cond-fp-move-printer
2008                 :print-name ',print-name)
2009      (:printer format-fpop2
2010                ((op ,op)
2011                 (op3 ,op3)
2012                 (opf0 1)
2013                 (opf1 nil :type 'integer-condition-register)
2014                 (opf2 0)
2015                 (rs1 nil :type 'branch-condition)
2016                 (opf3 ,opf_low)
2017                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2018                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
2019                cond-fp-move-printer
2020                :print-name ',print-name)
2021      (:delay 0)
2022      (:dependencies
2023       (if (member ccreg '(:icc :xcc))
2024           (reads :psr)
2025           (reads :fsr))
2026       (reads src)
2027       (reads dst)
2028       (writes dst))
2029      (:emitter
2030       (multiple-value-bind (opf_cc2 opf_cc01)
2031           (cond-move-condition-parts ccreg)
2032         (emit-format-3-fpop2 segment
2033                              ,op
2034                              (fp-reg-tn-encoding dst)
2035                              ,op3
2036                              (if (member ccreg '(:icc :xcc))
2037                                  (branch-condition condition)
2038                                  (fp-branch-condition condition))
2039                              opf_cc2
2040                              (ash opf_cc01 1)
2041                              0
2042                              ,opf_low
2043                              (fp-reg-tn-encoding src)))))))
2044   (define-cond-fp-move cfmovs fmovs #b10 #b110101 #b0001)
2045   (define-cond-fp-move cfmovd fmovd #b10 #b110101 #b0010 :extended t)
2046   (define-cond-fp-move cfmovq fmovq #b10 #b110101 #b0011 :extended t))
2047
2048
2049 ;; Move on integer register condition
2050 ;;
2051 ;; movr dst src reg reg-cond
2052 ;;
2053 ;; This means if reg satisfies reg-cond, src is copied to dst.  If the
2054 ;; condition is not satisfied, nothing is done.
2055 ;;
2056 (define-instruction movr (segment dst src2 src1 reg-condition)
2057   (:declare (type cond-move-integer-condition reg-condition)
2058             (type tn dst src1)
2059             (type (or (signed-byte 10) tn) src2))
2060   (:printer format-4-cond-move-integer
2061             ((op #b10)
2062              (op3 #b101111)
2063              (i 0)))
2064   (:printer format-4-cond-move-integer-immed
2065             ((op #b10)
2066              (op3 #b101111)
2067              (i 1)))
2068   (:delay 0)
2069   (:dependencies
2070    (reads :psr)
2071    (reads src2)
2072    (reads src1)
2073    (reads dst)
2074    (writes dst))
2075   (:emitter
2076    (etypecase src2
2077      (tn
2078       (emit-format-4-cond-move-integer
2079        segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
2080        0 (register-condition reg-condition)
2081        0 (reg-tn-encoding src2)))
2082      (integer
2083       (emit-format-4-cond-move-integer-immed
2084        segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
2085        1 (register-condition reg-condition) src2)))))
2086
2087
2088 ;; Same as MOVR, except we move FP registers depending on the value of
2089 ;; an integer register.
2090 ;;
2091 ;; fmovr dst src reg cond
2092 ;;
2093 ;; This means if REG satifies COND, SRC is COPIED to DST.  Nothing
2094 ;; happens if the condition is not satisfied.
2095 (macrolet ((define-cond-fp-move-integer (name opf_low &key extended)
2096   `(define-instruction ,name (segment dst src2 src1 reg-condition)
2097      (:declare (type cond-move-integer-condition reg-condition)
2098                (type tn dst src1 src2))
2099      (:printer format-fpop2
2100                ((op #b10)
2101                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2102                 (op3 #b110101)
2103                 (rs1 nil :type 'reg)
2104                 (opf0 0)
2105                 (opf1 nil :type 'register-condition)
2106                 (opf2 0)
2107                 (opf3 ,opf_low)
2108                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2109                 )
2110                cond-fp-move-integer-printer)
2111      (:delay 0)
2112      (:dependencies
2113       (reads src2)
2114       (reads src1)
2115       (reads dst)
2116       (writes dst))
2117      (:emitter
2118       (emit-format-3-fpop2
2119        segment
2120        #b10
2121        (fp-reg-tn-encoding dst)
2122        #b110101
2123        (reg-tn-encoding src1)
2124        0
2125        (register-condition reg-condition)
2126        0
2127        ,opf_low
2128        (fp-reg-tn-encoding src2))))))
2129   (define-cond-fp-move-integer fmovrs #b0101)
2130   (define-cond-fp-move-integer fmovrd #b0110 :extended t)
2131   (define-cond-fp-move-integer fmovrq #b0111 :extended t))