1 ;;;; the instruction set definition for the PPC
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; needs a little more work in the assembler, to realise that the
15 ;;; delays requested here are not mandatory, so that the assembler
16 ;;; shouldn't fill gaps with NOPs but with real instructions. -- CSR,
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (setf sb!assem:*assem-scheduler-p* t)
21 (setf sb!assem:*assem-max-locations* 70))
23 ;;;; Constants, types, conversion functions, some disassembler stuff.
25 (defun reg-tn-encoding (tn)
26 (declare (type tn tn))
31 (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
33 (error "~S isn't a register." tn)))))
35 (defun fp-reg-tn-encoding (tn)
36 (declare (type tn tn))
37 (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
38 (error "~S isn't a floating-point register." tn))
41 ;(sb!disassem:set-disassem-params :instruction-alignment 32)
43 (defvar *disassem-use-lisp-reg-names* t)
45 (!def-vm-support-routine location-number (loc)
52 (ecase (sb-name (sc-sb (tn-sc loc)))
54 ;; Can happen if $ZERO or $NULL are passed in.
57 (unless (zerop (tn-offset loc))
60 (+ (tn-offset loc) 32))))
70 (defparameter reg-symbols
73 (cond ((null name) nil)
74 (t (make-symbol (concatenate 'string "$" name)))))
77 (defun maybe-add-notes (regno dstate)
78 (let* ((inst (sb!disassem::sap-ref-int
79 (sb!disassem::dstate-segment-sap dstate)
80 (sb!disassem::dstate-cur-offs dstate)
82 (sb!disassem::dstate-byte-order dstate)))
83 (op (ldb (byte 6 26) inst)))
87 (when (= regno (ldb (byte 5 16) inst)) ; only for the second
88 (case (ldb (byte 5 16) inst)
91 (sb!disassem:note-code-constant (ldb (byte 16 0) inst) dstate)))))
94 (when (= regno null-offset)
95 (sb!disassem:maybe-note-nil-indexed-object
96 (ldb (byte 16 0) inst) dstate))))))
98 (sb!disassem:define-arg-type reg
100 (lambda (value stream dstate)
101 (declare (type stream stream) (fixnum value))
102 (let ((regname (aref reg-symbols value)))
103 (princ regname stream)
104 (sb!disassem:maybe-note-associated-storage-ref
105 value 'registers regname dstate)
106 (maybe-add-notes value dstate))))
108 (defparameter float-reg-symbols
110 (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
113 (sb!disassem:define-arg-type fp-reg
114 :printer #'(lambda (value stream dstate)
115 (declare (type stream stream) (fixnum value))
116 (let ((regname (aref float-reg-symbols value)))
117 (princ regname stream)
118 (sb!disassem:maybe-note-associated-storage-ref
124 (eval-when (:compile-toplevel :load-toplevel :execute)
125 (defparameter bo-kind-names
126 #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil
127 :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil
128 :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil
129 nil nil nil nil nil nil nil nil)))
131 (sb!disassem:define-arg-type bo-field
132 :printer #'(lambda (value stream dstate)
133 (declare (ignore dstate)
136 (princ (svref bo-kind-names value) stream)))
138 (eval-when (:compile-toplevel :load-toplevel :execute)
139 (defun valid-bo-encoding (enc)
140 (or (if (integerp enc)
141 (and (= enc (logand #x1f enc))
142 (not (null (svref bo-kind-names enc)))
144 (and enc (position enc bo-kind-names)))
145 (error "Invalid BO field spec: ~s" enc)))
149 (defparameter cr-bit-names #(:lt :gt :eq :so))
150 (defparameter cr-bit-inverse-names #(:ge :le :ne :ns))
152 (defparameter cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
154 (defun valid-cr-bit-encoding (enc &optional error-p)
155 (or (if (integerp enc)
156 (and (= enc (logand 3 enc))
158 (position enc cr-bit-names)
159 (if error-p (error "Invalid condition bit specifier : ~s" enc))))
161 (defun valid-cr-field-encoding (enc)
162 (let* ((field (if (integerp enc)
163 (and (= enc (logand #x7 enc)))
164 (position enc cr-field-names))))
167 (error "Invalid condition register field specifier : ~s" enc))))
169 (defun valid-bi-encoding (enc)
173 (and (= enc (logand 31 enc)) enc)
174 (position enc cr-bit-names))
175 (+ (valid-cr-field-encoding (car enc))
176 (valid-cr-bit-encoding (cadr enc))))
177 (error "Invalid BI field spec : ~s" enc)))
179 (sb!disassem:define-arg-type bi-field
180 :printer #'(lambda (value stream dstate)
181 (declare (ignore dstate)
183 (type (unsigned-byte 5) value))
184 (let* ((bitname (svref cr-bit-names (logand 3 value)))
185 (crfield (ash value -2)))
186 (declare (type (unsigned-byte 3) crfield))
188 (princ bitname stream)
189 (princ (list (svref cr-field-names crfield) bitname) stream)))))
191 (sb!disassem:define-arg-type crf
192 :printer #'(lambda (value stream dstate)
193 (declare (ignore dstate)
195 (type (unsigned-byte 3) value))
196 (princ (svref cr-field-names value) stream)))
198 (sb!disassem:define-arg-type relative-label
200 :use-label #'(lambda (value dstate)
201 (declare (type (signed-byte 14) value)
202 (type sb!disassem:disassem-state dstate))
203 (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
205 (eval-when (:compile-toplevel :load-toplevel :execute)
206 (defparameter trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
207 (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
208 (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))))
211 (defun valid-tcond-encoding (enc)
212 (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
213 (cdr (assoc enc trap-values-alist))
214 (error "Unknown trap condition: ~s" enc)))
216 (sb!disassem:define-arg-type to-field
218 :printer #'(lambda (value stream dstate)
219 (declare (ignore dstate)
222 (princ (or (car (rassoc value trap-values-alist))
226 (defun snarf-error-junk (sap offset &optional length-only)
227 (let* ((length (sb!sys:sap-ref-8 sap offset))
228 (vector (make-array length :element-type '(unsigned-byte 8))))
229 (declare (type sb!sys:system-area-pointer sap)
230 (type (unsigned-byte 8) length)
231 (type (simple-array (unsigned-byte 8) (*)) vector))
233 (values 0 (1+ length) nil nil))
235 (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
236 vector (* n-word-bits
238 (* length n-byte-bits))
239 (collect ((sc-offsets)
241 (lengths 1) ; the length byte
243 (error-number (sb!c:read-var-integer vector index)))
246 (when (>= index length)
248 (let ((old-index index))
249 (sc-offsets (sb!c:read-var-integer vector index))
250 (lengths (- index old-index))))
256 (defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p)
257 (declare (type boolean aa-p lk-p))
258 (let* ((bo (valid-bo-encoding bo))
259 (bi (valid-bi-encoding bi))
260 (aa-bit (if aa-p 1 0))
261 (lk-bit (if lk-p 1 0)))
262 (if aa-p ; Not bloody likely, bwth.
263 (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit)
264 ;; the target may be >32k away, in which case we have to invert the
265 ;; test and do an absolute branch
267 ;; We emit either 4 or 8 bytes, so I think we declare this as
268 ;; preserving 4 byte alignment. If this gives us no joy, we can
269 ;; stick a nop in the long branch and then we will be
270 ;; preserving 8 byte alignment
271 segment 8 2 ; 2^2 is 4 byte alignment. I think
272 #'(lambda (segment posn magic-value)
273 (let ((delta (ash (- (label-position target posn magic-value) posn)
275 (when (typep delta '(signed-byte 14))
276 (emit-back-patch segment 4
277 #'(lambda (segment posn)
280 (ash (- (label-position target) posn) -2)
283 #'(lambda (segment posn)
284 (declare (ignore posn))
285 (let ((bo (logxor 8 bo))) ;; invert the test
286 (emit-b-form-inst segment 16 bo bi
287 2 ; skip over next instruction
289 (emit-back-patch segment 4
290 #'(lambda (segment posn)
291 (declare (ignore posn))
292 (emit-i-form-branch segment target lk-p)))))
297 ; non-absolute I-form: B, BL.
298 (defun emit-i-form-branch (segment target &optional lk-p)
299 (let* ((lk-bit (if lk-p 1 0)))
302 (note-fixup segment :b target)
303 (emit-i-form-inst segment 18 0 0 lk-bit))
305 (emit-back-patch segment 4
306 #'(lambda (segment posn)
310 (ash (- (label-position target) posn) -2)
314 (eval-when (:compile-toplevel :execute :load-toplevel)
315 (defparameter *spr-numbers-alist* '((:xer 1) (:lr 8) (:ctr 9))))
317 (sb!disassem:define-arg-type spr
318 :printer #'(lambda (value stream dstate)
319 (declare (ignore dstate)
320 (type (unsigned-byte 10) value))
321 (let* ((name (car (rassoc value *spr-numbers-alist*))))
324 (princ value stream)))))
326 (eval-when (:compile-toplevel :load-toplevel :execute)
327 (defparameter jump-printer
328 #'(lambda (value stream dstate)
329 (let ((addr (ash value 2)))
330 (sb!disassem:maybe-note-assembler-routine addr t dstate)
331 (write addr :base 16 :radix t :stream stream)))))
335 ;;;; dissassem:define-instruction-formats
337 (eval-when (:compile-toplevel :execute)
338 (defmacro ppc-byte (startbit &optional (endbit startbit))
339 (unless (and (typep startbit '(unsigned-byte 32))
340 (typep endbit '(unsigned-byte 32))
341 (>= endbit startbit))
343 ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit)))
345 (defparameter *ppc-field-specs-alist*
346 `((aa :field ,(ppc-byte 30))
347 (ba :field ,(ppc-byte 11 15) :type 'bi-field)
348 (bb :field ,(ppc-byte 16 20) :type 'bi-field)
349 (bd :field ,(ppc-byte 16 29) :type 'relative-label)
350 (bf :field ,(ppc-byte 6 8) :type 'crf)
351 (bfa :field ,(ppc-byte 11 13) :type 'crf)
352 (bi :field ,(ppc-byte 11 15) :type 'bi-field)
353 (bo :field ,(ppc-byte 6 10) :type 'bo-field)
354 (bt :field ,(ppc-byte 6 10) :type 'bi-field)
355 (d :field ,(ppc-byte 16 31) :sign-extend t)
356 (flm :field ,(ppc-byte 7 14) :sign-extend nil)
357 (fra :field ,(ppc-byte 11 15) :type 'fp-reg)
358 (frb :field ,(ppc-byte 16 20) :type 'fp-reg)
359 (frc :field ,(ppc-byte 21 25) :type 'fp-reg)
360 (frs :field ,(ppc-byte 6 10) :type 'fp-reg)
361 (frt :field ,(ppc-byte 6 10) :type 'fp-reg)
362 (fxm :field ,(ppc-byte 12 19) :sign-extend nil)
363 (l :field ,(ppc-byte 10) :sign-extend nil)
364 (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label)
365 (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer)
366 (lk :field ,(ppc-byte 31))
367 (mb :field ,(ppc-byte 21 25) :sign-extend nil)
368 (me :field ,(ppc-byte 26 30) :sign-extend nil)
369 (nb :field ,(ppc-byte 16 20) :sign-extend nil)
370 (oe :field ,(ppc-byte 21))
371 (ra :field ,(ppc-byte 11 15) :type 'reg)
372 (rb :field ,(ppc-byte 16 20) :type 'reg)
373 (rc :field ,(ppc-byte 31))
374 (rs :field ,(ppc-byte 6 10) :type 'reg)
375 (rt :field ,(ppc-byte 6 10) :type 'reg)
376 (sh :field ,(ppc-byte 16 20) :sign-extend nil)
377 (si :field ,(ppc-byte 16 31) :sign-extend t)
378 (spr :field ,(ppc-byte 11 20) :type 'spr)
379 (to :field ,(ppc-byte 6 10) :type 'to-field)
380 (u :field ,(ppc-byte 16 19) :sign-extend nil)
381 (ui :field ,(ppc-byte 16 31) :sign-extend nil)
382 (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil)
383 (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil)
384 (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil)))
388 (sb!disassem:define-instruction-format (instr 32)
389 (op :field (byte 6 26))
390 (other :field (byte 26 0)))
392 (sb!disassem:define-instruction-format (xinstr 32 :default-printer '(:name :tab data))
393 (op-to-a :field (byte 16 16))
394 (data :field (byte 16 0)))
396 (sb!disassem:define-instruction-format (sc 32 :default-printer '(:name :tab rest))
397 (op :field (byte 6 26))
398 (rest :field (byte 26 0) :value 2))
402 (macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs)
403 (flet ((specname-field (specname)
404 (or (assoc specname *ppc-field-specs-alist*)
405 (error "Unknown ppc instruction field spec ~s" specname))))
406 (labels ((spec-field (spec)
408 (specname-field spec)
410 (cdr (specname-field (cadr spec)))))))
411 (collect ((field (list '(op :field (byte 6 26)))))
413 (field (spec-field spec)))
414 `(sb!disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
417 (def-ppc-iformat (i '(:name :tab li))
420 (def-ppc-iformat (i-abs '(:name :tab li-abs))
423 (def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
426 (def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
429 (def-ppc-iformat (d-si '(:name :tab rt "," ra "," si ))
432 (def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")"))
435 (def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui))
438 (def-ppc-iformat (d-crf-si)
441 (def-ppc-iformat (d-crf-ui)
444 (def-ppc-iformat (d-to '(:name :tab to "," ra "," si))
447 (def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")"))
450 (def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
455 ;;; There are around ... oh, 28 or so ... variants on the "X" format.
456 ;;; Some of them are only used by one instruction; some are used by dozens.
457 ;;; Some aren't used by instructions that we generate ...
459 (def-ppc-iformat (x '(:name :tab rt "," ra "," rb))
460 rt ra rb (xo xo21-30))
462 (def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb))
463 rt ra nb (xo xo21-30))
465 (def-ppc-iformat (x-4 '(:name :tab rt))
468 (def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb))
469 rs ra rb (xo xo21-30) rc)
471 (def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb))
472 rs ra rb (xo xo21-30))
474 (def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb))
475 rs ra nb (xo xo21-30))
477 (def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh))
478 rs ra sh (xo xo21-30) rc)
480 (def-ppc-iformat (x-10 '(:name :tab ra "," rs))
481 rs ra (xo xo21-30) rc)
483 (def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb))
484 bf l ra rb (xo xo21-30))
486 (def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb))
487 bf l fra frb (xo xo21-30))
489 (def-ppc-iformat (x-18 '(:name :tab bf))
492 (def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb))
493 to ra rb (xo xo21-30))
495 (def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb))
496 frt ra rb (xo xo21-30))
498 (def-ppc-iformat (x-21 '(:name :tab frt "," rb))
499 frt rb (xo xo21-30) rc)
501 (def-ppc-iformat (x-22 '(:name :tab frt))
504 (def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb))
505 frs ra rb (xo xo21-30))
507 (def-ppc-iformat (x-24 '(:name :tab bt))
510 (def-ppc-iformat (x-25 '(:name :tab ra "," rb))
513 (def-ppc-iformat (x-26 '(:name :tab rb))
516 (def-ppc-iformat (x-27 '(:name))
522 (def-ppc-iformat (xl '(:name :tab bt "," ba "," bb))
523 bt ba bb (xo xo21-30))
525 (def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi))
526 bo bi (xo xo21-30) lk)
528 (def-ppc-iformat (xl-cr '(:name :tab bf "," bfa))
531 (def-ppc-iformat (xl-xo '(:name))
537 (def-ppc-iformat (xfx)
540 (def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs))
543 (def-ppc-iformat (xfl '(:name :tab flm "," frb))
544 flm frb (xo xo21-30) rc)
549 (def-ppc-iformat (xo '(:name :tab rt "," ra "," rb))
550 rt ra rb oe (xo xo22-30) rc)
552 (def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb))
553 rt ra rb (xo xo22-30) rc)
555 (def-ppc-iformat (xo-a '(:name :tab rt "," ra))
556 rt ra oe (xo xo22-30) rc)
561 (def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc))
562 frt fra frb frc (xo xo26-30) rc)
564 (def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb))
565 frt fra frb (xo xo26-30) rc)
567 (def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc))
568 frt fra frc (xo xo26-30) rc)
570 (def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc))
571 frt frb frc (xo xo26-30) rc)
574 (def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me))
577 (def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me))
583 ;;;; Primitive emitters.
586 (define-bitfield-emitter emit-word 32
589 (define-bitfield-emitter emit-short 16
592 (define-bitfield-emitter emit-i-form-inst 32
593 (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0))
595 (define-bitfield-emitter emit-b-form-inst 32
596 (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0))
598 (define-bitfield-emitter emit-sc-form-inst 32
599 (byte 6 26) (byte 26 0))
601 (define-bitfield-emitter emit-d-form-inst 32
602 (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
604 ; Also used for XL-form. What's the difference ?
605 (define-bitfield-emitter emit-x-form-inst 32
606 (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0))
608 (define-bitfield-emitter emit-xfx-form-inst 32
609 (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0))
611 (define-bitfield-emitter emit-xfl-form-inst 32
612 (byte 6 26) (byte 10 16) (byte 5 11) (byte 10 1) (byte 1 0))
615 (define-bitfield-emitter emit-xo-form-inst 32
616 (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0))
618 (define-bitfield-emitter emit-a-form-inst 32
619 (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0))
624 (defun unimp-control (chunk inst stream dstate)
625 (declare (ignore inst))
626 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
627 (case (xinstr-data chunk dstate)
630 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
633 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
634 (#.object-not-list-trap
635 (nt "Object not list trap"))
637 (nt "Breakpoint trap"))
638 (#.pending-interrupt-trap
639 (nt "Pending interrupt trap"))
642 (#.fun-end-breakpoint-trap
643 (nt "Function end breakpoint trap"))
644 (#.object-not-instance-trap
645 (nt "Object not instance trap"))
648 (eval-when (:compile-toplevel :execute)
650 (defun classify-dependencies (deplist)
651 (collect ((reads) (writes))
652 (dolist (dep deplist)
655 (writes (writes dep))))
656 (values (reads) (writes)))))
658 (macrolet ((define-xo-instruction
659 (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
660 `(define-instruction ,name (segment rt ra rb)
661 (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
662 (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
663 (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
667 (emit-xo-form-inst segment ,op
674 (define-xo-oe-instruction
675 (name op xo rc-p always-reads-xer always-writes-xer cost)
676 `(define-instruction ,name (segment rt ra rb)
677 (:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
678 (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
679 (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))))
683 (emit-xo-form-inst segment ,op
690 (define-4-xo-instructions
691 (base op xo &key always-reads-xer always-writes-xer (cost 1))
693 (define-xo-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
694 (define-xo-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
695 (define-xo-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
696 (define-xo-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
698 (define-2-xo-oe-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
700 (define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost)
701 (define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost)))
703 (define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
704 `(define-instruction ,name (segment rt ra)
705 (:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0))))
706 (:dependencies (reads ra) ,@(if always-reads-xer '((reads :xer)))
707 (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))) )
711 (emit-xo-form-inst segment ,op
719 (define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
721 (define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
722 (define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
723 (define-xo-a-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
724 (define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
726 (define-x-instruction (name op xo &key (cost 2) other-dependencies)
727 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
728 `(define-instruction ,name (segment rt ra rb)
729 (:printer x ((op ,op) (xo ,xo)))
732 (:dependencies (reads ra) (reads rb) (reads :memory) ,@other-reads
733 (writes rt) ,@other-writes)
735 (emit-x-form-inst segment ,op
742 (define-x-20-instruction (name op xo &key (cost 2) other-dependencies)
743 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
744 `(define-instruction ,name (segment frt ra rb)
745 (:printer x-20 ((op ,op) (xo ,xo)))
748 (:dependencies (reads ra) (reads rb) ,@other-reads
749 (writes frt) ,@other-writes)
751 (emit-x-form-inst segment ,op
752 (fp-reg-tn-encoding frt)
758 (define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies)
759 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
760 `(define-instruction ,name (segment ra rs rb)
761 (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
764 (:dependencies (reads rb) (reads rs) ,@other-reads
765 (writes ra) ,@other-writes)
767 (emit-x-form-inst segment ,op
775 (define-x-5-st-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 rs ra rb)
778 (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
781 (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads
782 (writes :memory :partially t) ,@other-writes)
784 (emit-x-form-inst segment ,op
791 (define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies)
792 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
793 `(define-instruction ,name (segment frs ra rb)
794 (:printer x-23 ((op ,op) (xo ,xo)))
797 (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads
798 (writes :memory :partially t) ,@other-writes)
800 (emit-x-form-inst segment ,op
801 (fp-reg-tn-encoding frs)
807 (define-x-10-instruction (name op xo rc-p &key (cost 1) other-dependencies)
808 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
809 `(define-instruction ,name (segment ra rs)
810 (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
813 (:dependencies (reads rs) ,@other-reads
814 (writes ra) ,@other-writes)
816 (emit-x-form-inst segment ,op
823 (define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies)
825 (define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
826 (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
827 :other-dependencies ,other-dependencies)))
829 (define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies)
831 (define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
832 (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
833 :other-dependencies ,other-dependencies)))
836 (define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies)
837 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
838 `(define-instruction ,name (segment frt frb)
839 (:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
842 (:dependencies (reads frb) ,@other-reads
843 (writes frt) ,@other-writes)
845 (emit-x-form-inst segment ,op
846 (fp-reg-tn-encoding frt)
848 (fp-reg-tn-encoding frb)
852 (define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies)
854 (define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
855 (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
856 :other-dependencies ,other-dependencies)))
859 (define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies)
860 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
861 `(define-instruction ,name (segment rt ra si)
862 (:declare (type (or ,@(when fixup '(fixup))
863 (unsigned-byte 16) (signed-byte 16))
865 (:printer d-si ((op ,op)))
868 (:dependencies (reads ra) ,@other-reads
869 (writes rt) ,@other-writes)
871 (when (typep si 'fixup)
873 ((:ha :l) (note-fixup segment ,fixup si)))
875 (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
877 (define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies)
878 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
879 `(define-instruction ,name (segment ra rs ui)
880 (:declare (type (unsigned-byte 16) ui))
881 (:printer d-rs-ui ((op ,op)))
884 (:dependencies (reads rs) ,@other-reads
885 (writes ra) ,@other-writes)
887 (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui)))))
889 (define-d-instruction (name op &key (cost 2) other-dependencies pinned)
890 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
891 `(define-instruction ,name (segment rt ra si)
892 (:declare (type (signed-byte 16) si))
893 (:printer d ((op ,op)))
896 ,@(when pinned '(:pinned))
897 (:dependencies (reads ra) (reads :memory) ,@other-reads
898 (writes rt) ,@other-writes)
900 (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
902 (define-d-frt-instruction (name op &key (cost 3) other-dependencies)
903 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
904 `(define-instruction ,name (segment frt ra si)
905 (:declare (type (signed-byte 16) si))
906 (:printer d-frt ((op ,op)))
909 (:dependencies (reads ra) (reads :memory) ,@other-reads
910 (writes frt) ,@other-writes)
912 (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si)))))
914 (define-d-rs-instruction (name op &key (cost 1) other-dependencies pinned)
915 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
916 `(define-instruction ,name (segment rs ra si)
917 (:declare (type (signed-byte 16) si))
918 (:printer d-rs ((op ,op)))
921 ,@(when pinned '(:pinned))
922 (:dependencies (reads rs) (reads ra) ,@other-reads
923 (writes :memory :partially t) ,@other-writes)
925 (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si)))))
927 (define-d-frs-instruction (name op &key (cost 1) other-dependencies)
928 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
929 `(define-instruction ,name (segment frs ra si)
930 (:declare (type (signed-byte 16) si))
931 (:printer d-frs ((op ,op)))
934 (:dependencies (reads frs) (reads ra) ,@other-reads
935 (writes :memory :partially t) ,@other-writes)
937 (emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si)))))
939 (define-a-instruction (name op xo rc &key (cost 1) other-dependencies)
940 `(define-instruction ,name (segment frt fra frb frc)
941 (:printer a ((op ,op) (xo ,xo) (rc ,rc)))
944 (:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies)
946 (emit-a-form-inst segment
948 (fp-reg-tn-encoding frt)
949 (fp-reg-tn-encoding fra)
950 (fp-reg-tn-encoding frb)
951 (fp-reg-tn-encoding frb)
955 (define-2-a-instructions (name op xo &key (cost 1) other-dependencies)
957 (define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
958 (define-a-instruction ,(symbolicate name ".")
959 ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
961 (define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies)
962 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
963 `(define-instruction ,name (segment frt fra frb)
964 (:printer a-tab ((op ,op) (xo ,xo) (rc ,rc)))
967 (:dependencies (reads fra) (reads frb) ,@other-reads
968 (writes frt) ,@other-writes)
970 (emit-a-form-inst segment
972 (fp-reg-tn-encoding frt)
973 (fp-reg-tn-encoding fra)
974 (fp-reg-tn-encoding frb)
979 (define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies)
981 (define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
982 (define-a-tab-instruction ,(symbolicate name ".")
983 ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
985 (define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies)
986 (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
987 `(define-instruction ,name (segment frt fra frb)
988 (:printer a-tac ((op ,op) (xo ,xo) (rc ,rc)))
991 (:dependencies (reads fra) (reads frb) ,@other-reads
992 (writes frt) ,@other-writes)
994 (emit-a-form-inst segment
996 (fp-reg-tn-encoding frt)
997 (fp-reg-tn-encoding fra)
999 (fp-reg-tn-encoding frb)
1003 (define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies)
1005 (define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
1006 (define-a-tac-instruction ,(symbolicate name ".")
1007 ,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
1009 (define-crbit-instruction (name op xo)
1010 `(define-instruction ,name (segment dbit abit bbit)
1011 (:printer xl ((op ,op ) (xo ,xo)))
1014 (:dependencies (reads :ccr) (writes :ccr))
1015 (:emitter (emit-x-form-inst segment 19
1016 (valid-bi-encoding dbit)
1017 (valid-bi-encoding abit)
1018 (valid-bi-encoding bbit)
1022 ;;; The instructions, in numerical order
1024 (define-instruction unimp (segment data)
1025 (:declare (type (signed-byte 16) data))
1026 (:printer xinstr ((op-to-a #.(logior (ash 3 10) (ash 6 5) 0)))
1027 :default :control #'unimp-control)
1030 (:emitter (emit-d-form-inst segment 3 6 0 data)))
1032 (define-instruction twi (segment tcond ra si)
1033 (:printer d-to ((op 3)))
1036 (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si)))
1038 (define-d-si-instruction mulli 7 :cost 5)
1039 (define-d-si-instruction subfic 8)
1041 (define-instruction cmplwi (segment crf ra &optional (ui nil ui-p))
1042 (:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui))
1043 (:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr))
1047 (setq ui ra ra crf crf :cr0))
1048 (emit-d-form-inst segment
1050 (valid-cr-field-encoding crf)
1051 (reg-tn-encoding ra)
1054 (define-instruction cmpwi (segment crf ra &optional (si nil si-p))
1055 (:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si))
1056 (:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr))
1060 (setq si ra ra crf crf :cr0))
1061 (emit-d-form-inst segment
1063 (valid-cr-field-encoding crf)
1064 (reg-tn-encoding ra)
1067 (define-d-si-instruction addic 12 :other-dependencies ((writes :xer)))
1068 (define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr)))
1070 (define-d-si-instruction addi 14 :fixup :l)
1071 (define-d-si-instruction addis 15 :fixup :ha)
1073 ;; There's no real support here for branch options that decrement
1074 ;; and test the CTR :
1075 ;; (a) the instruction scheduler doesn't know that anything's happening
1077 ;; (b) Lisp may have to assume that the CTR always has a lisp
1078 ;; object/locative in it.
1080 (define-instruction bc (segment bo bi target)
1081 (:declare (type label target))
1082 (:printer b ((op 16) (aa 0) (lk 0)))
1083 (:attributes branch)
1085 (:dependencies (reads :ccr))
1087 (emit-conditional-branch segment bo bi target)))
1089 (define-instruction bcl (segment bo bi target)
1090 (:declare (type label target))
1091 (:printer b ((op 16) (aa 0) (lk 1)))
1092 (:attributes branch)
1094 (:dependencies (reads :ccr))
1096 (emit-conditional-branch segment bo bi target nil t)))
1098 (define-instruction bca (segment bo bi target)
1099 (:declare (type label target))
1100 (:printer b ((op 16) (aa 1) (lk 0)))
1101 (:attributes branch)
1103 (:dependencies (reads :ccr))
1105 (emit-conditional-branch segment bo bi target t)))
1107 (define-instruction bcla (segment bo bi target)
1108 (:declare (type label target))
1109 (:printer b ((op 16) (aa 1) (lk 1)))
1110 (:attributes branch)
1112 (:dependencies (reads :ccr))
1114 (emit-conditional-branch segment bo bi target t t)))
1116 ;;; There may (or may not) be a good reason to use this in preference
1117 ;;; to "b[la] target". I can't think of a -bad- reason ...
1119 (define-instruction bu (segment target)
1120 (:declare (type label target))
1121 (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0))
1123 (:attributes branch)
1126 (emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil)))
1129 (define-instruction bt (segment bi target)
1130 (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-t)) (aa 0) (lk 0))
1131 '(:name :tab bi "," bd))
1132 (:attributes branch)
1135 (emit-conditional-branch segment #.(valid-bo-encoding :bo-t) bi target nil nil)))
1137 (define-instruction bf (segment bi target)
1138 (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-f)) (aa 0) (lk 0))
1139 '(:name :tab bi "," bd))
1140 (:attributes branch)
1143 (emit-conditional-branch segment #.(valid-bo-encoding :bo-f) bi target nil nil)))
1145 (define-instruction b? (segment cr-field-name cr-name &optional (target nil target-p))
1146 (:attributes branch)
1150 (setq target cr-name cr-name cr-field-name cr-field-name :cr0))
1151 (let* ((+cond (position cr-name cr-bit-names))
1152 (-cond (position cr-name cr-bit-inverse-names))
1156 (error "Unknown branch condition ~s" cr-name))))
1157 (cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond)))))
1158 (emit-conditional-branch segment b0 cr-form target))))
1160 (define-instruction sc (segment)
1161 (:printer sc ((op 17)))
1162 (:attributes branch)
1165 (:emitter (emit-sc-form-inst segment 17 2)))
1167 (define-instruction b (segment target)
1168 (:printer i ((op 18) (aa 0) (lk 0)))
1169 (:attributes branch)
1172 (emit-i-form-branch segment target nil)))
1174 (define-instruction ba (segment target)
1175 (:printer i-abs ((op 18) (aa 1) (lk 0)))
1176 (:attributes branch)
1179 (when (typep target 'fixup)
1180 (note-fixup segment :ba target)
1182 (emit-i-form-inst segment 18 (ash target -2) 1 0)))
1185 (define-instruction bl (segment target)
1186 (:printer i ((op 18) (aa 0) (lk 1)))
1187 (:attributes branch)
1190 (emit-i-form-branch segment target t)))
1192 (define-instruction bla (segment target)
1193 (:printer i-abs ((op 18) (aa 1) (lk 1)))
1194 (:attributes branch)
1197 (when (typep target 'fixup)
1198 (note-fixup segment :ba target)
1200 (emit-i-form-inst segment 18 (ash target -2) 1 1)))
1202 (define-instruction blr (segment)
1203 (:printer xl-bo-bi ((op 19) (xo 16) (bo #.(valid-bo-encoding :bo-u))(bi 0) (lk 0)) '(:name))
1204 (:attributes branch)
1206 (:dependencies (reads :ccr) (reads :ctr))
1208 (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0)))
1210 (define-instruction bclr (segment bo bi)
1211 (:printer xl-bo-bi ((op 19) (xo 16)))
1212 (:attributes branch)
1214 (:dependencies (reads :ccr) (reads :lr))
1216 (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0)))
1218 (define-instruction bclrl (segment bo bi)
1219 (:printer xl-bo-bi ((op 19) (xo 16) (lk 1)))
1220 (:attributes branch)
1222 (:dependencies (reads :ccr) (reads :lr))
1224 (emit-x-form-inst segment 19 (valid-bo-encoding bo)
1225 (valid-bi-encoding bi) 0 16 1)))
1227 (define-crbit-instruction crnor 19 33)
1228 (define-crbit-instruction crandc 19 129)
1229 (define-instruction isync (segment)
1230 (:printer xl-xo ((op 19) (xo 150)))
1233 (:emitter (emit-x-form-inst segment 19 0 0 0 150 0)))
1235 (define-crbit-instruction crxor 19 193)
1236 (define-crbit-instruction crnand 19 225)
1237 (define-crbit-instruction crand 19 257)
1238 (define-crbit-instruction creqv 19 289)
1239 (define-crbit-instruction crorc 19 417)
1240 (define-crbit-instruction cror 19 449)
1242 (define-instruction bcctr (segment bo bi)
1243 (:printer xl-bo-bi ((op 19) (xo 528)))
1244 (:attributes branch)
1246 (:dependencies (reads :ccr) (reads :ctr))
1248 (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0)))
1250 (define-instruction bcctrl (segment bo bi)
1251 (:printer xl-bo-bi ((op 19) (xo 528) (lk 1)))
1252 (:attributes branch)
1254 (:dependencies (reads :ccr) (reads :ctr) (writes :lr))
1256 (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1)))
1258 (define-instruction bctr (segment)
1259 (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 0)) '(:name))
1260 (:attributes branch)
1262 (:dependencies (reads :ccr) (reads :ctr))
1264 (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 0)))
1266 (define-instruction bctrl (segment)
1267 (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 1)) '(:name))
1268 (:attributes branch)
1270 (:dependencies (reads :ccr) (reads :ctr))
1272 (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 1)))
1274 (define-instruction rlwimi (segment ra rs sh mb me)
1275 (:printer m-sh ((op 20) (rc 0)))
1276 (:dependencies (reads rs) (writes ra))
1279 (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1281 (define-instruction rlwimi. (segment ra rs sh mb me)
1282 (:printer m-sh ((op 20) (rc 1)))
1283 (:dependencies (reads rs) (writes ra) (writes :ccr))
1286 (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1288 (define-instruction rlwinm (segment ra rs sh mb me)
1289 (:printer m-sh ((op 21) (rc 0)))
1291 (:dependencies (reads rs) (writes ra))
1293 (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1295 (define-instruction rlwinm. (segment ra rs sh mb me)
1296 (:printer m-sh ((op 21) (rc 1)))
1298 (:dependencies (reads rs) (writes ra) (writes :ccr))
1300 (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1302 (define-instruction rlwnm (segment ra rs rb mb me)
1303 (:printer m ((op 23) (rc 0) (rb nil :type 'reg)))
1305 (:dependencies (reads rs) (writes ra) (reads rb))
1307 (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0)))
1309 (define-instruction rlwnm. (segment ra rs rb mb me)
1310 (:printer m ((op 23) (rc 1) (rb nil :type 'reg)))
1312 (:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr))
1314 (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1)))
1317 (define-d-rs-ui-instruction ori 24)
1319 (define-instruction nop (segment)
1320 (:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name))
1324 (emit-d-form-inst segment 24 0 0 0)))
1326 (define-d-rs-ui-instruction oris 25)
1327 (define-d-rs-ui-instruction xori 26)
1328 (define-d-rs-ui-instruction xoris 27)
1329 (define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr)))
1330 (define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr)))
1332 (define-instruction cmpw (segment crf ra &optional (rb nil rb-p))
1333 (:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb))
1335 (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1338 (setq rb ra ra crf crf :cr0))
1339 (emit-x-form-inst segment
1341 (valid-cr-field-encoding crf)
1342 (reg-tn-encoding ra)
1343 (reg-tn-encoding rb)
1347 (define-instruction tw (segment tcond ra rb)
1348 (:printer x-19 ((op 31) (xo 4)))
1349 (:attributes branch)
1352 (:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0)))
1354 (define-4-xo-instructions subfc 31 8 :always-writes-xer t)
1355 (define-4-xo-instructions addc 31 10 :always-writes-xer t)
1356 (define-2-xo-oe-instructions mulhwu 31 11 :cost 5)
1358 (define-instruction mfcr (segment rd)
1359 (:printer x-4 ((op 31) (xo 19)))
1361 (:dependencies (reads :ccr) (writes rd))
1362 (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0)))
1364 (define-x-instruction lwarx 31 20)
1365 (define-x-instruction lwzx 31 23)
1366 (define-2-x-5-instructions slw 31 24)
1367 (define-2-x-10-instructions cntlzw 31 26)
1368 (define-2-x-5-instructions and 31 28)
1370 (define-instruction cmplw (segment crf ra &optional (rb nil rb-p))
1371 (:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb))
1373 (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1376 (setq rb ra ra crf crf :cr0))
1377 (emit-x-form-inst segment
1379 (valid-cr-field-encoding crf)
1380 (reg-tn-encoding ra)
1381 (reg-tn-encoding rb)
1386 (define-4-xo-instructions subf 31 40)
1388 (define-x-instruction lwzux 31 55 :other-dependencies ((writes rt)))
1389 (define-2-x-5-instructions andc 31 60)
1390 (define-2-xo-oe-instructions mulhw 31 75 :cost 5)
1392 (define-x-instruction lbzx 31 87)
1393 (define-4-xo-a-instructions neg 31 104)
1394 (define-x-instruction lbzux 31 119 :other-dependencies ((writes rt)))
1395 (define-2-x-5-instructions nor 31 124)
1396 (define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t)
1398 (define-instruction-macro sube (rt ra rb)
1399 `(inst subfe ,rt ,rb ,ra))
1401 (define-instruction-macro sube. (rt ra rb)
1402 `(inst subfe. ,rt ,rb ,ra))
1404 (define-instruction-macro subeo (rt ra rb)
1405 `(inst subfeo ,rt ,rb ,ra))
1407 (define-instruction-macro subeo. (rt ra rb)
1408 `(inst subfeo ,rt ,rb ,ra))
1410 (define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t)
1412 (define-instruction mtcrf (segment mask rt)
1413 (:printer xfx-fxm ((op 31) (xo 144)))
1415 (:dependencies (reads rt) (writes :ccr))
1416 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0)))
1418 (define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr)))
1419 (define-x-5-st-instruction stwx 31 151 nil)
1420 (define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra)))
1421 (define-4-xo-a-instructions subfze 31 200 :always-reads-xer t :always-writes-xer t)
1422 (define-4-xo-a-instructions addze 31 202 :always-reads-xer t :always-writes-xer t)
1423 (define-x-5-st-instruction stbx 31 215 nil)
1424 (define-4-xo-a-instructions subfme 31 232 :always-reads-xer t :always-writes-xer t)
1425 (define-4-xo-a-instructions addme 31 234 :always-reads-xer t :always-writes-xer t)
1426 (define-4-xo-instructions mullw 31 235 :cost 5)
1427 (define-x-5-st-instruction stbux 31 247 nil :other-dependencies ((writes ra)))
1428 (define-4-xo-instructions add 31 266)
1429 (define-x-instruction lhzx 31 279)
1430 (define-2-x-5-instructions eqv 31 284)
1431 (define-x-instruction lhzux 31 311 :other-dependencies ((writes ra)))
1432 (define-2-x-5-instructions xor 31 316)
1434 (define-instruction mfmq (segment rt)
1435 (:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt))
1437 (:dependencies (reads :xer) (writes rt))
1438 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0)))
1440 (define-instruction mfxer (segment rt)
1441 (:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt))
1443 (:dependencies (reads :xer) (writes rt))
1444 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0)))
1446 (define-instruction mflr (segment rt)
1447 (:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt))
1449 (:dependencies (reads :lr) (writes rt))
1450 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0)))
1452 (define-instruction mfctr (segment rt)
1453 (:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt))
1455 (:dependencies (reads rt) (reads :ctr))
1456 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0)))
1459 (define-x-instruction lhax 31 343)
1460 (define-x-instruction lhaux 31 375 :other-dependencies ((writes ra)))
1461 (define-x-5-st-instruction sthx 31 407 nil)
1462 (define-2-x-5-instructions orc 31 412)
1463 (define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra)))
1465 (define-instruction or (segment ra rs rb)
1466 (:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond
1467 ((rs :same-as rb) 'mr)
1471 (:unless (:same-as rs) "," rb)))
1474 (:dependencies (reads rb) (reads rs) (writes ra))
1476 (emit-x-form-inst segment
1478 (reg-tn-encoding rs)
1479 (reg-tn-encoding ra)
1480 (reg-tn-encoding rb)
1484 (define-instruction or. (segment ra rs rb)
1485 (:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond
1486 ((rs :same-as rb) 'mr.)
1490 (:unless (:same-as rs) "," rb)))
1493 (:dependencies (reads rb) (reads rs) (writes ra) (writes :ccr))
1495 (emit-x-form-inst segment
1497 (reg-tn-encoding rs)
1498 (reg-tn-encoding ra)
1499 (reg-tn-encoding rb)
1503 (define-instruction-macro mr (ra rs)
1504 `(inst or ,ra ,rs ,rs))
1506 (define-instruction-macro mr. (ra rs)
1507 `(inst or. ,ra ,rs ,rs))
1509 (define-4-xo-instructions divwu 31 459 :cost 36)
1511 ; This is a 601-specific instruction class.
1512 (define-4-xo-instructions div 31 331 :cost 36)
1514 ; This is a 601-specific instruction.
1515 (define-instruction mtmq (segment rt)
1516 (:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt))
1518 (:dependencies (reads rt) (writes :xer))
1519 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0)))
1521 (define-instruction mtxer (segment rt)
1522 (:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt))
1524 (:dependencies (reads rt) (writes :xer))
1525 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0)))
1527 (define-instruction mtlr (segment rt)
1528 (:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt))
1530 (:dependencies (reads rt) (writes :lr))
1531 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0)))
1533 (define-instruction mtctr (segment rt)
1534 (:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt))
1536 (:dependencies (reads rt) (writes :ctr))
1537 (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0)))
1540 (define-2-x-5-instructions nand 31 476)
1541 (define-4-xo-instructions divw 31 491 :cost 36)
1542 (define-instruction mcrxr (segment crf)
1543 (:printer x-18 ((op 31) (xo 512)))
1545 (:dependencies (reads :xer) (writes :ccr) (writes :xer))
1546 (:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0)))
1548 (define-instruction lswx (segment rs ra rb)
1549 (:printer x ((op 31) (xo 533) (rc 0)))
1553 (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0)))
1554 (define-x-instruction lwbrx 31 534)
1555 (define-x-20-instruction lfsx 31 535)
1556 (define-2-x-5-instructions srw 31 536)
1557 (define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra)))
1559 (define-instruction lswi (segment rt ra rb)
1560 (:printer x-1 ((op 31) (xo 597) (rc 0)))
1564 (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0)))
1566 (define-instruction sync (segment)
1567 (:printer x-27 ((op 31) (xo 598)))
1570 (:emitter (emit-x-form-inst segment 31 0 0 0 598 0)))
1571 (define-x-20-instruction lfdx 31 599)
1572 (define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra)))
1573 (define-instruction stswx (segment rs ra rb)
1574 (:printer x-5 ((op 31) (xo 661)))
1578 (:emitter (emit-x-form-inst sb!assem:segment 31
1579 (reg-tn-encoding rs)
1580 (reg-tn-encoding ra)
1581 (reg-tn-encoding rb)
1584 (define-x-5-st-instruction stwbrx 31 662 nil)
1585 (define-x-23-st-instruction stfsx 31 663)
1586 (define-x-23-st-instruction stfsux 31 695 :other-dependencies ((writes ra)))
1587 (define-instruction stswi (segment rs ra nb)
1588 (:printer x-8 ((op 31) (xo 725)))
1592 (emit-x-form-inst segment 31
1593 (reg-tn-encoding rs)
1594 (reg-tn-encoding ra)
1599 (define-x-23-st-instruction stfdx 31 727)
1600 (define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra)))
1601 (define-x-instruction lhbrx 31 790)
1602 (define-2-x-5-instructions sraw 31 792)
1604 (define-instruction srawi (segment ra rs rb)
1605 (:printer x-9 ((op 31) (xo 824) (rc 0)))
1608 (:dependencies (reads rs) (writes ra))
1610 (emit-x-form-inst segment 31
1611 (reg-tn-encoding rs)
1612 (reg-tn-encoding ra)
1617 (define-instruction srawi. (segment ra rs rb)
1618 (:printer x-9 ((op 31) (xo 824) (rc 1)))
1621 (:dependencies (reads rs) (writes ra) (writes :ccr))
1623 (emit-x-form-inst segment 31
1624 (reg-tn-encoding rs)
1625 (reg-tn-encoding ra)
1630 (define-instruction eieio (segment)
1631 (:printer x-27 ((op 31) (xo 854)))
1634 (:emitter (emit-x-form-inst segment 31 0 0 0 854 0)))
1636 (define-x-5-st-instruction sthbrx 31 918 nil)
1638 (define-2-x-10-instructions extsb 31 954)
1639 (define-2-x-10-instructions extsh 31 922)
1642 (define-instruction lwz (segment rt ra si)
1643 (:declare (type (or fixup (signed-byte 16)) si))
1644 (:printer d ((op 32)))
1647 (:dependencies (reads ra) (writes rt) (reads :memory))
1649 (when (typep si 'fixup)
1650 (note-fixup segment :l si)
1652 (emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si)))
1654 (define-d-instruction lwzu 33 :other-dependencies ((writes ra)))
1655 (define-d-instruction lbz 34)
1656 (define-d-instruction lbzu 35 :other-dependencies ((writes ra)))
1657 (define-d-rs-instruction stw 36)
1658 (define-d-rs-instruction stwu 37 :other-dependencies ((writes ra)))
1659 (define-d-rs-instruction stb 38)
1660 (define-d-rs-instruction stbu 39 :other-dependencies ((writes ra)))
1661 (define-d-instruction lhz 40)
1662 (define-d-instruction lhzu 41 :other-dependencies ((writes ra)))
1663 (define-d-instruction lha 42)
1664 (define-d-instruction lhau 43 :other-dependencies ((writes ra)))
1665 (define-d-rs-instruction sth 44)
1666 (define-d-rs-instruction sthu 45 :other-dependencies ((writes ra)))
1667 (define-d-instruction lmw 46 :pinned t)
1668 (define-d-rs-instruction stmw 47 :pinned t)
1669 (define-d-frt-instruction lfs 48)
1670 (define-d-frt-instruction lfsu 49 :other-dependencies ((writes ra)))
1671 (define-d-frt-instruction lfd 50)
1672 (define-d-frt-instruction lfdu 51 :other-dependencies ((writes ra)))
1673 (define-d-frs-instruction stfs 52)
1674 (define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra)))
1675 (define-d-frs-instruction stfd 54)
1676 (define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra)))
1678 (define-2-a-tab-instructions fdivs 59 18 :cost 17)
1679 (define-2-a-tab-instructions fsubs 59 20)
1680 (define-2-a-tab-instructions fadds 59 21)
1681 (define-2-a-tac-instructions fmuls 59 25)
1682 (define-2-a-instructions fmsubs 59 28 :cost 4)
1683 (define-2-a-instructions fmadds 59 29 :cost 4)
1684 (define-2-a-instructions fnmsubs 59 30 :cost 4)
1685 (define-2-a-instructions fnmadds 59 31 :cost 4)
1687 (define-instruction fcmpu (segment crfd fra frb)
1688 (:printer x-15 ((op 63) (xo 0)))
1689 (:dependencies (reads fra) (reads frb) (reads :fpscr)
1690 (writes :fpscr) (writes :ccr))
1693 (:emitter (emit-x-form-inst segment
1695 (valid-cr-field-encoding crfd)
1696 (fp-reg-tn-encoding fra)
1697 (fp-reg-tn-encoding frb)
1702 (define-2-x-21-instructions frsp 63 12)
1703 (define-2-x-21-instructions fctiw 63 14)
1704 (define-2-x-21-instructions fctiwz 63 15)
1706 (define-2-a-tab-instructions fdiv 63 18 :cost 31)
1707 (define-2-a-tab-instructions fsub 63 20)
1708 (define-2-a-tab-instructions fadd 63 21)
1709 (define-2-a-tac-instructions fmul 63 25 :cost 5)
1710 (define-2-a-instructions fmsub 63 28 :cost 5)
1711 (define-2-a-instructions fmadd 63 29 :cost 5)
1712 (define-2-a-instructions fnmsub 63 30 :cost 5)
1713 (define-2-a-instructions fnmadd 63 31 :cost 5)
1715 (define-instruction fcmpo (segment crfd fra frb)
1716 (:printer x-15 ((op 63) (xo 32)))
1717 (:dependencies (reads fra) (reads frb) (reads :fpscr)
1718 (writes :fpscr) (writes :ccr))
1721 (:emitter (emit-x-form-inst segment
1723 (valid-cr-field-encoding crfd)
1724 (fp-reg-tn-encoding fra)
1725 (fp-reg-tn-encoding frb)
1729 (define-2-x-21-instructions fneg 63 40)
1731 (define-2-x-21-instructions fmr 63 72)
1732 (define-2-x-21-instructions fnabs 63 136)
1733 (define-2-x-21-instructions fabs 63 264)
1735 (define-instruction mffs (segment frd)
1736 (:printer x-22 ((op 63) (xo 583) (rc 0)))
1738 (:dependencies (reads :fpscr) (writes frd))
1739 (:emitter (emit-x-form-inst segment
1741 (fp-reg-tn-encoding frd)
1747 (define-instruction mffs. (segment frd)
1748 (:printer x-22 ((op 63) (xo 583) (rc 1)))
1750 (:dependencies (reads :fpscr) (writes frd) (writes :ccr))
1751 (:emitter (emit-x-form-inst segment
1753 (fp-reg-tn-encoding frd)
1759 (define-instruction mtfsf (segment mask rb)
1760 (:printer xfl ((op 63) (xo 711) (rc 0)))
1761 (:dependencies (reads rb) (writes :fpscr))
1763 (:emitter (emit-xfl-form-inst segment 63 (ash mask 1) (fp-reg-tn-encoding rb) 711 0)))
1765 (define-instruction mtfsf. (segment mask rb)
1766 (:printer xfl ((op 63) (xo 711) (rc 1)))
1768 (:dependencies (reads rb) (writes :ccr) (writes :fpscr))
1769 (:emitter (emit-xfl-form-inst segment 63 (ash mask 1) (fp-reg-tn-encoding rb) 711 1)))
1774 ;;; Here in the future, macros are our friends.
1776 (define-instruction-macro subis (rt ra simm)
1777 `(inst addis ,rt ,ra (- ,simm)))
1779 (define-instruction-macro sub (rt rb ra)
1780 `(inst subf ,rt ,ra ,rb))
1781 (define-instruction-macro sub. (rt rb ra)
1782 `(inst subf. ,rt ,ra ,rb))
1783 (define-instruction-macro subo (rt rb ra)
1784 `(inst subfo ,rt ,ra ,rb))
1785 (define-instruction-macro subo. (rt rb ra)
1786 `(inst subfo. ,rt ,ra ,rb))
1789 (define-instruction-macro subic (rt ra simm)
1790 `(inst addic ,rt ,ra (- ,simm)))
1793 (define-instruction-macro subic. (rt ra simm)
1794 `(inst addic. ,rt ,ra (- ,simm)))
1798 (define-instruction-macro subc (rt rb ra)
1799 `(inst subfc ,rt ,ra ,rb))
1800 (define-instruction-macro subc. (rt rb ra)
1801 `(inst subfc. ,rt ,ra ,rb))
1802 (define-instruction-macro subco (rt rb ra)
1803 `(inst subfco ,rt ,ra ,rb))
1804 (define-instruction-macro subco. (rt rb ra)
1805 `(inst subfco. ,rt ,ra ,rb))
1807 (define-instruction-macro subi (rt ra simm)
1808 `(inst addi ,rt ,ra (- ,simm)))
1810 (define-instruction-macro li (rt val)
1811 `(inst addi ,rt zero-tn ,val))
1813 (define-instruction-macro lis (rt val)
1814 `(inst addis ,rt zero-tn ,val))
1817 (define-instruction-macro not (ra rs)
1818 `(inst nor ,ra ,rs ,rs))
1820 (define-instruction-macro not. (ra rs)
1821 `(inst nor. ,ra ,rs ,rs))
1824 (!def-vm-support-routine emit-nop (segment)
1825 (emit-word segment #x60000000))
1827 (define-instruction-macro extlwi (ra rs n b)
1828 `(inst rlwinm ,ra ,rs ,b 0 (1- ,n)))
1830 (define-instruction-macro extlwi. (ra rs n b)
1831 `(inst rlwinm. ,ra ,rs ,b 0 (1- ,n)))
1833 (define-instruction-macro srwi (ra rs n)
1834 `(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31))
1836 (define-instruction-macro srwi. (ra rs n)
1837 `(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31))
1839 (define-instruction-macro clrrwi (ra rs n)
1840 `(inst rlwinm ,ra ,rs 0 0 (- 31 ,n)))
1842 (define-instruction-macro clrrwi. (ra rs n)
1843 `(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n)))
1845 (define-instruction-macro inslw (ra rs n b)
1846 `(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1848 (define-instruction-macro inslw. (ra rs n b)
1849 `(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1851 (define-instruction-macro rotlw (ra rs rb)
1852 `(inst rlwnm ,ra ,rs ,rb 0 31))
1854 (define-instruction-macro rotlw. (ra rs rb)
1855 `(inst rlwnm. ,ra ,rs ,rb 0 31))
1857 (define-instruction-macro rotlwi (ra rs n)
1858 `(inst rlwinm ,ra ,rs ,n 0 31))
1860 (define-instruction-macro rotrwi (ra rs n)
1861 `(inst rlwinm ,ra ,rs (- 32 ,n) 0 31))
1863 (define-instruction-macro slwi (ra rs n)
1864 `(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n)))
1866 (define-instruction-macro slwi. (ra rs n)
1867 `(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n))))
1874 ((define-conditional-branches (name bo-name)
1875 (let* ((bo-enc (valid-bo-encoding bo-name)))
1877 (define-instruction-macro ,(symbolicate name "A") (bi target)
1878 ``(inst bca ,,,bo-enc ,,bi ,,target))
1879 (define-instruction-macro ,(symbolicate name "L") (bi target)
1880 ``(inst bcl ,,,bo-enc ,,bi ,,target))
1881 (define-instruction-macro ,(symbolicate name "LA") (bi target)
1882 ``(inst bcla ,,,bo-enc ,,bi ,,target))
1883 (define-instruction-macro ,(symbolicate name "CTR") (bi target)
1884 ``(inst bcctr ,,,bo-enc ,,bi ,,target))
1885 (define-instruction-macro ,(symbolicate name "CTRL") (bi target)
1886 ``(inst bcctrl ,,,bo-enc ,,bi ,,target))
1887 (define-instruction-macro ,(symbolicate name "LR") (bi target)
1888 ``(inst bclr ,,,bo-enc ,,bi ,,target))
1889 (define-instruction-macro ,(symbolicate name "LRL") (bi target)
1890 ``(inst bclrl ,,,bo-enc ,,bi ,,target))))))
1891 (define-conditional-branches bt :bo-t)
1892 (define-conditional-branches bf :bo-f))
1896 ((define-positive-conditional-branches (name cr-bit-name)
1898 (define-instruction-macro ,name (crf &optional (target nil target-p))
1900 (setq target crf crf :cr0))
1901 `(inst bt `(,,crf ,,,cr-bit-name) ,target))
1903 (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1904 ``(inst bta (,,cr-field ,,,cr-bit-name) ,,target))
1905 (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1906 ``(inst btl (,,cr-field ,,,cr-bit-name) ,,target))
1907 (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1908 ``(inst btla (,,cr-field ,,,cr-bit-name) ,,target))
1909 (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1910 ``(inst btctr (,,cr-field ,,,cr-bit-name) ,,target))
1911 (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1912 ``(inst btctrl (,,cr-field ,,,cr-bit-name) ,,target))
1913 (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1914 ``(inst btlr (,,cr-field ,,,cr-bit-name) ,,target))
1915 (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1916 ``(inst btlrl (,,cr-field ,,,cr-bit-name) ,,target))
1919 (define-positive-conditional-branches beq :eq)
1920 (define-positive-conditional-branches blt :lt)
1921 (define-positive-conditional-branches bgt :gt)
1922 (define-positive-conditional-branches bso :so)
1923 (define-positive-conditional-branches bun :so))
1927 ((define-negative-conditional-branches (name cr-bit-name)
1929 (define-instruction-macro ,name (crf &optional (target nil target-p))
1931 (setq target crf crf :cr0))
1932 `(inst bf `(,,crf ,,,cr-bit-name) ,target))
1934 (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1935 ``(inst bfa (,,cr-field ,,,cr-bit-name) ,,target))
1936 (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1937 ``(inst bfl (,,cr-field ,,,cr-bit-name) ,,target))
1938 (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1939 ``(inst bfla (,,cr-field ,,,cr-bit-name) ,,target))
1940 (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1941 ``(inst bfctr (,,cr-field ,,,cr-bit-name) ,,target))
1942 (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1943 ``(inst bfctrl (,,cr-field ,,,cr-bit-name) ,,target))
1944 (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1945 ``(inst bflr (,,cr-field ,,,cr-bit-name) ,,target))
1946 (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1947 ``(inst bflrl (,,cr-field ,,,cr-bit-name) ,,target))
1950 (define-negative-conditional-branches bne :eq)
1951 (define-negative-conditional-branches bnl :lt)
1952 (define-negative-conditional-branches bge :lt)
1953 (define-negative-conditional-branches bng :gt)
1954 (define-negative-conditional-branches ble :gt)
1955 (define-negative-conditional-branches bns :so)
1956 (define-negative-conditional-branches bnu :so))
1960 (define-instruction-macro j (func-tn offset)
1962 (inst addi lip-tn ,func-tn ,offset)
1968 (define-instruction-macro bua (target)
1969 `(inst bca :bo-u 0 ,target))
1971 (define-instruction-macro bul (target)
1972 `(inst bcl :bo-u 0 ,target))
1974 (define-instruction-macro bula (target)
1975 `(inst bcla :bo-u 0 ,target))
1978 (define-instruction-macro blrl ()
1979 `(inst bclrl :bo-u 0))
1989 ;;; Some more macros
1991 (defun %lr (reg value)
1994 (inst li reg value))
1996 (inst ori reg zero-tn value))
1997 ((or (signed-byte 32) (unsigned-byte 32))
1998 (let* ((high-half (ldb (byte 16 16) value))
1999 (low-half (ldb (byte 16 0) value)))
2000 (declare (type (unsigned-byte 16) high-half low-half))
2001 (cond ((and (logbitp 15 low-half) (= high-half #xffff))
2002 (inst li reg (dpb low-half (byte 16 0) -1)))
2003 ((and (not (logbitp 15 low-half)) (zerop high-half))
2004 (inst li reg low-half))
2006 (inst lis reg (if (logbitp 15 high-half)
2007 (dpb high-half (byte 16 0) -1)
2009 (unless (zerop low-half)
2010 (inst ori reg reg low-half))))))
2012 (inst lis reg value)
2013 (inst addi reg reg value))))
2015 (define-instruction-macro lr (reg value)
2020 ;;;; Instructions for dumping data and header objects.
2022 (define-instruction word (segment word)
2023 (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
2027 (emit-word segment word)))
2029 (define-instruction short (segment short)
2030 (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
2034 (emit-short segment short)))
2036 (define-instruction byte (segment byte)
2037 (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
2041 (emit-byte segment byte)))
2043 (define-bitfield-emitter emit-header-object 32
2044 (byte 24 8) (byte 8 0))
2046 (defun emit-header-data (segment type)
2049 #'(lambda (segment posn)
2052 (ash (+ posn (component-header-length))
2053 (- n-widetag-bits word-shift)))))))
2055 (define-instruction simple-fun-header-word (segment)
2059 (emit-header-data segment simple-fun-header-widetag)))
2061 (define-instruction lra-header-word (segment)
2065 (emit-header-data segment return-pc-header-widetag)))
2068 ;;;; Instructions for converting between code objects, functions, and lras.
2069 (defun emit-compute-inst (segment vop dst src label temp calc)
2071 ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
2073 #'(lambda (segment posn delta-if-after)
2074 (let ((delta (funcall calc label posn delta-if-after)))
2075 (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
2076 (emit-back-patch segment 4
2077 #'(lambda (segment posn)
2078 (assemble (segment vop)
2080 (funcall calc label posn 0)))))
2082 #'(lambda (segment posn)
2083 (let ((delta (funcall calc label posn 0)))
2084 (assemble (segment vop)
2085 (inst lis temp (ldb (byte 16 16) delta))
2086 (inst ori temp temp (ldb (byte 16 0) delta))
2087 (inst add dst src temp))))))
2089 ;; this function is misnamed. should be compute-code-from-lip,
2090 ;; if the use in xep-allocate-frame is typical
2091 ;; (someone says code = fn - header - label-offset + other-pointer-tag)
2092 (define-instruction compute-code-from-fn (segment dst src label temp)
2093 (:declare (type tn dst src temp) (type label label))
2094 (:attributes variable-length)
2095 (:dependencies (reads src) (writes dst) (writes temp))
2099 (emit-compute-inst segment vop dst src label temp
2100 #'(lambda (label posn delta-if-after)
2101 (- other-pointer-lowtag
2102 ;;function-pointer-type
2103 (label-position label posn delta-if-after)
2104 (component-header-length))))))
2106 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
2107 (define-instruction compute-code-from-lra (segment dst src label temp)
2108 (:declare (type tn dst src temp) (type label label))
2109 (:attributes variable-length)
2110 (:dependencies (reads src) (writes dst) (writes temp))
2114 (emit-compute-inst segment vop dst src label temp
2115 #'(lambda (label posn delta-if-after)
2116 (- (+ (label-position label posn delta-if-after)
2117 (component-header-length)))))))
2119 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
2120 (define-instruction compute-lra-from-code (segment dst src label temp)
2121 (:declare (type tn dst src temp) (type label label))
2122 (:attributes variable-length)
2123 (:dependencies (reads src) (writes dst) (writes temp))
2127 (emit-compute-inst segment vop dst src label temp
2128 #'(lambda (label posn delta-if-after)
2129 (+ (label-position label posn delta-if-after)
2130 (component-header-length))))))