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