1;;;; the instruction set definition for the PPC
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!PPC-ASM")
13
14(eval-when (:compile-toplevel :load-toplevel :execute)
15  ;; Imports from this package into SB-VM
16  (import '(reg-tn-encoding) 'sb!vm)
17  ;; Imports from SB-VM into this package
18  (import '(;; SBs and SCs
19            sb!vm::zero sb!vm::immediate-constant
20            sb!vm::registers sb!vm::float-registers
21            ;; TNs and offsets
22            sb!vm::zero-tn sb!vm::lip-tn
23            sb!vm::zero-offset sb!vm::null-offset)))
24
25;;; needs a little more work in the assembler, to realise that the
26;;; delays requested here are not mandatory, so that the assembler
27;;; shouldn't fill gaps with NOPs but with real instructions.  -- CSR,
28;;; 2003-09-08
29#+nil
30(eval-when (:compile-toplevel :load-toplevel :execute)
31  (setf sb!assem:*assem-scheduler-p* t)
32  (setf sb!assem:*assem-max-locations* 70))
33
34;;;; Constants, types, conversion functions, some disassembler stuff.
35
36(defun reg-tn-encoding (tn)
37  (declare (type tn tn))
38  (sc-case tn
39    (zero zero-offset)
40    (null null-offset)
41    (t
42     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
43         (tn-offset tn)
44         (error "~S isn't a register." tn)))))
45
46(defun fp-reg-tn-encoding (tn)
47  (declare (type tn tn))
48  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
49    (error "~S isn't a floating-point register." tn))
50  (tn-offset tn))
51
52(defvar *disassem-use-lisp-reg-names* t)
53
54(defun location-number (loc)
55  (etypecase loc
56    (null)
57    (number)
58    (label)
59    (fixup)
60    (tn
61     (ecase (sb-name (sc-sb (tn-sc loc)))
62       (immediate-constant
63        ;; Can happen if $ZERO or $NULL are passed in.
64        nil)
65       (registers
66        (unless (zerop (tn-offset loc))
67          (tn-offset loc)))
68       (float-registers
69        (+ (tn-offset loc) 32))))
70    (symbol
71     (ecase loc
72       (:memory 0)
73       (:ccr 64)
74       (:xer 65)
75       (:lr 66)
76       (:ctr 67)
77       (:fpscr 68)))))
78
79(defparameter reg-symbols
80  (map 'vector
81       #'(lambda (name)
82           (cond ((null name) nil)
83                 (t (make-symbol (concatenate 'string "$" name)))))
84       sb!vm::*register-names*))
85
86(define-arg-type reg
87  :printer
88  (lambda (value stream dstate)
89    (declare (type stream stream) (fixnum value))
90    (let ((regname (aref reg-symbols value)))
91      (princ regname stream)
92      (maybe-note-associated-storage-ref value 'registers regname dstate)
93      (maybe-add-notes value dstate))))
94
95(defparameter float-reg-symbols
96  #.(coerce
97     (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
98     'vector))
99
100(define-arg-type fp-reg
101  :printer #'(lambda (value stream dstate)
102               (declare (type stream stream) (fixnum value))
103               (let ((regname (aref float-reg-symbols value)))
104                 (princ regname stream)
105                 (maybe-note-associated-storage-ref
106                  value
107                  'float-registers
108                  regname
109                  dstate))))
110
111(defconstant-eqx bo-kind-names
112    #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil
113      :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil
114      :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil
115      nil nil nil nil nil nil nil nil)
116    #'equalp)
117
118(define-arg-type bo-field
119  :printer #'(lambda (value stream dstate)
120               (declare (ignore dstate)
121                        (type stream stream)
122                        (type fixnum value))
123               (princ (svref bo-kind-names value) stream)))
124
125(define-compiler-macro valid-bo-encoding (&whole form enc)
126  (declare (notinline valid-bo-encoding))
127  (if (keywordp enc) (valid-bo-encoding enc) form))
128(eval-when (:compile-toplevel :load-toplevel :execute)
129(defun valid-bo-encoding (enc)
130  (or (if (integerp enc)
131        (and (= enc (logand #x1f enc))
132             (not (null (svref bo-kind-names enc)))
133             enc)
134        (and enc (position enc bo-kind-names)))
135      (error "Invalid BO field spec: ~s" enc)))
136)
137
138(defconstant-eqx cr-bit-names #(:lt :gt :eq :so) #'equalp)
139(defconstant-eqx cr-bit-inverse-names #(:ge :le :ne :ns) #'equalp)
140
141(defconstant-eqx cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)
142  #'equalp)
143
144(defun valid-cr-bit-encoding (enc &optional error-p)
145  (or (if (integerp enc)
146        (and (= enc (logand 3 enc))
147             enc))
148      (position enc cr-bit-names)
149      (if error-p (error "Invalid condition bit specifier : ~s" enc))))
150
151(defun valid-cr-field-encoding (enc)
152  (let* ((field (if (integerp enc)
153                  (and (= enc (logand #x7 enc)))
154                  (position enc cr-field-names))))
155    (if field
156      (ash field 2)
157      (error "Invalid condition register field specifier : ~s" enc))))
158
159(defun valid-bi-encoding (enc)
160  (or
161   (if (atom enc)
162     (if (integerp enc)
163       (and (= enc (logand 31 enc)) enc)
164       (position enc cr-bit-names))
165     (+ (valid-cr-field-encoding (car enc))
166        (valid-cr-bit-encoding (cadr enc))))
167   (error "Invalid BI field spec : ~s" enc)))
168
169(define-arg-type bi-field
170  :printer #'(lambda (value stream dstate)
171               (declare (ignore dstate)
172                        (type stream stream)
173                        (type (unsigned-byte 5) value))
174               (let* ((bitname (svref cr-bit-names (logand 3 value)))
175                      (crfield (ash value -2)))
176                 (declare (type (unsigned-byte 3) crfield))
177                 (if (= crfield 0)
178                   (princ bitname stream)
179                   (princ (list (svref cr-field-names crfield) bitname) stream)))))
180
181(define-arg-type crf
182  :printer #'(lambda (value stream dstate)
183               (declare (ignore dstate)
184                        (type stream stream)
185                        (type (unsigned-byte 3) value))
186               (princ (svref cr-field-names value) stream)))
187
188(define-arg-type relative-label
189  :sign-extend t
190  :use-label #'(lambda (value dstate)
191                 (declare (type (signed-byte 24) value))
192                 (+ (ash value 2) (dstate-cur-addr dstate))))
193
194(defconstant-eqx trap-values-alist
195  '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
196    (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
197    (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))
198  #'equal)
199
200
201(defun valid-tcond-encoding (enc)
202  (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
203      (cdr (assoc enc trap-values-alist))
204      (error "Unknown trap condition: ~s" enc)))
205
206(define-arg-type to-field
207  :sign-extend nil
208  :printer #'(lambda (value stream dstate)
209               (declare (ignore dstate)
210                        (type stream stream)
211                        (type fixnum value))
212               (princ (or (car (rassoc value trap-values-alist))
213                          value)
214                      stream)))
215
216(defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p)
217  (declare (type boolean aa-p lk-p))
218  (let* ((bo (valid-bo-encoding bo))
219         (bi (valid-bi-encoding bi))
220         (aa-bit (if aa-p 1 0))
221         (lk-bit (if lk-p 1 0)))
222    (if aa-p                            ; Not bloody likely, bwth.
223      (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit)
224      ;; the target may be >32k away, in which case we have to invert the
225      ;; test and do an absolute branch
226      (emit-chooser
227       ;; We emit either 4 or 8 bytes, so I think we declare this as
228       ;; preserving 4 byte alignment.  If this gives us no joy, we can
229       ;; stick a nop in the long branch and then we will be
230       ;; preserving 8 byte alignment
231       segment 8 2 ; 2^2 is 4 byte alignment.  I think
232       #'(lambda (segment posn magic-value)
233           (let ((delta (ash (- (label-position target posn magic-value) posn)
234                             -2)))
235             (when (typep delta '(signed-byte 14))
236               (emit-back-patch segment 4
237                                #'(lambda (segment posn)
238                                    (emit-b-form-inst
239                                     segment 16 bo bi
240                                     (ash (- (label-position target) posn) -2)
241                                     aa-bit lk-bit)))
242               t)))
243       #'(lambda (segment posn)
244           (declare (ignore posn))
245           (let ((bo (logxor 8 bo))) ;; invert the test
246             (emit-b-form-inst segment 16 bo bi
247                               2 ; skip over next instruction
248                               0 0)
249             (emit-back-patch segment 4
250                              #'(lambda (segment posn)
251                                  (declare (ignore posn))
252                                  (emit-i-form-branch segment target lk-p)))))
253       ))))
254
255
256
257; non-absolute I-form: B, BL.
258(defun emit-i-form-branch (segment target &optional lk-p)
259  (let* ((lk-bit (if lk-p 1 0)))
260    (etypecase target
261      (fixup
262       (note-fixup segment :b target)
263       (emit-i-form-inst segment 18 0 0 lk-bit))
264      (label
265       (emit-back-patch segment 4
266                        #'(lambda (segment posn)
267                            (emit-i-form-inst
268                             segment
269                             18
270                             (ash (- (label-position target) posn) -2)
271                             0
272                             lk-bit)))))))
273
274(defconstant-eqx +spr-numbers-alist+ '((:xer 1) (:lr 8) (:ctr 9)) #'equal)
275
276(define-arg-type spr
277  :printer #'(lambda (value stream dstate)
278               (declare (ignore dstate)
279                        (type (unsigned-byte 10) value))
280               (let* ((name (car (rassoc value +spr-numbers-alist+))))
281                   (if name
282                     (princ name stream)
283                     (princ value stream)))))
284
285#-sb-xc-host ; no definition of MAYBE-NOTE-ASSEMBLER-ROUTINE
286(defparameter jump-printer
287    #'(lambda (value stream dstate)
288        (let ((addr (ash value 2)))
289          (maybe-note-assembler-routine addr t dstate)
290          (write addr :base 16 :radix t :stream stream))))
291
292
293
294;;;; dissassem:define-instruction-formats
295
296(defmacro ppc-byte (startbit &optional (endbit startbit))
297  (unless (and (typep startbit '(unsigned-byte 32))
298               (typep endbit '(unsigned-byte 32))
299               (>= endbit startbit))
300    (error "Bad bits."))
301  ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit)))
302
303(defconstant-eqx +ppc-field-specs-alist+
304    `((aa :field ,(ppc-byte 30))
305      (ba :field ,(ppc-byte 11 15) :type 'bi-field)
306      (bb :field ,(ppc-byte 16 20) :type 'bi-field)
307      (bd :field ,(ppc-byte 16 29) :type 'relative-label)
308      (bf :field ,(ppc-byte 6 8) :type 'crf)
309      (bfa :field ,(ppc-byte 11 13) :type 'crf)
310      (bi :field ,(ppc-byte 11 15) :type 'bi-field)
311      (bo :field ,(ppc-byte 6 10) :type 'bo-field)
312      (bt :field ,(ppc-byte 6 10) :type 'bi-field)
313      (d :field ,(ppc-byte 16 31) :sign-extend t)
314      (flm :field ,(ppc-byte 7 14) :sign-extend nil)
315      (fra :field ,(ppc-byte 11 15) :type 'fp-reg)
316      (frb :field ,(ppc-byte 16 20) :type 'fp-reg)
317      (frc :field ,(ppc-byte 21 25) :type 'fp-reg)
318      (frs :field ,(ppc-byte 6 10) :type 'fp-reg)
319      (frt :field ,(ppc-byte 6 10) :type 'fp-reg)
320      (fxm :field ,(ppc-byte 12 19) :sign-extend nil)
321      (l :field ,(ppc-byte 10) :sign-extend nil)
322      (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label)
323      (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer)
324      (lk :field ,(ppc-byte 31))
325      (mb :field ,(ppc-byte 21 25) :sign-extend nil)
326      (me :field ,(ppc-byte 26 30) :sign-extend nil)
327      (nb :field ,(ppc-byte 16 20) :sign-extend nil)
328      (oe :field ,(ppc-byte 21))
329      (ra :field ,(ppc-byte 11 15) :type 'reg)
330      (rb :field ,(ppc-byte 16 20) :type 'reg)
331      (rc :field ,(ppc-byte 31))
332      (rs :field ,(ppc-byte 6 10) :type 'reg)
333      (rt :field ,(ppc-byte 6 10) :type 'reg)
334      (sh :field ,(ppc-byte 16 20) :sign-extend nil)
335      (si :field ,(ppc-byte 16 31) :sign-extend t)
336      (spr :field ,(ppc-byte 11 20) :type 'spr)
337      (to :field ,(ppc-byte 6 10) :type 'to-field)
338      (u :field ,(ppc-byte 16 19) :sign-extend nil)
339      (ui :field ,(ppc-byte 16 31) :sign-extend nil)
340      (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil)
341      (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil)
342      (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil))
343    #'equal)
344
345
346(define-instruction-format (instr 32)
347  (op :field (byte 6 26))
348  (other :field (byte 26 0)))
349
350(define-instruction-format (sc 32 :default-printer '(:name :tab rest))
351  (op :field (byte 6 26))
352  (rest :field (byte 26 0) :value 2))
353
354
355
356(macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs)
357               (flet ((specname-field (specname)
358                        (or (assoc specname +ppc-field-specs-alist+)
359                            (error "Unknown ppc instruction field spec ~s" specname))))
360                 (labels ((spec-field (spec)
361                            (if (atom spec)
362                                (specname-field spec)
363                                (cons (car spec)
364                                      (cdr (specname-field (cadr spec)))))))
365                   (collect ((field (list '(op :field (byte 6 26)))))
366                            (dolist (spec specs)
367                              (field (spec-field spec)))
368                            `(define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
369                              ,@(field)))))))
370
371(def-ppc-iformat (i '(:name :tab li))
372  li aa lk)
373
374(def-ppc-iformat (i-abs '(:name :tab li-abs))
375  li-abs aa lk)
376
377(def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
378  bo bi bd aa lk)
379
380(def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
381  rt ra d)
382
383(def-ppc-iformat (d-si '(:name :tab rt "," ra "," si ))
384  rt ra si)
385
386(def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")"))
387  rs ra d)
388
389(def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui))
390  rs ra ui)
391
392(def-ppc-iformat (d-crf-si)
393  bf l ra si)
394
395(def-ppc-iformat (d-crf-ui)
396  bf l ra ui)
397
398(def-ppc-iformat (d-to '(:name :tab to "," ra "," si))
399  to ra rb si)
400
401(def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")"))
402  frt ra d)
403
404(def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
405  frs ra d)
406
407
408
409;;; There are around ... oh, 28 or so ... variants on the "X" format.
410;;;  Some of them are only used by one instruction; some are used by dozens.
411;;;  Some aren't used by instructions that we generate ...
412
413(def-ppc-iformat (x '(:name :tab rt "," ra "," rb))
414  rt ra rb (xo xo21-30))
415
416(def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb))
417  rt ra nb (xo xo21-30))
418
419(def-ppc-iformat (x-4 '(:name :tab rt))
420  rt (xo xo21-30))
421
422(def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb))
423  rs ra rb (xo xo21-30) rc)
424
425(def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb))
426  rs ra rb (xo xo21-30))
427
428(def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb))
429  rs ra nb (xo xo21-30))
430
431(def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh))
432  rs ra sh (xo xo21-30) rc)
433
434(def-ppc-iformat (x-10 '(:name :tab ra "," rs))
435  rs ra (xo xo21-30) rc)
436
437(def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb))
438  bf l ra rb (xo xo21-30))
439
440(def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb))
441  bf l fra frb (xo xo21-30))
442
443(def-ppc-iformat (x-18 '(:name :tab bf))
444  bf (xo xo21-30))
445
446(def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb))
447  to ra rb (xo xo21-30))
448
449(def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb))
450  frt ra rb (xo xo21-30))
451
452(def-ppc-iformat (x-21 '(:name :tab frt "," rb))
453  frt rb (xo xo21-30) rc)
454
455(def-ppc-iformat (x-22 '(:name :tab frt))
456  frt (xo xo21-30) rc)
457
458(def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb))
459  frs ra rb (xo xo21-30))
460
461(def-ppc-iformat (x-24 '(:name :tab bt))
462  bt (xo xo21-30) rc)
463
464(def-ppc-iformat (x-25 '(:name :tab ra "," rb))
465  ra rb (xo xo21-30))
466
467(def-ppc-iformat (x-26 '(:name :tab rb))
468  rb (xo xo21-30))
469
470(def-ppc-iformat (x-27 '(:name))
471  (xo xo21-30))
472
473
474;;;;
475
476(def-ppc-iformat (xl '(:name :tab bt "," ba "," bb))
477  bt ba bb (xo xo21-30))
478
479(def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi))
480  bo bi (xo xo21-30) lk)
481
482(def-ppc-iformat (xl-cr '(:name :tab bf "," bfa))
483  bf bfa (xo xo21-30))
484
485(def-ppc-iformat (xl-xo '(:name))
486  (xo xo21-30))
487
488
489;;;;
490
491(def-ppc-iformat (xfx)
492  rt spr (xo xo21-30))
493
494(def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs))
495  rs fxm (xo xo21-30))
496
497(def-ppc-iformat (xfl '(:name :tab flm "," frb))
498  flm frb (xo xo21-30) rc)
499
500
501;;;
502
503(def-ppc-iformat (xo '(:name :tab rt "," ra "," rb))
504  rt ra rb oe (xo xo22-30) rc)
505
506(def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb))
507  rt ra rb (xo xo22-30) rc)
508
509(def-ppc-iformat (xo-a '(:name :tab rt "," ra))
510  rt ra oe (xo xo22-30) rc)
511
512
513;;;
514
515(def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc))
516  frt fra frb frc (xo xo26-30) rc)
517
518(def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb))
519  frt fra frb (xo xo26-30) rc)
520
521(def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc))
522  frt fra frc (xo xo26-30) rc)
523
524(def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc))
525  frt frb frc (xo xo26-30) rc)
526
527
528(def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me))
529  rs ra rb mb me rc)
530
531(def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me))
532  rs ra sh mb me rc)
533) ; end MACROLET DEF-PPC-IFORMAT
534
535(define-instruction-format (xinstr 32 :default-printer '(:name :tab data))
536  (op-to-a :field (byte 16 16))
537  (data :field (byte 16 0) :reader xinstr-data))
538
539
540
541;;;; Primitive emitters.
542
543
544(define-bitfield-emitter emit-word 32
545  (byte 32 0))
546
547(define-bitfield-emitter emit-short 16
548  (byte 16 0))
549
550(define-bitfield-emitter emit-i-form-inst 32
551  (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0))
552
553(define-bitfield-emitter emit-b-form-inst 32
554  (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0))
555
556(define-bitfield-emitter emit-sc-form-inst 32
557  (byte 6 26) (byte 26 0))
558
559(define-bitfield-emitter emit-d-form-inst 32
560  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
561
562; Also used for XL-form.  What's the difference ?
563(define-bitfield-emitter emit-x-form-inst 32
564  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0))
565
566(define-bitfield-emitter emit-xfx-form-inst 32
567  (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0))
568
569(define-bitfield-emitter emit-xfl-form-inst 32
570  (byte 6 26) (byte 10  16) (byte 5 11) (byte 10 1) (byte 1 0))
571
572; XS is 64-bit only
573(define-bitfield-emitter emit-xo-form-inst 32
574  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0))
575
576(define-bitfield-emitter emit-a-form-inst 32
577  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0))
578
579
580
581
582(eval-when (:compile-toplevel :execute)
583(defun classify-dependencies (deplist)
584  (collect ((reads) (writes))
585    (dolist (dep deplist)
586      (ecase (car dep)
587        (reads (reads dep))
588        (writes (writes dep))))
589    (values (reads) (writes)))))
590
591(macrolet ((define-xo-instruction
592               (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
593               `(define-instruction ,name (segment rt ra rb)
594                 (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
595                 (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
596                  (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
597                 (:cost ,cost)
598                 (:delay ,cost)
599                 (:emitter
600                  (emit-xo-form-inst segment ,op
601                   (reg-tn-encoding rt)
602                   (reg-tn-encoding ra)
603                   (reg-tn-encoding rb)
604                   ,(if oe-p 1 0)
605                   ,xo
606                   ,(if rc-p 1 0)))))
607           (define-xo-oe-instruction
608               (name op xo rc-p always-reads-xer always-writes-xer cost)
609               `(define-instruction ,name (segment rt ra rb)
610                 (:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
611                 (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
612                  (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))))
613                 (:cost ,cost)
614                 (:delay ,cost)
615                 (:emitter
616                  (emit-xo-form-inst segment ,op
617                   (reg-tn-encoding rt)
618                   (reg-tn-encoding ra)
619                   (reg-tn-encoding rb)
620                   0
621                   ,xo
622                   (if ,rc-p 1 0)))))
623           (define-4-xo-instructions
624               (base op xo &key always-reads-xer always-writes-xer (cost 1))
625               `(progn
626                 (define-xo-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
627                 (define-xo-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
628                 (define-xo-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
629                 (define-xo-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
630
631           (define-2-xo-oe-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
632               `(progn
633                 (define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost)
634                 (define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost)))
635
636           (define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
637               `(define-instruction ,name (segment rt ra)
638                 (:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0))))
639                 (:dependencies (reads ra) ,@(if always-reads-xer '((reads :xer)))
640                  (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))) )
641                 (:cost ,cost)
642                 (:delay ,cost)
643                 (:emitter
644                  (emit-xo-form-inst segment ,op
645                   (reg-tn-encoding rt)
646                   (reg-tn-encoding ra)
647                   0
648                   (if ,oe-p 1 0)
649                   ,xo
650                   (if ,rc-p 1 0)))))
651
652           (define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
653               `(progn
654                 (define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
655                 (define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
656                 (define-xo-a-instruction ,(symbolicate base "O")  ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
657                 (define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
658
659           (define-x-instruction (name op xo &key (cost 2) other-dependencies)
660               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
661                 `(define-instruction ,name (segment rt ra rb)
662                   (:printer x ((op ,op) (xo ,xo)))
663                   (:delay ,cost)
664                   (:cost ,cost)
665                   (:dependencies (reads ra) (reads rb) (reads :memory) ,@other-reads
666                    (writes rt) ,@other-writes)
667                   (:emitter
668                    (emit-x-form-inst segment ,op
669                     (reg-tn-encoding rt)
670                     (reg-tn-encoding ra)
671                     (reg-tn-encoding rb)
672                     ,xo
673                     0)))))
674
675           (define-x-20-instruction (name op xo &key (cost 2) other-dependencies)
676               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
677                 `(define-instruction ,name (segment frt ra rb)
678                   (:printer x-20 ((op ,op) (xo ,xo)))
679                   (:delay ,cost)
680                   (:cost ,cost)
681                   (:dependencies (reads ra) (reads rb) ,@other-reads
682                    (writes frt) ,@other-writes)
683                   (:emitter
684                    (emit-x-form-inst segment ,op
685                     (fp-reg-tn-encoding frt)
686                     (reg-tn-encoding ra)
687                     (reg-tn-encoding rb)
688                     ,xo
689                     0)))))
690
691           (define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies)
692               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
693                 `(define-instruction ,name (segment ra rs rb)
694                   (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
695                   (:delay ,cost)
696                   (:cost ,cost)
697                   (:dependencies (reads rb) (reads rs) ,@other-reads
698                    (writes ra) ,@other-writes)
699                   (:emitter
700                    (emit-x-form-inst segment ,op
701                     (reg-tn-encoding rs)
702                     (reg-tn-encoding ra)
703                     (reg-tn-encoding rb)
704                     ,xo
705                     ,(if rc-p 1 0))))))
706
707
708           (define-x-5-st-instruction (name op xo rc-p &key (cost 1) other-dependencies)
709               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
710                 `(define-instruction ,name (segment rs ra rb)
711                   (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
712                   (:delay ,cost)
713                   (:cost ,cost)
714                   (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads
715                    (writes :memory :partially t) ,@other-writes)
716                   (:emitter
717                    (emit-x-form-inst segment ,op
718                     (reg-tn-encoding rs)
719                     (reg-tn-encoding ra)
720                     (reg-tn-encoding rb)
721                     ,xo
722                     ,(if rc-p 1 0))))))
723
724           (define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies)
725               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
726                 `(define-instruction ,name (segment frs ra rb)
727                   (:printer x-23 ((op ,op) (xo ,xo)))
728                   (:delay ,cost)
729                   (:cost ,cost)
730                   (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads
731                    (writes :memory :partially t) ,@other-writes)
732                   (:emitter
733                    (emit-x-form-inst segment ,op
734                     (fp-reg-tn-encoding frs)
735                     (reg-tn-encoding ra)
736                     (reg-tn-encoding rb)
737                     ,xo
738                     0)))))
739
740           (define-x-10-instruction (name op xo rc-p &key (cost 1) other-dependencies)
741               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
742                 `(define-instruction ,name (segment ra rs)
743                   (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
744                   (:delay ,cost)
745                   (:cost ,cost)
746                   (:dependencies (reads rs) ,@other-reads
747                    (writes ra) ,@other-writes)
748                   (:emitter
749                    (emit-x-form-inst segment ,op
750                     (reg-tn-encoding rs)
751                     (reg-tn-encoding ra)
752                     0
753                     ,xo
754                     ,(if rc-p 1 0))))))
755
756           (define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies)
757               `(progn
758                 (define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
759                 (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
760                                         :other-dependencies ,other-dependencies)))
761
762           (define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies)
763               `(progn
764                 (define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
765                 (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
766                                          :other-dependencies ,other-dependencies)))
767
768
769           (define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies)
770               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
771                 `(define-instruction ,name (segment frt frb)
772                   (:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
773                   (:cost ,cost)
774                   (:delay ,cost)
775                   (:dependencies (reads frb) ,@other-reads
776                    (writes frt) ,@other-writes)
777                   (:emitter
778                    (emit-x-form-inst segment ,op
779                     (fp-reg-tn-encoding frt)
780                     0
781                     (fp-reg-tn-encoding frb)
782                     ,xo
783                     ,(if rc-p 1 0))))))
784
785           (define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies)
786               `(progn
787                 (define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
788                 (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
789                                          :other-dependencies ,other-dependencies)))
790
791
792           (define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies)
793               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
794                 `(define-instruction ,name (segment rt ra si)
795                   (:declare (type (or ,@(when fixup '(fixup))
796                                       (unsigned-byte 16) (signed-byte 16))
797                                   si))
798                   (:printer d-si ((op ,op)))
799                   (:delay ,cost)
800                   (:cost ,cost)
801                   (:dependencies (reads ra) ,@other-reads
802                    (writes rt) ,@other-writes)
803                   (:emitter
804                    (when (typep si 'fixup)
805                      (ecase ,fixup
806                        ((:ha :l) (note-fixup segment ,fixup si)))
807                      (setq si (or (fixup-offset si) 0)))
808                    (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
809
810           (define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies)
811               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
812                 `(define-instruction ,name (segment ra rs ui)
813                   (:declare (type (unsigned-byte 16) ui))
814                   (:printer d-rs-ui ((op ,op)))
815                   (:cost ,cost)
816                   (:delay ,cost)
817                   (:dependencies (reads rs) ,@other-reads
818                    (writes ra) ,@other-writes)
819                   (:emitter
820                    (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui)))))
821
822           (define-d-instruction (name op &key (cost 2) other-dependencies pinned)
823               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
824                 `(define-instruction ,name (segment rt ra si)
825                   (:declare (type (signed-byte 16) si))
826                   (:printer d ((op ,op)))
827                   (:delay ,cost)
828                   (:cost ,cost)
829                   ,@(when pinned '(:pinned))
830                   (:dependencies (reads ra) (reads :memory) ,@other-reads
831                    (writes rt) ,@other-writes)
832                   (:emitter
833                    (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
834
835           (define-d-frt-instruction (name op &key (cost 3) other-dependencies)
836               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
837                 `(define-instruction ,name (segment frt ra si)
838                   (:declare (type (signed-byte 16) si))
839                   (:printer d-frt ((op ,op)))
840                   (:delay ,cost)
841                   (:cost ,cost)
842                   (:dependencies (reads ra) (reads :memory) ,@other-reads
843                    (writes frt) ,@other-writes)
844                   (:emitter
845                    (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si)))))
846
847           (define-d-rs-instruction (name op &key (cost 1) other-dependencies pinned)
848               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
849                 `(define-instruction ,name (segment rs ra si)
850                   (:declare (type (signed-byte 16) si))
851                   (:printer d-rs ((op ,op)))
852                   (:delay ,cost)
853                   (:cost ,cost)
854                   ,@(when pinned '(:pinned))
855                   (:dependencies (reads rs) (reads ra) ,@other-reads
856                    (writes :memory :partially t) ,@other-writes)
857                   (:emitter
858                    (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si)))))
859
860           (define-d-frs-instruction (name op &key (cost 1) other-dependencies)
861               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
862                 `(define-instruction ,name (segment frs ra si)
863                   (:declare (type (signed-byte 16) si))
864                   (:printer d-frs ((op ,op)))
865                   (:delay ,cost)
866                   (:cost ,cost)
867                   (:dependencies (reads frs) (reads ra) ,@other-reads
868                    (writes :memory :partially t) ,@other-writes)
869                   (:emitter
870                    (emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si)))))
871
872           (define-a-instruction (name op xo rc &key (cost 1) other-dependencies)
873               `(define-instruction ,name (segment frt fra frb frc)
874                 (:printer a ((op ,op) (xo ,xo) (rc ,rc)))
875                 (:cost ,cost)
876                 (:delay ,cost)
877                 (:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies)
878                 (:emitter
879                  (emit-a-form-inst segment
880                   ,op
881                   (fp-reg-tn-encoding frt)
882                   (fp-reg-tn-encoding fra)
883                   (fp-reg-tn-encoding frb)
884                   (fp-reg-tn-encoding frb)
885                   ,xo
886                   ,rc))))
887
888           (define-2-a-instructions (name op xo &key (cost 1) other-dependencies)
889               `(progn
890                 (define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
891                 (define-a-instruction ,(symbolicate name ".")
892                     ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
893
894           (define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies)
895               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
896                 `(define-instruction ,name (segment frt fra frb)
897                   (:printer a-tab ((op ,op) (xo ,xo) (rc ,rc)))
898                   (:cost ,cost)
899                   (:delay 1)
900                   (:dependencies (reads fra) (reads frb) ,@other-reads
901                    (writes frt) ,@other-writes)
902                   (:emitter
903                    (emit-a-form-inst segment
904                     ,op
905                     (fp-reg-tn-encoding frt)
906                     (fp-reg-tn-encoding fra)
907                     (fp-reg-tn-encoding frb)
908                     0
909                     ,xo
910                     ,rc)))))
911
912           (define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies)
913               `(progn
914                 (define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
915                 (define-a-tab-instruction ,(symbolicate name ".")
916                     ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
917
918           (define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies)
919               (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
920                 `(define-instruction ,name (segment frt fra frb)
921                   (:printer a-tac ((op ,op) (xo ,xo) (rc ,rc)))
922                   (:cost ,cost)
923                   (:delay 1)
924                   (:dependencies (reads fra) (reads frb) ,@other-reads
925                    (writes frt) ,@other-writes)
926                   (:emitter
927                    (emit-a-form-inst segment
928                     ,op
929                     (fp-reg-tn-encoding frt)
930                     (fp-reg-tn-encoding fra)
931                     0
932                     (fp-reg-tn-encoding frb)
933                     ,xo
934                     ,rc)))))
935
936           (define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies)
937               `(progn
938                 (define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
939                 (define-a-tac-instruction ,(symbolicate name ".")
940                     ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
941
942           (define-crbit-instruction (name op xo)
943               `(define-instruction ,name (segment dbit abit bbit)
944                 (:printer xl ((op ,op ) (xo ,xo)))
945                 (:delay 1)
946                 (:cost 1)
947                 (:dependencies (reads :ccr) (writes :ccr))
948                 (:emitter (emit-x-form-inst segment 19
949                            (valid-bi-encoding dbit)
950                            (valid-bi-encoding abit)
951                            (valid-bi-encoding bbit)
952                            ,xo
953                            0)))))
954
955   ;;; The instructions, in numerical order
956
957  (define-instruction unimp (segment data)
958    (:declare (type (signed-byte 16) data))
959    (:printer xinstr ((op-to-a #.(logior (ash 3 10) (ash 6 5) 0)))
960              :default :control #'unimp-control)
961    :pinned
962    (:delay 0)
963    (:emitter (emit-d-form-inst segment 3 6 0 data)))
964
965  (define-instruction twi (segment tcond ra si)
966    (:printer d-to ((op 3)))
967    (:delay 0)
968    :pinned
969    (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si)))
970
971  (define-d-si-instruction mulli 7 :cost 5)
972  (define-d-si-instruction subfic 8)
973
974  (define-instruction cmplwi (segment crf ra &optional (ui nil ui-p))
975    (:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui))
976    (:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr))
977    (:delay 1)
978    (:emitter
979     (unless ui-p
980       (setq ui ra ra crf crf :cr0))
981     (emit-d-form-inst segment
982                       10
983                       (valid-cr-field-encoding crf)
984                       (reg-tn-encoding ra)
985                       ui)))
986
987  (define-instruction cmpwi (segment crf ra  &optional (si nil si-p))
988    (:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si))
989    (:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr))
990    (:delay 1)
991    (:emitter
992     (unless si-p
993       (setq si ra ra crf crf :cr0))
994     (emit-d-form-inst segment
995                       11
996                       (valid-cr-field-encoding crf)
997                       (reg-tn-encoding ra)
998                       si)))
999
1000  (define-d-si-instruction addic 12 :other-dependencies ((writes :xer)))
1001  (define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr)))
1002
1003  (define-d-si-instruction addi 14 :fixup :l)
1004  (define-d-si-instruction addis 15 :fixup :ha)
1005
1006  ;; There's no real support here for branch options that decrement
1007  ;; and test the CTR :
1008  ;; (a) the instruction scheduler doesn't know that anything's happening
1009  ;;    to the CTR
1010  ;; (b) Lisp may have to assume that the CTR always has a lisp
1011  ;;    object/locative in it.
1012
1013  (define-instruction bc (segment bo bi target)
1014    (:declare (type label target))
1015    (:printer b ((op 16) (aa 0) (lk 0)))
1016    (:attributes branch)
1017    (:delay 0)
1018    (:dependencies (reads :ccr))
1019    (:emitter
1020     (emit-conditional-branch segment bo bi target)))
1021
1022  (define-instruction bcl (segment bo bi target)
1023    (:declare (type label target))
1024    (:printer b ((op 16) (aa 0) (lk 1)))
1025    (:attributes branch)
1026    (:delay 0)
1027    (:dependencies (reads :ccr))
1028    (:emitter
1029     (emit-conditional-branch segment bo bi target nil t)))
1030
1031  (define-instruction bca (segment bo bi target)
1032    (:declare (type label target))
1033    (:printer b ((op 16) (aa 1) (lk 0)))
1034    (:attributes branch)
1035    (:delay 0)
1036    (:dependencies (reads :ccr))
1037    (:emitter
1038     (emit-conditional-branch segment bo bi target t)))
1039
1040  (define-instruction bcla (segment bo bi target)
1041    (:declare (type label target))
1042    (:printer b ((op 16) (aa 1) (lk 1)))
1043    (:attributes branch)
1044    (:delay 0)
1045    (:dependencies (reads :ccr))
1046    (:emitter
1047     (emit-conditional-branch segment bo bi target t t)))
1048
1049;;; There may (or may not) be a good reason to use this in preference
1050;;; to "b[la] target".  I can't think of a -bad- reason ...
1051
1052  (define-instruction bu (segment target)
1053    (:declare (type label target))
1054    (:printer b ((op 16) (bo (valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0))
1055              '(:name :tab bd))
1056    (:attributes branch)
1057    (:delay 0)
1058    (:emitter
1059     (emit-conditional-branch segment (valid-bo-encoding :bo-u) 0 target nil nil)))
1060
1061
1062  (define-instruction bt (segment bi  target)
1063    (:printer b ((op 16) (bo (valid-bo-encoding :bo-t)) (aa 0) (lk 0))
1064              '(:name :tab bi "," bd))
1065    (:attributes branch)
1066    (:delay 0)
1067    (:emitter
1068     (emit-conditional-branch segment (valid-bo-encoding :bo-t) bi target nil nil)))
1069
1070  (define-instruction bf (segment bi  target)
1071    (:printer b ((op 16) (bo (valid-bo-encoding :bo-f)) (aa 0) (lk 0))
1072              '(:name :tab bi "," bd))
1073    (:attributes branch)
1074    (:delay 0)
1075    (:emitter
1076     (emit-conditional-branch segment (valid-bo-encoding :bo-f) bi target nil nil)))
1077
1078  (define-instruction b? (segment cr-field-name cr-name  &optional (target nil target-p))
1079    (:attributes branch)
1080    (:delay 0)
1081    (:emitter
1082     (unless target-p
1083       (setq target cr-name cr-name cr-field-name cr-field-name :cr0))
1084     (let*  ((+cond (position cr-name cr-bit-names))
1085             (-cond (position cr-name cr-bit-inverse-names))
1086             (b0 (if +cond :bo-t
1087                     (if -cond
1088                         :bo-f
1089                         (error "Unknown branch condition ~s" cr-name))))
1090             (cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond)))))
1091       (emit-conditional-branch segment b0 cr-form target))))
1092
1093  (define-instruction sc (segment)
1094    (:printer sc ((op 17)))
1095    (:attributes branch)
1096    (:delay 0)
1097    :pinned
1098    (:emitter (emit-sc-form-inst segment 17 2)))
1099
1100  (define-instruction b (segment target)
1101    (:printer i ((op 18) (aa 0) (lk 0)))
1102    (:attributes branch)
1103    (:delay 0)
1104    (:emitter
1105     (emit-i-form-branch segment target nil)))
1106
1107  (define-instruction ba (segment target)
1108    (:printer i-abs ((op 18) (aa 1) (lk 0)))
1109    (:attributes branch)
1110    (:delay 0)
1111    (:emitter
1112     (when (typep target 'fixup)
1113       (note-fixup segment :ba target)
1114       (setq target 0))
1115     (emit-i-form-inst segment 18 (ash target -2) 1 0)))
1116
1117
1118  (define-instruction bl (segment target)
1119    (:printer i ((op 18) (aa 0) (lk 1)))
1120    (:attributes branch)
1121    (:delay 0)
1122    (:emitter
1123     (emit-i-form-branch segment target t)))
1124
1125  (define-instruction bla (segment target)
1126    (:printer i-abs ((op 18) (aa 1) (lk 1)))
1127    (:attributes branch)
1128    (:delay 0)
1129    (:emitter
1130     (when (typep target 'fixup)
1131       (note-fixup segment :ba target)
1132       (setq target 0))
1133     (emit-i-form-inst segment 18 (ash target -2) 1 1)))
1134
1135  (define-instruction blr (segment)
1136    (:printer xl-bo-bi ((op 19) (xo 16) (bo (valid-bo-encoding :bo-u))(bi 0) (lk 0))  '(:name))
1137    (:attributes branch)
1138    (:delay 0)
1139    (:dependencies (reads :ccr) (reads :ctr))
1140    (:emitter
1141     (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0)))
1142
1143  (define-instruction bclr (segment bo bi)
1144    (:printer xl-bo-bi ((op 19) (xo 16)))
1145    (:attributes branch)
1146    (:delay 0)
1147    (:dependencies (reads :ccr) (reads :lr))
1148    (:emitter
1149     (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0)))
1150
1151  (define-instruction bclrl (segment bo bi)
1152    (:printer xl-bo-bi ((op 19) (xo 16) (lk 1)))
1153    (:attributes branch)
1154    (:delay 0)
1155    (:dependencies (reads :ccr) (reads :lr))
1156    (:emitter
1157     (emit-x-form-inst segment 19 (valid-bo-encoding bo)
1158                       (valid-bi-encoding bi) 0 16 1)))
1159
1160  (define-crbit-instruction crnor 19 33)
1161  (define-crbit-instruction crandc 19 129)
1162  (define-instruction isync (segment)
1163    (:printer xl-xo ((op 19) (xo 150)))
1164    (:delay 1)
1165    :pinned
1166    (:emitter (emit-x-form-inst segment 19 0 0 0 150 0)))
1167
1168  (define-crbit-instruction crxor 19 193)
1169  (define-crbit-instruction crnand 19 225)
1170  (define-crbit-instruction crand 19 257)
1171  (define-crbit-instruction creqv 19 289)
1172  (define-crbit-instruction crorc 19 417)
1173  (define-crbit-instruction cror 19 449)
1174
1175  (define-instruction bcctr (segment bo bi)
1176    (:printer xl-bo-bi ((op 19) (xo 528)))
1177    (:attributes branch)
1178    (:delay 0)
1179    (:dependencies (reads :ccr) (reads :ctr))
1180    (:emitter
1181     (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0)))
1182
1183  (define-instruction bcctrl (segment bo bi)
1184    (:printer xl-bo-bi ((op 19) (xo 528) (lk 1)))
1185    (:attributes branch)
1186    (:delay 0)
1187    (:dependencies (reads :ccr) (reads :ctr) (writes :lr))
1188    (:emitter
1189     (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1)))
1190
1191  (define-instruction bctr (segment)
1192    (:printer xl-bo-bi ((op 19) (xo 528) (bo (valid-bo-encoding :bo-u)) (bi 0) (lk 0))  '(:name))
1193    (:attributes branch)
1194    (:delay 0)
1195    (:dependencies (reads :ccr) (reads :ctr))
1196    (:emitter
1197     (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0  528 0)))
1198
1199  (define-instruction bctrl (segment)
1200    (:printer xl-bo-bi ((op 19) (xo 528) (bo (valid-bo-encoding :bo-u)) (bi 0) (lk 1))  '(:name))
1201    (:attributes branch)
1202    (:delay 0)
1203    (:dependencies (reads :ccr) (reads :ctr))
1204    (:emitter
1205     (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0  528 1)))
1206
1207  (define-instruction rlwimi (segment ra rs sh mb me)
1208    (:printer m-sh ((op 20) (rc 0)))
1209    (:dependencies (reads rs) (writes ra))
1210    (:delay 1)
1211    (:emitter
1212     (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1213
1214  (define-instruction rlwimi. (segment ra rs sh mb me)
1215    (:printer m-sh ((op 20) (rc 1)))
1216    (:dependencies (reads rs) (writes ra) (writes :ccr))
1217    (:delay 1)
1218    (:emitter
1219     (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1220
1221  (define-instruction rlwinm (segment ra rs sh mb me)
1222    (:printer m-sh ((op 21) (rc 0)))
1223    (:delay 1)
1224    (:dependencies (reads rs) (writes ra))
1225    (:emitter
1226     (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1227
1228  (define-instruction rlwinm. (segment ra rs sh mb me)
1229    (:printer m-sh ((op 21) (rc 1)))
1230    (:delay 1)
1231    (:dependencies (reads rs) (writes ra) (writes :ccr))
1232    (:emitter
1233     (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1234
1235  (define-instruction rlwnm (segment ra rs rb mb me)
1236    (:printer m ((op 23) (rc 0) (rb nil :type 'reg)))
1237    (:delay 1)
1238    (:dependencies (reads rs) (writes ra) (reads rb))
1239    (:emitter
1240     (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0)))
1241
1242  (define-instruction rlwnm. (segment ra rs rb mb me)
1243    (:printer m ((op 23) (rc 1) (rb nil :type 'reg)))
1244    (:delay 1)
1245    (:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr))
1246    (:emitter
1247     (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1)))
1248
1249
1250  (define-d-rs-ui-instruction ori 24)
1251
1252  (define-instruction nop (segment)
1253    (:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name))
1254    (:cost 1)
1255    (:delay 1)
1256    (:emitter
1257     (emit-d-form-inst segment 24 0 0 0)))
1258
1259  (define-d-rs-ui-instruction oris 25)
1260  (define-d-rs-ui-instruction xori 26)
1261  (define-d-rs-ui-instruction xoris 27)
1262  (define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr)))
1263  (define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr)))
1264
1265  (define-instruction cmpw (segment crf ra  &optional (rb nil rb-p))
1266    (:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb))
1267    (:delay 1)
1268    (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1269    (:emitter
1270     (unless rb-p
1271       (setq rb ra ra crf crf :cr0))
1272     (emit-x-form-inst segment
1273                       31
1274                       (valid-cr-field-encoding crf)
1275                       (reg-tn-encoding ra)
1276                       (reg-tn-encoding rb)
1277                       0
1278                       0)))
1279
1280  (define-instruction tw (segment tcond ra rb)
1281    (:printer x-19 ((op 31) (xo 4)))
1282    (:attributes branch)
1283    (:delay 0)
1284    :pinned
1285    (:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0)))
1286
1287  (define-4-xo-instructions subfc 31 8 :always-writes-xer t)
1288  (define-4-xo-instructions addc 31 10 :always-writes-xer t)
1289  (define-2-xo-oe-instructions mulhwu 31 11 :cost 5)
1290
1291  (define-instruction mfcr (segment rd)
1292    (:printer x-4 ((op 31) (xo 19)))
1293    (:delay 1)
1294    (:dependencies (reads :ccr) (writes rd))
1295    (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0)))
1296
1297  (define-x-instruction lwarx 31 20)
1298  (define-x-instruction lwzx 31 23)
1299  (define-2-x-5-instructions slw 31 24)
1300  (define-2-x-10-instructions cntlzw 31 26)
1301  (define-2-x-5-instructions and 31 28)
1302
1303  (define-instruction cmplw (segment crf ra  &optional (rb nil rb-p))
1304    (:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb))
1305    (:delay 1)
1306    (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1307    (:emitter
1308     (unless rb-p
1309       (setq rb ra ra crf crf :cr0))
1310     (emit-x-form-inst segment
1311                       31
1312                       (valid-cr-field-encoding crf)
1313                       (reg-tn-encoding ra)
1314                       (reg-tn-encoding rb)
1315                       32
1316                       0)))
1317
1318
1319  (define-4-xo-instructions subf 31 40)
1320                                        ; dcbst
1321  (define-x-instruction lwzux 31 55 :other-dependencies ((writes rt)))
1322  (define-2-x-5-instructions andc 31 60)
1323  (define-2-xo-oe-instructions mulhw 31 75 :cost 5)
1324
1325  (define-x-instruction lbzx 31 87)
1326  (define-4-xo-a-instructions neg 31 104)
1327  (define-x-instruction lbzux 31 119 :other-dependencies ((writes rt)))
1328  (define-2-x-5-instructions nor 31 124)
1329  (define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t)
1330
1331  (define-instruction-macro sube (rt ra rb)
1332    `(inst subfe ,rt ,rb ,ra))
1333
1334  (define-instruction-macro sube. (rt ra rb)
1335    `(inst subfe. ,rt ,rb ,ra))
1336
1337  (define-instruction-macro subeo (rt ra rb)
1338    `(inst subfeo ,rt ,rb ,ra))
1339
1340  (define-instruction-macro subeo. (rt ra rb)
1341    `(inst subfeo ,rt ,rb ,ra))
1342
1343  (define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t)
1344
1345  (define-instruction mtcrf (segment mask rt)
1346    (:printer xfx-fxm ((op 31) (xo 144)))
1347    (:delay 1)
1348    (:dependencies (reads rt) (writes :ccr))
1349    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0)))
1350
1351  (define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr)))
1352  (define-x-5-st-instruction stwx 31 151 nil)
1353  (define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra)))
1354  (define-4-xo-a-instructions subfze 31 200 :always-reads-xer t :always-writes-xer t)
1355  (define-4-xo-a-instructions addze 31 202 :always-reads-xer t :always-writes-xer t)
1356  (define-x-5-st-instruction stbx 31 215 nil)
1357  (define-4-xo-a-instructions subfme 31 232 :always-reads-xer t :always-writes-xer t)
1358  (define-4-xo-a-instructions addme 31 234 :always-reads-xer t :always-writes-xer t)
1359  (define-4-xo-instructions mullw 31 235 :cost 5)
1360  (define-x-5-st-instruction stbux 31 247 nil :other-dependencies ((writes ra)))
1361  (define-4-xo-instructions add 31 266)
1362  (define-x-instruction lhzx 31 279)
1363  (define-2-x-5-instructions eqv 31 284)
1364  (define-x-instruction lhzux 31 311 :other-dependencies ((writes ra)))
1365  (define-2-x-5-instructions xor 31 316)
1366
1367  (define-instruction mfmq (segment rt)
1368    (:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt))
1369    (:delay 1)
1370    (:dependencies (reads :xer) (writes rt))
1371    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0)))
1372
1373  (define-instruction mfxer (segment rt)
1374    (:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt))
1375    (:delay 1)
1376    (:dependencies (reads :xer) (writes rt))
1377    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0)))
1378
1379  (define-instruction mflr (segment rt)
1380    (:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt))
1381    (:delay 1)
1382    (:dependencies (reads :lr) (writes rt))
1383    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0)))
1384
1385  (define-instruction mfctr (segment rt)
1386    (:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt))
1387    (:delay 1)
1388    (:dependencies (reads rt) (reads :ctr))
1389    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0)))
1390
1391
1392  (define-x-instruction lhax 31 343)
1393  (define-x-instruction lhaux 31 375 :other-dependencies ((writes ra)))
1394  (define-x-5-st-instruction sthx 31 407 nil)
1395  (define-2-x-5-instructions orc 31 412)
1396  (define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra)))
1397
1398  (define-instruction or (segment ra rs rb)
1399    (:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond
1400                                                ((rs :same-as rb) 'mr)
1401                                                (t :name))
1402                                              :tab
1403                                              ra "," rs
1404                                              (:unless (:same-as rs) "," rb)))
1405    (:delay 1)
1406    (:cost 1)
1407    (:dependencies (reads rb) (reads rs) (writes ra))
1408    (:emitter
1409     (emit-x-form-inst segment
1410                       31
1411                       (reg-tn-encoding rs)
1412                       (reg-tn-encoding ra)
1413                       (reg-tn-encoding rb)
1414                       444
1415                       0)))
1416
1417  (define-instruction or. (segment ra rs rb)
1418    (:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond
1419                                                ((rs :same-as rb) 'mr.)
1420                                                (t :name))
1421                                              :tab
1422                                              ra "," rs
1423                                              (:unless (:same-as rs) "," rb)))
1424    (:delay 1)
1425    (:cost 1)
1426    (:dependencies (reads rb) (reads rs) (writes ra) (writes :ccr))
1427    (:emitter
1428     (emit-x-form-inst segment
1429                       31
1430                       (reg-tn-encoding rs)
1431                       (reg-tn-encoding ra)
1432                       (reg-tn-encoding rb)
1433                       444
1434                       1)))
1435
1436  (define-instruction-macro mr (ra rs)
1437    `(inst or ,ra ,rs ,rs))
1438
1439  (define-instruction-macro mr. (ra rs)
1440    `(inst or. ,ra ,rs ,rs))
1441
1442  (define-4-xo-instructions divwu 31 459 :cost 36)
1443
1444                                        ; This is a 601-specific instruction class.
1445  (define-4-xo-instructions div 31 331 :cost 36)
1446
1447                                        ; This is a 601-specific instruction.
1448  (define-instruction mtmq (segment rt)
1449    (:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt))
1450    (:delay 1)
1451    (:dependencies (reads rt) (writes :xer))
1452    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0)))
1453
1454  (define-instruction mtxer (segment rt)
1455    (:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt))
1456    (:delay 1)
1457    (:dependencies (reads rt) (writes :xer))
1458    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0)))
1459
1460  (define-instruction mtlr (segment rt)
1461    (:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt))
1462    (:delay 1)
1463    (:dependencies (reads rt) (writes :lr))
1464    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0)))
1465
1466  (define-instruction mtctr (segment rt)
1467    (:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt))
1468    (:delay 1)
1469    (:dependencies (reads rt) (writes :ctr))
1470    (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0)))
1471
1472
1473  (define-2-x-5-instructions nand 31 476)
1474  (define-4-xo-instructions divw 31 491 :cost 36)
1475  (define-instruction mcrxr (segment crf)
1476    (:printer x-18 ((op 31) (xo 512)))
1477    (:delay 1)
1478    (:dependencies (reads :xer) (writes :ccr) (writes :xer))
1479    (:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0)))
1480
1481  (define-instruction lswx (segment rs ra rb)
1482    (:printer x ((op 31) (xo 533) (rc 0)))
1483    (:delay 1)
1484    :pinned
1485    (:cost 8)
1486    (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0)))
1487  (define-x-instruction lwbrx 31 534)
1488  (define-x-20-instruction lfsx 31 535)
1489  (define-2-x-5-instructions srw 31 536)
1490  (define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra)))
1491
1492  (define-instruction lswi (segment rt ra rb)
1493    (:printer x-1 ((op 31) (xo 597) (rc 0)))
1494    :pinned
1495    (:delay 8)
1496    (:cost 8)
1497    (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0)))
1498
1499  (define-instruction sync (segment)
1500    (:printer x-27 ((op 31) (xo 598)))
1501    (:delay 1)
1502    :pinned
1503    (:emitter (emit-x-form-inst segment 31 0 0 0 598 0)))
1504  (define-x-20-instruction lfdx 31 599)
1505  (define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra)))
1506  (define-instruction stswx (segment rs ra rb)
1507    (:printer x-5 ((op 31) (xo 661)))
1508    :pinned
1509    (:cost 8)
1510    (:delay 1)
1511    (:emitter (emit-x-form-inst segment 31
1512                                (reg-tn-encoding rs)
1513                                (reg-tn-encoding ra)
1514                                (reg-tn-encoding rb)
1515                                661
1516                                0)))
1517  (define-x-5-st-instruction stwbrx 31 662 nil)
1518  (define-x-23-st-instruction stfsx 31 663)
1519  (define-x-23-st-instruction stfsux 31 695 :other-dependencies ((writes ra)))
1520  (define-instruction stswi (segment rs ra nb)
1521    (:printer x-8 ((op 31) (xo 725)))
1522    :pinned
1523    (:delay 1)
1524    (:emitter
1525     (emit-x-form-inst segment 31
1526                       (reg-tn-encoding rs)
1527                       (reg-tn-encoding ra)
1528                       nb
1529                       725
1530                       0)))
1531
1532  (define-x-23-st-instruction stfdx 31 727)
1533  (define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra)))
1534  (define-x-instruction lhbrx 31 790)
1535  (define-2-x-5-instructions sraw 31 792)
1536
1537  (define-instruction srawi (segment ra rs rb)
1538    (:printer x-9 ((op 31) (xo 824) (rc 0)))
1539    (:cost 1)
1540    (:delay 1)
1541    (:dependencies (reads rs) (writes ra))
1542    (:emitter
1543     (emit-x-form-inst segment 31
1544                       (reg-tn-encoding rs)
1545                       (reg-tn-encoding ra)
1546                       rb
1547                       824
1548                       0)))
1549
1550  (define-instruction srawi. (segment ra rs rb)
1551    (:printer x-9 ((op 31) (xo 824) (rc 1)))
1552    (:cost 1)
1553    (:delay 1)
1554    (:dependencies (reads rs) (writes ra) (writes :ccr))
1555    (:emitter
1556     (emit-x-form-inst segment 31
1557                       (reg-tn-encoding rs)
1558                       (reg-tn-encoding ra)
1559                       rb
1560                       824
1561                        1)))
1562
1563  (define-instruction eieio (segment)
1564    (:printer x-27 ((op 31) (xo 854)))
1565    :pinned
1566    (:delay 1)
1567    (:emitter (emit-x-form-inst segment 31 0 0 0 854 0)))
1568
1569  (define-x-5-st-instruction sthbrx 31 918 nil)
1570
1571  (define-2-x-10-instructions extsb 31 954)
1572  (define-2-x-10-instructions extsh 31 922)
1573                                        ; Whew.
1574
1575  (define-instruction lwz (segment rt ra si)
1576    (:declare (type (or fixup (signed-byte 16)) si))
1577    (:printer d ((op 32)))
1578    (:delay 2)
1579    (:cost 2)
1580    (:dependencies (reads ra) (writes rt) (reads :memory))
1581    (:emitter
1582     (when (typep si 'fixup)
1583       (note-fixup segment :l si)
1584       (setq si 0))
1585     (emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si)))
1586
1587  (define-d-instruction lwzu 33 :other-dependencies ((writes ra)))
1588  (define-d-instruction lbz 34)
1589  (define-d-instruction lbzu 35 :other-dependencies ((writes ra)))
1590  (define-d-rs-instruction stw 36)
1591  (define-d-rs-instruction stwu 37 :other-dependencies ((writes ra)))
1592  (define-d-rs-instruction stb 38)
1593  (define-d-rs-instruction stbu 39 :other-dependencies ((writes ra)))
1594  (define-d-instruction lhz 40)
1595  (define-d-instruction lhzu 41 :other-dependencies ((writes ra)))
1596  (define-d-instruction lha 42)
1597  (define-d-instruction lhau 43 :other-dependencies ((writes ra)))
1598  (define-d-rs-instruction sth 44)
1599  (define-d-rs-instruction sthu 45 :other-dependencies ((writes ra)))
1600  (define-d-instruction lmw 46 :pinned t)
1601  (define-d-rs-instruction stmw 47 :pinned t)
1602  (define-d-frt-instruction lfs 48)
1603  (define-d-frt-instruction lfsu 49 :other-dependencies ((writes ra)))
1604  (define-d-frt-instruction lfd 50)
1605  (define-d-frt-instruction lfdu 51 :other-dependencies ((writes ra)))
1606  (define-d-frs-instruction stfs 52)
1607  (define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra)))
1608  (define-d-frs-instruction stfd 54)
1609  (define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra)))
1610
1611  (define-2-a-tab-instructions fdivs 59 18 :cost 17)
1612  (define-2-a-tab-instructions fsubs 59 20)
1613  (define-2-a-tab-instructions fadds 59 21)
1614  (define-2-a-tac-instructions fmuls 59 25)
1615  (define-2-a-instructions fmsubs 59 28 :cost 4)
1616  (define-2-a-instructions fmadds 59 29 :cost 4)
1617  (define-2-a-instructions fnmsubs 59 30 :cost 4)
1618  (define-2-a-instructions fnmadds 59 31 :cost 4)
1619
1620  (define-instruction fcmpu (segment crfd fra frb)
1621    (:printer x-15 ((op 63) (xo 0)))
1622    (:dependencies (reads fra) (reads frb) (reads :fpscr)
1623                   (writes :fpscr) (writes :ccr))
1624    (:cost 4)
1625    (:delay 4)
1626    (:emitter (emit-x-form-inst segment
1627                                63
1628                                (valid-cr-field-encoding crfd)
1629                                (fp-reg-tn-encoding fra)
1630                                (fp-reg-tn-encoding frb)
1631                                0
1632                                0)))
1633
1634
1635  (define-2-x-21-instructions frsp 63 12)
1636  (define-2-x-21-instructions fctiw 63 14)
1637  (define-2-x-21-instructions fctiwz 63 15)
1638
1639  (define-2-a-tab-instructions fdiv 63 18 :cost 31)
1640  (define-2-a-tab-instructions fsub 63 20)
1641  (define-2-a-tab-instructions fadd 63 21)
1642  (define-2-a-tac-instructions fmul 63 25 :cost 5)
1643  (define-2-a-instructions fmsub 63 28 :cost 5)
1644  (define-2-a-instructions fmadd 63 29 :cost 5)
1645  (define-2-a-instructions fnmsub 63 30 :cost 5)
1646  (define-2-a-instructions fnmadd 63 31 :cost 5)
1647
1648  (define-instruction fcmpo (segment crfd fra frb)
1649    (:printer x-15 ((op 63) (xo 32)))
1650    (:dependencies (reads fra) (reads frb) (reads :fpscr)
1651                   (writes :fpscr) (writes :ccr))
1652    (:cost 4)
1653    (:delay 1)
1654    (:emitter (emit-x-form-inst segment
1655                                63
1656                                (valid-cr-field-encoding crfd)
1657                                (fp-reg-tn-encoding fra)
1658                                (fp-reg-tn-encoding frb)
1659                                32
1660                              0)))
1661
1662  (define-2-x-21-instructions fneg 63 40)
1663
1664  (define-2-x-21-instructions fmr 63 72)
1665  (define-2-x-21-instructions fnabs 63 136)
1666  (define-2-x-21-instructions fabs 63 264)
1667
1668  (define-instruction mffs (segment frd)
1669  (:printer x-22 ((op 63)  (xo 583) (rc 0)))
1670  (:delay 1)
1671  (:dependencies (reads :fpscr) (writes frd))
1672  (:emitter (emit-x-form-inst segment
1673                          63
1674                          (fp-reg-tn-encoding frd)
1675                          0
1676                          0
1677                          583
1678                          0)))
1679
1680  (define-instruction mffs. (segment frd)
1681  (:printer x-22 ((op 63)  (xo 583) (rc 1)))
1682  (:delay 1)
1683  (:dependencies (reads :fpscr) (writes frd) (writes :ccr))
1684  (:emitter (emit-x-form-inst segment
1685                          63
1686                          (fp-reg-tn-encoding frd)
1687                          0
1688                          0
1689                          583
1690                          1)))
1691
1692  (define-instruction mtfsf (segment mask rb)
1693  (:printer xfl ((op 63) (xo 711) (rc 0)))
1694  (:dependencies (reads rb) (writes :fpscr))
1695  (:delay 1)
1696  (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 0)))
1697
1698  (define-instruction mtfsf. (segment mask rb)
1699  (:printer xfl ((op 63) (xo 711) (rc 1)))
1700  (:delay 1)
1701  (:dependencies (reads rb) (writes :ccr) (writes :fpscr))
1702  (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 1)))
1703
1704
1705
1706
1707;;; Here in the future, macros are our friends.
1708
1709  (define-instruction-macro subis (rt ra simm)
1710    `(inst addis ,rt ,ra (- ,simm)))
1711
1712  (define-instruction-macro sub (rt rb ra)
1713    `(inst subf ,rt ,ra ,rb))
1714  (define-instruction-macro sub. (rt rb ra)
1715    `(inst subf. ,rt ,ra ,rb))
1716  (define-instruction-macro subo (rt rb ra)
1717    `(inst subfo ,rt ,ra ,rb))
1718  (define-instruction-macro subo. (rt rb ra)
1719    `(inst subfo. ,rt ,ra ,rb))
1720
1721
1722  (define-instruction-macro subic (rt ra simm)
1723    `(inst addic ,rt ,ra (- ,simm)))
1724
1725
1726  (define-instruction-macro subic. (rt ra simm)
1727    `(inst addic. ,rt ,ra (- ,simm)))
1728
1729
1730
1731  (define-instruction-macro subc (rt rb ra)
1732    `(inst subfc ,rt ,ra ,rb))
1733  (define-instruction-macro subc. (rt rb ra)
1734    `(inst subfc. ,rt ,ra ,rb))
1735  (define-instruction-macro subco (rt rb ra)
1736    `(inst subfco ,rt ,ra ,rb))
1737  (define-instruction-macro subco. (rt rb ra)
1738    `(inst subfco. ,rt ,ra ,rb))
1739
1740  (define-instruction-macro subi (rt ra simm)
1741    `(inst addi ,rt ,ra (- ,simm)))
1742
1743  (define-instruction-macro li (rt val)
1744    `(inst addi ,rt zero-tn ,val))
1745
1746  (define-instruction-macro lis (rt val)
1747    `(inst addis ,rt zero-tn ,val))
1748
1749
1750  (define-instruction-macro not (ra rs)
1751    `(inst nor ,ra ,rs ,rs))
1752
1753  (define-instruction-macro not. (ra rs)
1754    `(inst nor. ,ra ,rs ,rs))
1755
1756
1757  (defun emit-nop (segment)
1758                           (emit-word segment #x60000000))
1759
1760  (define-instruction-macro extlwi (ra rs n b)
1761    `(inst rlwinm ,ra ,rs ,b 0 (1- ,n)))
1762
1763  (define-instruction-macro extlwi. (ra rs n b)
1764    `(inst rlwinm. ,ra ,rs ,b 0 (1- ,n)))
1765
1766  (define-instruction-macro extrwi (ra rs n b)
1767    `(inst rlwinm ,ra ,rs (mod (+ ,b ,n) 32) (- 32 ,n) 31))
1768
1769  (define-instruction-macro extrwi. (ra rs n b)
1770    `(inst rlwinm. ,ra ,rs (mod (+ ,b ,n) 32) (- 32 ,n) 31))
1771
1772  (define-instruction-macro srwi (ra rs n)
1773    `(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31))
1774
1775  (define-instruction-macro srwi. (ra rs n)
1776    `(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31))
1777
1778  (define-instruction-macro clrlwi (ra rs n)
1779    `(inst rlwinm ,ra ,rs 0 ,n 31))
1780
1781  (define-instruction-macro clrlwi. (ra rs n)
1782    `(inst rlwinm. ,ra ,rs 0 ,n 31))
1783
1784  (define-instruction-macro clrrwi (ra rs n)
1785    `(inst rlwinm ,ra ,rs 0 0 (- 31 ,n)))
1786
1787  (define-instruction-macro clrrwi. (ra rs n)
1788    `(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n)))
1789
1790  (define-instruction-macro inslw (ra rs n b)
1791    `(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1792
1793  (define-instruction-macro inslw. (ra rs n b)
1794    `(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1795
1796  (define-instruction-macro rotlw (ra rs rb)
1797    `(inst rlwnm ,ra ,rs ,rb 0 31))
1798
1799  (define-instruction-macro rotlw. (ra rs rb)
1800    `(inst rlwnm. ,ra ,rs ,rb 0 31))
1801
1802  (define-instruction-macro rotlwi (ra rs n)
1803    `(inst rlwinm ,ra ,rs ,n 0 31))
1804
1805  (define-instruction-macro rotrwi (ra rs n)
1806    `(inst rlwinm ,ra ,rs (- 32 ,n) 0 31))
1807
1808  (define-instruction-macro slwi (ra rs n)
1809    `(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n)))
1810
1811  (define-instruction-macro slwi. (ra rs n)
1812    `(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n))))
1813
1814
1815
1816
1817#|
1818(macrolet
1819  ((define-conditional-branches (name bo-name)
1820     (let* ((bo-enc (valid-bo-encoding bo-name)))
1821       `(progn
1822          (define-instruction-macro ,(symbolicate name "A") (bi target)
1823            ``(inst bca ,,,bo-enc ,,bi ,,target))
1824          (define-instruction-macro ,(symbolicate name "L") (bi target)
1825            ``(inst bcl ,,,bo-enc ,,bi ,,target))
1826          (define-instruction-macro ,(symbolicate name "LA") (bi target)
1827            ``(inst bcla ,,,bo-enc ,,bi ,,target))
1828          (define-instruction-macro ,(symbolicate name "CTR") (bi target)
1829            ``(inst bcctr ,,,bo-enc ,,bi ,,target))
1830          (define-instruction-macro ,(symbolicate name "CTRL") (bi target)
1831            ``(inst bcctrl ,,,bo-enc ,,bi ,,target))
1832          (define-instruction-macro ,(symbolicate name "LR") (bi target)
1833            ``(inst bclr ,,,bo-enc ,,bi ,,target))
1834          (define-instruction-macro ,(symbolicate name "LRL") (bi target)
1835            ``(inst bclrl ,,,bo-enc ,,bi ,,target))))))
1836  (define-conditional-branches bt :bo-t)
1837  (define-conditional-branches bf :bo-f))
1838|#
1839
1840(macrolet
1841  ((define-positive-conditional-branches (name cr-bit-name)
1842     `(progn
1843        (define-instruction-macro ,name (crf &optional (target nil target-p))
1844          (unless target-p
1845            (setq target crf crf :cr0))
1846          `(inst bt `(,,crf ,,,cr-bit-name) ,target))
1847#|
1848        (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1849          ``(inst bta (,,cr-field ,,,cr-bit-name) ,,target))
1850        (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1851          ``(inst btl (,,cr-field ,,,cr-bit-name) ,,target))
1852        (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1853          ``(inst btla (,,cr-field ,,,cr-bit-name) ,,target))
1854        (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1855          ``(inst btctr (,,cr-field ,,,cr-bit-name) ,,target))
1856        (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1857          ``(inst btctrl (,,cr-field ,,,cr-bit-name) ,,target))
1858        (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1859          ``(inst btlr (,,cr-field ,,,cr-bit-name) ,,target))
1860        (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1861          ``(inst btlrl (,,cr-field ,,,cr-bit-name) ,,target))
1862|#
1863        )))
1864  (define-positive-conditional-branches beq :eq)
1865  (define-positive-conditional-branches blt :lt)
1866  (define-positive-conditional-branches bgt :gt)
1867  (define-positive-conditional-branches bso :so)
1868  (define-positive-conditional-branches bun :so))
1869
1870
1871(macrolet
1872  ((define-negative-conditional-branches (name cr-bit-name)
1873     `(progn
1874        (define-instruction-macro ,name (crf &optional (target nil target-p))
1875          (unless target-p
1876            (setq target crf crf :cr0))
1877          `(inst bf `(,,crf ,,,cr-bit-name) ,target))
1878#|
1879        (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1880          ``(inst bfa (,,cr-field ,,,cr-bit-name) ,,target))
1881        (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1882          ``(inst bfl (,,cr-field ,,,cr-bit-name) ,,target))
1883        (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1884          ``(inst bfla (,,cr-field ,,,cr-bit-name) ,,target))
1885        (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1886          ``(inst bfctr (,,cr-field ,,,cr-bit-name) ,,target))
1887        (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1888          ``(inst bfctrl (,,cr-field ,,,cr-bit-name) ,,target))
1889        (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1890          ``(inst bflr (,,cr-field ,,,cr-bit-name) ,,target))
1891        (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1892          ``(inst bflrl (,,cr-field ,,,cr-bit-name) ,,target))
1893|#
1894)))
1895  (define-negative-conditional-branches bne :eq)
1896  (define-negative-conditional-branches bnl :lt)
1897  (define-negative-conditional-branches bge :lt)
1898  (define-negative-conditional-branches bng :gt)
1899  (define-negative-conditional-branches ble :gt)
1900  (define-negative-conditional-branches bns :so)
1901  (define-negative-conditional-branches bnu :so))
1902
1903
1904
1905(define-instruction-macro j (func-tn offset)
1906  `(progn
1907    (inst addi lip-tn ,func-tn ,offset)
1908    (inst mtctr lip-tn)
1909    (inst bctr)))
1910
1911
1912#|
1913(define-instruction-macro bua (target)
1914  `(inst bca :bo-u 0 ,target))
1915
1916(define-instruction-macro bul (target)
1917  `(inst bcl :bo-u 0 ,target))
1918
1919(define-instruction-macro bula (target)
1920  `(inst bcla :bo-u 0 ,target))
1921|#
1922
1923(define-instruction-macro blrl ()
1924  `(inst bclrl :bo-u 0))
1925
1926
1927;;; Some more macros
1928
1929(defun %lr (reg value)
1930  (etypecase value
1931    ((signed-byte 16)
1932     (inst li reg value))
1933    ((unsigned-byte 16)
1934     (inst ori reg zero-tn value))
1935    ((or (signed-byte 32) (unsigned-byte 32))
1936     (let* ((high-half (ldb (byte 16 16) value))
1937            (low-half (ldb (byte 16 0) value)))
1938       (declare (type (unsigned-byte 16) high-half low-half))
1939       (cond ((and (logbitp 15 low-half) (= high-half #xffff))
1940              (inst li reg (dpb low-half (byte 16 0) -1)))
1941             ((and (not (logbitp 15 low-half)) (zerop high-half))
1942              (inst li reg low-half))
1943             (t
1944              (inst lis reg (if (logbitp 15 high-half)
1945                                (dpb high-half (byte 16 0) -1)
1946                                high-half))
1947              (unless (zerop low-half)
1948                (inst ori reg reg low-half))))))
1949    (fixup
1950     (inst lis reg value)
1951     (inst addi reg reg value))))
1952
1953(define-instruction-macro lr (reg value)
1954  `(%lr ,reg ,value))
1955
1956
1957
1958;;;; Instructions for dumping data and header objects.
1959
1960(define-instruction word (segment word)
1961  (:declare (type (or (unsigned-byte 32) (signed-byte 32) fixup) word))
1962  :pinned
1963  (:delay 0)
1964  (:emitter
1965   (etypecase word
1966     (fixup
1967      (note-fixup segment :absolute word)
1968      (emit-word segment 0))
1969     (integer
1970      (emit-word segment word)))))
1971
1972(define-instruction short (segment short)
1973  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
1974  :pinned
1975  (:delay 0)
1976  (:emitter
1977   (emit-short segment short)))
1978
1979(define-instruction byte (segment byte)
1980  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
1981  :pinned
1982  (:delay 0)
1983  (:emitter
1984   (emit-byte segment byte)))
1985
1986(define-bitfield-emitter emit-header-object 32
1987  (byte 24 8) (byte 8 0))
1988
1989(defun emit-header-data (segment type)
1990  (emit-back-patch
1991   segment 4
1992   #'(lambda (segment posn)
1993       (emit-word segment
1994                  (logior type
1995                          (ash (+ posn (component-header-length))
1996                               (- n-widetag-bits word-shift)))))))
1997
1998(define-instruction simple-fun-header-word (segment)
1999  :pinned
2000  (:delay 0)
2001  (:emitter
2002   (emit-header-data segment simple-fun-header-widetag)))
2003
2004(define-instruction lra-header-word (segment)
2005  :pinned
2006  (:delay 0)
2007  (:emitter
2008   (emit-header-data segment return-pc-header-widetag)))
2009
2010
2011;;;; Instructions for converting between code objects, functions, and lras.
2012(defun emit-compute-inst (segment vop dst src label temp calc)
2013  (emit-chooser
2014   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
2015   segment 12 3
2016   #'(lambda (segment posn delta-if-after)
2017       (let ((delta (funcall calc label posn delta-if-after)))
2018         (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
2019           (emit-back-patch segment 4
2020                            #'(lambda (segment posn)
2021                                (assemble (segment vop)
2022                                          (inst addi dst src
2023                                                (funcall calc label posn 0)))))
2024           t)))
2025   #'(lambda (segment posn)
2026       (let ((delta (funcall calc label posn 0)))
2027         (assemble (segment vop)
2028                   (inst lis temp (ldb (byte 16 16) delta))
2029                   (inst ori temp temp (ldb (byte 16 0) delta))
2030                   (inst add dst src temp))))))
2031
2032;; code = lip - header - label-offset + other-pointer-tag
2033(define-instruction compute-code-from-lip (segment dst src label temp)
2034  (:declare (type tn dst src temp) (type label label))
2035  (:attributes variable-length)
2036  (:dependencies (reads src) (writes dst) (writes temp))
2037  (:delay 0)
2038  (:vop-var vop)
2039  (:emitter
2040   (emit-compute-inst segment vop dst src label temp
2041                      #'(lambda (label posn delta-if-after)
2042                          (- other-pointer-lowtag
2043                             ;;function-pointer-type
2044                             (label-position label posn delta-if-after)
2045                             (component-header-length))))))
2046
2047;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
2048;;      = lra - (header + label-offset)
2049(define-instruction compute-code-from-lra (segment dst src label temp)
2050  (:declare (type tn dst src temp) (type label label))
2051  (:attributes variable-length)
2052  (:dependencies (reads src) (writes dst) (writes temp))
2053  (:delay 0)
2054  (:vop-var vop)
2055  (:emitter
2056   (emit-compute-inst segment vop dst src label temp
2057                      #'(lambda (label posn delta-if-after)
2058                          (- (+ (label-position label posn delta-if-after)
2059                                (component-header-length)))))))
2060
2061;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
2062;;     = code + header + label-offset
2063(define-instruction compute-lra-from-code (segment dst src label temp)
2064  (:declare (type tn dst src temp) (type label label))
2065  (:attributes variable-length)
2066  (:dependencies (reads src) (writes dst) (writes temp))
2067  (:delay 0)
2068  (:vop-var vop)
2069  (:emitter
2070   (emit-compute-inst segment vop dst src label temp
2071                      #'(lambda (label posn delta-if-after)
2072                          (+ (label-position label posn delta-if-after)
2073                             (component-header-length))))))
2074