1 ;;;; the instruction set definition for HPPA
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 ; normally assem-scheduler-p is t, and nil if debugging the assembler
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 (setf *assem-scheduler-p* nil))
17 (setf *assem-max-locations* 68) ; see number-location
20 ;;;; Utility functions.
22 (defun reg-tn-encoding (tn)
23 (declare (type tn tn))
28 (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
31 (defun fp-reg-tn-encoding (tn)
32 (declare (type tn tn))
34 (fp-single-zero (values 0 nil))
35 (single-reg (values (tn-offset tn) nil))
36 (fp-double-zero (values 0 t))
37 (double-reg (values (tn-offset tn) t))))
39 (defconstant-eqx compare-conditions
40 '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
43 (deftype compare-condition ()
44 `(member nil ,@compare-conditions))
46 (defun compare-condition (cond)
47 (declare (type compare-condition cond))
49 (let ((result (or (position cond compare-conditions :test #'eq)
50 (error "Bogus Compare/Subtract condition: ~S" cond))))
51 (values (ldb (byte 3 0) result)
55 (defconstant-eqx add-conditions
56 '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
59 (deftype add-condition ()
60 `(member nil ,@add-conditions))
62 (defun add-condition (cond)
63 (declare (type add-condition cond))
65 (let ((result (or (position cond add-conditions :test #'eq)
66 (error "Bogus Add condition: ~S" cond))))
67 (values (ldb (byte 3 0) result)
71 (defconstant-eqx logical-conditions
72 '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
75 (deftype logical-condition ()
76 `(member nil ,@(remove nil logical-conditions)))
78 (defun logical-condition (cond)
79 (declare (type logical-condition cond))
81 (let ((result (or (position cond logical-conditions :test #'eq)
82 (error "Bogus Logical condition: ~S" cond))))
83 (values (ldb (byte 3 0) result)
87 (defconstant-eqx unit-conditions
88 '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
91 (deftype unit-condition ()
92 `(member nil ,@(remove nil unit-conditions)))
94 (defun unit-condition (cond)
95 (declare (type unit-condition cond))
97 (let ((result (or (position cond unit-conditions :test #'eq)
98 (error "Bogus Unit condition: ~S" cond))))
99 (values (ldb (byte 3 0) result)
103 (defconstant-eqx extract/deposit-conditions
104 '(:never := :< :od :tr :<> :>= :ev)
107 (deftype extract/deposit-condition ()
108 `(member nil ,@extract/deposit-conditions))
110 (defun extract/deposit-condition (cond)
111 (declare (type extract/deposit-condition cond))
113 (or (position cond extract/deposit-conditions :test #'eq)
114 (error "Bogus Extract/Deposit condition: ~S" cond))
118 (defun space-encoding (space)
119 (declare (type (unsigned-byte 3) space))
120 (dpb (ldb (byte 2 0) space)
122 (ldb (byte 1 2) space)))
125 ;;;; Initial disassembler setup.
127 ;;; FIXME-lav: is this still used, if so , why use package prefix
128 ;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
130 (defvar *disassem-use-lisp-reg-names* t)
132 ; In each define-instruction the form (:dependencies ...)
133 ; contains read and write howto that passed as LOC here.
134 ; Example: (:dependencies (reads src) (writes dst) (writes temp))
135 ; src, dst and temp is passed each in loc, and can be a register
136 ; immediate or anything else.
137 ; this routine will return an location-number
138 ; this number must be less than *assem-max-locations*
139 (!def-vm-support-routine location-number (loc)
146 (ecase (sb-name (sc-sb (tn-sc loc)))
148 ;; Can happen if $ZERO or $NULL are passed in.
151 (unless (zerop (tn-offset loc))
157 (defparameter reg-symbols
160 (cond ((null name) nil)
161 (t (make-symbol (concatenate 'string "$" name)))))
164 (sb!disassem:define-arg-type reg
165 :printer (lambda (value stream dstate)
166 (declare (stream stream) (fixnum value))
167 (let ((regname (aref reg-symbols value)))
168 (princ regname stream)
169 (sb!disassem:maybe-note-associated-storage-ref
175 (defparameter float-reg-symbols
177 (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
180 (sb!disassem:define-arg-type fp-reg
181 :printer (lambda (value stream dstate)
182 (declare (stream stream) (fixnum value))
183 (let ((regname (aref float-reg-symbols value)))
184 (princ regname stream)
185 (sb!disassem:maybe-note-associated-storage-ref
191 (sb!disassem:define-arg-type fp-fmt-0c
192 :printer (lambda (value stream dstate)
193 (declare (ignore dstate) (stream stream) (fixnum value))
195 (0 (format stream "~A" '\,SGL))
196 (1 (format stream "~A" '\,DBL))
197 (3 (format stream "~A" '\,QUAD)))))
199 (defun low-sign-extend (x n)
200 (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
202 (logior (ash -1 (1- n)) normal)
205 (defun sign-extend (x n)
206 (if (logbitp (1- n) x)
207 (logior (ash -1 (1- n)) x)
210 (defun assemble-bits (x list)
213 (dolist (e (reverse list))
214 (setf result (logior result (ash (ldb e x) offset)))
215 (incf offset (byte-size e)))
218 (macrolet ((define-imx-decode (name bits)
219 `(sb!disassem:define-arg-type ,name
220 :printer (lambda (value stream dstate)
221 (declare (ignore dstate) (stream stream) (fixnum value))
222 (format stream "~S" (low-sign-extend value ,bits))))))
223 (define-imx-decode im5 5)
224 (define-imx-decode im11 11)
225 (define-imx-decode im14 14))
227 (sb!disassem:define-arg-type im3
228 :printer (lambda (value stream dstate)
229 (declare (ignore dstate) (stream stream) (fixnum value))
230 (format stream "~S" (assemble-bits value `(,(byte 1 0)
233 (sb!disassem:define-arg-type im21
234 :printer (lambda (value stream dstate)
235 (declare (ignore dstate) (stream stream) (fixnum value))
237 (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
238 ,(byte 2 14) ,(byte 5 16)
241 (sb!disassem:define-arg-type cp
242 :printer (lambda (value stream dstate)
243 (declare (ignore dstate) (stream stream) (fixnum value))
244 (format stream "~S" (- 31 value))))
246 (sb!disassem:define-arg-type clen
247 :printer (lambda (value stream dstate)
248 (declare (ignore dstate) (stream stream) (fixnum value))
249 (format stream "~S" (- 32 value))))
251 (sb!disassem:define-arg-type compare-condition
252 :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
253 \,> \,>>= \,>> \,NSV \,EV))
255 (sb!disassem:define-arg-type compare-condition-false
256 :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
257 "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
259 (sb!disassem:define-arg-type add-condition
260 :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
263 (sb!disassem:define-arg-type add-condition-false
264 :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
265 "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
267 (sb!disassem:define-arg-type logical-condition
268 :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
270 (sb!disassem:define-arg-type unit-condition
271 :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
274 (sb!disassem:define-arg-type extract/deposit-condition
275 :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
277 (sb!disassem:define-arg-type extract/deposit-condition-false
278 :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
280 (sb!disassem:define-arg-type nullify
283 (sb!disassem:define-arg-type fcmp-cond
284 :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
285 \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
286 \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
288 (sb!disassem:define-arg-type integer
289 :printer (lambda (value stream dstate)
290 (declare (ignore dstate) (stream stream) (fixnum value))
291 (format stream "~S" value)))
293 (sb!disassem:define-arg-type space
294 :printer #("" |1,| |2,| |3,|))
297 ;;;; Define-instruction-formats for disassembler.
299 (sb!disassem:define-instruction-format
301 (op :field (byte 6 26))
302 (b :field (byte 5 21) :type 'reg)
303 (t/r :field (byte 5 16) :type 'reg)
304 (s :field (byte 2 14) :type 'space)
305 (im14 :field (byte 14 0) :type 'im14))
307 (defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
308 (:cond ((m :constant 1) '\,M)))
311 (defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
312 (:cond ((s :constant 0) '\,MA)
316 (defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
318 (:cond ((m :constant 1) '\,M)))
321 (sb!disassem:define-instruction-format
322 (extended-load/store 32)
323 (op1 :field (byte 6 26) :value 3)
324 (b :field (byte 5 21) :type 'reg)
325 (x/im5/r :field (byte 5 16) :type 'reg)
326 (s :field (byte 2 14) :type 'space)
327 (u :field (byte 1 13))
328 (op2 :field (byte 3 10))
329 (ext4/c :field (byte 4 6))
330 (m :field (byte 1 5))
331 (t/im5 :field (byte 5 0) :type 'reg))
333 (sb!disassem:define-instruction-format
334 (ldil 32 :default-printer '(:name :tab im21 "," t))
335 (op :field (byte 6 26))
336 (t :field (byte 5 21) :type 'reg)
337 (im21 :field (byte 21 0) :type 'im21))
339 (sb!disassem:define-instruction-format
341 (op1 :field (byte 6 26))
342 (t :field (byte 5 21) :type 'reg)
343 (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
345 (lambda (value dstate)
346 (declare (type sb!disassem:disassem-state dstate) (list value))
347 (let ((x (logior (ash (first value) 12) (ash (second value) 1)
350 (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
351 ,(byte 10 2))) 17) 2)
352 (sb!disassem:dstate-cur-addr dstate) 8))))
353 (op2 :field (byte 3 13))
354 (n :field (byte 1 1) :type 'nullify))
356 (sb!disassem:define-instruction-format
358 (op1 :field (byte 6 26))
359 (r2 :field (byte 5 21) :type 'reg)
360 (r1 :field (byte 5 16) :type 'reg)
361 (w :fields `(,(byte 11 2) ,(byte 1 0))
363 (lambda (value dstate)
364 (declare (type sb!disassem:disassem-state dstate) (list value))
365 (let ((x (logior (ash (first value) 1) (second value))))
367 (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
369 (sb!disassem:dstate-cur-addr dstate) 8))))
370 (c :field (byte 3 13))
371 (n :field (byte 1 1) :type 'nullify))
373 (sb!disassem:define-instruction-format
375 (op1 :field (byte 6 26))
376 (t :field (byte 5 21) :type 'reg)
377 (x :field (byte 5 16) :type 'reg)
378 (op2 :field (byte 3 13))
379 (x1 :field (byte 11 2))
380 (n :field (byte 1 1) :type 'nullify)
381 (x2 :field (byte 1 0)))
383 (sb!disassem:define-instruction-format
384 (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
385 (r3 :field (byte 6 26) :value 2)
386 (r2 :field (byte 5 21) :type 'reg)
387 (r1 :field (byte 5 16) :type 'reg)
388 (c :field (byte 3 13))
389 (f :field (byte 1 12))
390 (op :field (byte 7 5))
391 (t :field (byte 5 0) :type 'reg))
393 (sb!disassem:define-instruction-format
394 (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
395 (op :field (byte 6 26))
396 (r :field (byte 5 21) :type 'reg)
397 (t :field (byte 5 16) :type 'reg)
398 (c :field (byte 3 13))
399 (f :field (byte 1 12))
400 (o :field (byte 1 11))
401 (im11 :field (byte 11 0) :type 'im11))
403 (sb!disassem:define-instruction-format
404 (extract/deposit-inst 32)
405 (op1 :field (byte 6 26))
406 (r2 :field (byte 5 21) :type 'reg)
407 (r1 :field (byte 5 16) :type 'reg)
408 (c :field (byte 3 13) :type 'extract/deposit-condition)
409 (op2 :field (byte 3 10))
410 (cp :field (byte 5 5) :type 'cp)
411 (t/clen :field (byte 5 0) :type 'clen))
413 (sb!disassem:define-instruction-format
414 (break 32 :default-printer '(:name :tab im13 "," im5))
415 (op1 :field (byte 6 26) :value 0)
416 (im13 :field (byte 13 13))
417 (q2 :field (byte 8 5) :value 0)
418 (im5 :field (byte 5 0)))
420 (defun snarf-error-junk (sap offset &optional length-only)
421 (let* ((length (sb!sys:sap-ref-8 sap offset))
422 (vector (make-array length :element-type '(unsigned-byte 8))))
423 (declare (type sb!sys:system-area-pointer sap)
424 (type (unsigned-byte 8) length)
425 (type (simple-array (unsigned-byte 8) (*)) vector))
427 (values 0 (1+ length) nil nil))
429 (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
431 (collect ((sc-offsets)
433 (lengths 1) ; the length byte
435 (error-number (sb!c:read-var-integer vector index)))
438 (when (>= index length)
440 (let ((old-index index))
441 (sc-offsets (sb!c:read-var-integer vector index))
442 (lengths (- index old-index))))
448 (defun break-control (chunk inst stream dstate)
449 (declare (ignore inst))
450 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
451 (case (break-im5 chunk dstate)
454 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
457 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
459 (nt "Breakpoint trap"))
460 (#.pending-interrupt-trap
461 (nt "Pending interrupt trap"))
464 (#.fun-end-breakpoint-trap
465 (nt "Function end breakpoint trap"))
466 (#.single-step-around-trap
467 (nt "Single step around trap")))))
469 (sb!disassem:define-instruction-format
471 (op1 :field (byte 6 26) :value 0)
472 (r1 :field (byte 5 21) :type 'reg)
473 (r2 :field (byte 5 16) :type 'reg)
474 (s :field (byte 3 13))
475 (op2 :field (byte 8 5))
476 (r3 :field (byte 5 0) :type 'reg))
478 (sb!disassem:define-instruction-format
480 (op :field (byte 6 26))
481 (b :field (byte 5 21) :type 'reg)
482 (x :field (byte 5 16) :type 'reg)
483 (s :field (byte 2 14) :type 'space)
484 (u :field (byte 1 13))
485 (x1 :field (byte 1 12))
486 (x2 :field (byte 2 10))
487 (x3 :field (byte 1 9))
488 (x4 :field (byte 3 6))
489 (m :field (byte 1 5))
490 (t :field (byte 5 0) :type 'fp-reg))
492 (sb!disassem:define-instruction-format
494 (op1 :field (byte 6 26))
495 (r :field (byte 5 21) :type 'fp-reg)
496 (x1 :field (byte 5 16) :type 'fp-reg)
497 (op2 :field (byte 3 13))
498 (fmt :field (byte 2 11) :type 'fp-fmt-0c)
499 (x2 :field (byte 2 9))
500 (x3 :field (byte 3 6))
501 (x4 :field (byte 1 5))
502 (t :field (byte 5 0) :type 'fp-reg))
504 (sb!disassem:define-instruction-format
506 (op1 :field (byte 6 26))
507 (r :field (byte 5 21) :type 'fp-reg)
508 (x1 :field (byte 4 17) :value 0)
509 (x2 :field (byte 2 15))
510 (df :field (byte 2 13) :type 'fp-fmt-0c)
511 (sf :field (byte 2 11) :type 'fp-fmt-0c)
512 (x3 :field (byte 2 9) :value 1)
513 (x4 :field (byte 3 6) :value 0)
514 (x5 :field (byte 1 5) :value 0)
515 (t :field (byte 5 0) :type 'fp-reg))
519 ;;;; Load and Store stuff.
521 (define-bitfield-emitter emit-load/store 32
528 (defun encode-imm21 (segment value)
529 (declare (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
530 (cond ((fixup-p value)
531 (note-fixup segment :hi value)
532 (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
535 (let ((hi (ldb (byte 21 11) value)))
536 (logior (ash (ldb (byte 5 2) hi) 16)
537 (ash (ldb (byte 2 7) hi) 14)
538 (ash (ldb (byte 2 0) hi) 12)
539 (ash (ldb (byte 11 9) hi) 1)
540 (ldb (byte 1 20) hi))))))
542 (defun encode-imm11 (value)
543 (declare (type (signed-byte 11) value))
544 (dpb (ldb (byte 10 0) value)
546 (ldb (byte 1 10) value)))
548 (defun encode-imm11u (value)
549 (declare (type (or (signed-byte 32) (unsigned-byte 32)) value))
550 (declare (type (unsigned-byte 11) value))
551 (dpb (ldb (byte 11 0) value)
555 (defun encode-imm14 (value)
556 (declare (type (signed-byte 14) value))
557 (dpb (ldb (byte 13 0) value)
559 (ldb (byte 1 13) value)))
561 (defun encode-disp/fixup (segment disp imm-bits)
564 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
566 (note-fixup segment :load11u disp)
567 (note-fixup segment :load disp))
572 (encode-imm14 disp)))))
574 ; LDO can be used in two ways: to load an 14bit-signed value
575 ; or load an 11bit-unsigned value. The latter is used for
576 ; example in an LDIL/LDO pair. The key :unsigned specifies this.
577 (macrolet ((define-load-inst (name opcode &optional imm-bits)
578 `(define-instruction ,name (segment disp base reg &key unsigned)
579 (:declare (type tn reg base)
580 (type (member t nil) unsigned)
581 (type (or fixup (signed-byte 14)) disp))
583 (:printer load/store ((op ,opcode) (s 0))
584 '(:name :tab im14 "(" s b ")," t/r))
585 (:dependencies (reads base) (reads :memory) (writes reg))
587 (emit-load/store segment ,opcode
588 (reg-tn-encoding base) (reg-tn-encoding reg) 0
590 (encode-disp/fixup segment disp t)
591 (encode-disp/fixup segment disp nil))))))
592 (define-store-inst (name opcode &optional imm-bits)
593 `(define-instruction ,name (segment reg disp base)
594 (:declare (type tn reg base)
595 (type (or fixup (signed-byte 14)) disp))
597 (:printer load/store ((op ,opcode) (s 0))
598 '(:name :tab t/r "," im14 "(" s b ")"))
599 (:dependencies (reads base) (reads reg) (writes :memory))
601 (emit-load/store segment ,opcode
602 (reg-tn-encoding base) (reg-tn-encoding reg) 0
603 (encode-disp/fixup segment disp ,imm-bits))))))
604 (define-load-inst ldw #x12)
605 (define-load-inst ldh #x11)
606 (define-load-inst ldb #x10)
607 (define-load-inst ldwm #x13)
608 (define-load-inst ldo #x0D)
609 (define-store-inst stw #x1A)
610 (define-store-inst sth #x19)
611 (define-store-inst stb #x18)
612 (define-store-inst stwm #x1B))
614 (define-bitfield-emitter emit-extended-load/store 32
615 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
616 (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
618 (macrolet ((define-load-indexed-inst (name opcode)
619 `(define-instruction ,name (segment index base reg &key modify scale)
620 (:declare (type tn reg base index)
621 (type (member t nil) modify scale))
623 (:dependencies (reads index) (reads base) (writes reg) (reads :memory))
624 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
626 `(:name ,@cmplt-index-print :tab x/im5/r
629 (emit-extended-load/store
630 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
631 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
632 (reg-tn-encoding reg))))))
633 (define-load-indexed-inst ldwx 2)
634 (define-load-indexed-inst ldhx 1)
635 (define-load-indexed-inst ldbx 0)
636 (define-load-indexed-inst ldcwx 7))
638 (defun short-disp-encoding (segment disp)
639 (declare (type (or fixup (signed-byte 5)) disp))
640 (cond ((fixup-p disp)
641 (note-fixup segment :load-short disp)
642 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
645 (dpb (ldb (byte 4 0) disp)
647 (ldb (byte 1 4) disp)))))
649 (macrolet ((define-load-short-inst (name opcode)
650 `(define-instruction ,name (segment base disp reg &key modify)
651 (:declare (type tn base reg)
652 (type (or fixup (signed-byte 5)) disp)
653 (type (member :before :after nil) modify))
655 (:dependencies (reads base) (writes reg) (reads :memory))
656 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
658 `(:name ,@cmplt-disp-print :tab x/im5/r
665 (:after (values 1 0))
666 (:before (values 1 1)))
667 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
668 (short-disp-encoding segment disp)
670 (reg-tn-encoding reg))))))
671 (define-store-short-inst (name opcode)
672 `(define-instruction ,name (segment reg base disp &key modify)
673 (:declare (type tn reg base)
674 (type (or fixup (signed-byte 5)) disp)
675 (type (member :before :after nil) modify))
677 (:dependencies (reads base) (reads reg) (writes :memory))
678 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
680 `(:name ,@cmplt-disp-print :tab x/im5/r
681 "," t/im5 "(" s b ")"))
687 (:after (values 1 0))
688 (:before (values 1 1)))
689 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
690 (short-disp-encoding segment disp)
692 (reg-tn-encoding reg)))))))
693 (define-load-short-inst ldws 2)
694 (define-load-short-inst ldhs 1)
695 (define-load-short-inst ldbs 0)
696 (define-load-short-inst ldcws 7)
698 (define-store-short-inst stws 10)
699 (define-store-short-inst sths 9)
700 (define-store-short-inst stbs 8))
702 (define-instruction stbys (segment reg base disp where &key modify)
703 (:declare (type tn reg base)
704 (type (signed-byte 5) disp)
705 (type (member :begin :end) where)
706 (type (member t nil) modify))
708 (:dependencies (reads base) (reads reg) (writes :memory))
709 (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
710 `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
712 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
713 (reg-tn-encoding reg) 0
714 (ecase where (:begin 0) (:end 1))
715 4 #xC (if modify 1 0)
716 (short-disp-encoding segment disp))))
719 ;;;; Immediate 21-bit Instructions.
720 ;;; Note the heavy scrambling of the immediate value to instruction memory
722 (define-bitfield-emitter emit-imm21 32
727 (define-instruction ldil (segment value reg)
728 (:declare (type tn reg)
729 (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
731 (:dependencies (writes reg))
732 (:printer ldil ((op #x08)))
734 (emit-imm21 segment #x08 (reg-tn-encoding reg)
735 (encode-imm21 segment value))))
737 ; this one overwrites number stack ?
738 (define-instruction addil (segment value reg)
739 (:declare (type tn reg)
740 (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
742 (:dependencies (writes reg))
743 (:printer ldil ((op #x0A)))
745 (emit-imm21 segment #x0A (reg-tn-encoding reg)
746 (encode-imm21 segment value))))
749 ;;;; Branch instructions.
751 (define-bitfield-emitter emit-branch 32
752 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
753 (byte 11 2) (byte 1 1) (byte 1 0))
755 (defun label-relative-displacement (label posn &optional delta-if-after)
756 (declare (type label label) (type index posn))
757 (ash (- (if delta-if-after
758 (label-position label posn delta-if-after)
759 (label-position label))
762 (defun decompose-branch-disp (segment disp)
763 (declare (type (or fixup (signed-byte 17)) disp))
764 (cond ((fixup-p disp)
765 (note-fixup segment :branch disp)
766 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
769 (values (ldb (byte 5 11) disp)
770 (dpb (ldb (byte 10 0) disp)
772 (ldb (byte 1 10) disp))
773 (ldb (byte 1 16) disp)))))
775 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
776 (declare (type (unsigned-byte 6) opcode)
777 (type (unsigned-byte 5) link)
778 (type (unsigned-byte 1) sub-opcode)
780 (type (member t nil) nullify))
781 (emit-back-patch segment 4
782 (lambda (segment posn)
783 (let ((disp (label-relative-displacement target posn)))
784 (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
787 (decompose-branch-disp segment disp)
788 (emit-branch segment opcode link w1 sub-opcode w2
789 (if nullify 1 0) w))))))
791 (define-instruction b (segment target &key nullify)
792 (:declare (type label target) (type (member t nil) nullify))
795 (emit-relative-branch segment #x3A 0 0 target nullify)))
797 (define-instruction bl (segment target reg &key nullify)
798 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
799 (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
801 (:dependencies (writes reg))
803 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
805 (define-instruction gateway (segment target reg &key nullify)
806 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
807 (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
809 (:dependencies (writes reg))
811 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
813 ;;; BLR is useless because we have no way to generate the offset.
815 (define-instruction bv (segment base &key nullify offset)
816 (:declare (type tn base)
817 (type (member t nil) nullify)
818 (type (or tn null) offset))
820 (:dependencies (reads base))
821 (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
823 (emit-branch segment #x3A (reg-tn-encoding base)
824 (if offset (reg-tn-encoding offset) 0)
825 6 0 (if nullify 1 0) 0)))
827 (define-instruction be (segment disp space base &key nullify)
828 (:declare (type (or fixup (signed-byte 17)) disp)
830 (type (unsigned-byte 3) space)
831 (type (member t nil) nullify))
833 (:dependencies (reads base))
834 (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
835 '(:name n :tab w "(" op2 "," t ")"))
839 (decompose-branch-disp segment disp)
840 (emit-branch segment #x38 (reg-tn-encoding base) w1
841 (space-encoding space) w2 (if nullify 1 0) w))))
843 (define-instruction ble (segment disp space base &key nullify)
844 (:declare (type (or fixup (signed-byte 17)) disp)
846 (type (unsigned-byte 3) space)
847 (type (member t nil) nullify))
849 (:dependencies (reads base))
850 (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
851 '(:name n :tab w "(" op2 "," t ")"))
852 (:dependencies (writes lip-tn))
856 (decompose-branch-disp segment disp)
857 (emit-branch segment #x39 (reg-tn-encoding base) w1
858 (space-encoding space) w2 (if nullify 1 0) w))))
860 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
861 (emit-back-patch segment 4
862 (lambda (segment posn)
863 (let ((disp (label-relative-displacement target posn)))
864 (when (not (<= (- (ash 1 11)) disp (1- (ash 1 11))))
865 (format t "AVER fail: disp = ~s~%" disp)
866 (format t "target = ~s~%" target)
867 (format t "posn = ~s~%" posn)
869 (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
870 (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
871 (ldb (byte 1 10) disp)))
872 (w (ldb (byte 1 11) disp)))
873 (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
875 (defun im5-encoding (value)
876 (declare (type (signed-byte 5) value)
877 #+nil (values (unsigned-byte 5)))
878 (dpb (ldb (byte 4 0) value)
880 (ldb (byte 1 4) value)))
882 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
884 (let* ((conditional (symbolicate cond-kind "-CONDITION"))
885 (false-conditional (symbolicate conditional "-FALSE")))
887 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
888 (:declare (type ,conditional cond)
891 (type (member t nil) nullify))
895 '((:dependencies (reads r1) (reads r2) (writes r2))))
899 '((:dependencies (reads r1) (reads r2)))))
901 ; '((:dependencies (reads r1) (reads r2) (writes r2)))
902 ; '((:dependencies (reads r1) (reads r2))))
903 (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
904 '(:name c n :tab r1 "," r2 "," w))
905 ,@(unless (= r-opcode #x32)
906 `((:printer branch12 ((op1 ,(+ 2 r-opcode))
907 (c nil :type ',false-conditional))
908 '(:name c n :tab r1 "," r2 "," w))))
911 (cond-encoding false)
913 (emit-conditional-branch
914 segment (if false ,(+ r-opcode 2) ,r-opcode)
915 (reg-tn-encoding r2) (reg-tn-encoding r1)
916 cond-encoding target nullify))))
917 (define-instruction ,i-name (segment cond imm reg target &key nullify)
918 (:declare (type ,conditional cond)
919 (type (signed-byte 5) imm)
921 (type (member t nil) nullify))
924 ; '((:dependencies (reads reg) (writes reg)))
925 ; '((:dependencies (reads reg))))
928 '((:dependencies (reads r1) (reads r2) (writes r2))))
932 '((:dependencies (reads r1) (reads r2)))))
933 (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
934 (c nil :type ',conditional))
935 '(:name c n :tab r1 "," r2 "," w))
936 ,@(unless (= r-opcode #x32)
937 `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
938 (c nil :type ',false-conditional))
939 '(:name c n :tab r1 "," r2 "," w))))
942 (cond-encoding false)
944 (emit-conditional-branch
945 segment (if false (+ ,i-opcode 2) ,i-opcode)
946 (reg-tn-encoding reg) (im5-encoding imm)
947 cond-encoding target nullify))))))))
948 (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
949 (define-branch-inst comb #x20 comib #x21 compare :pinned)
950 (define-branch-inst addb #x28 addib #x29 add :write-reg))
952 (define-instruction bb (segment cond reg posn target &key nullify)
953 (:declare (type (member t nil) cond nullify)
955 (type (or (member :variable) (unsigned-byte 5)) posn))
957 (:dependencies (reads reg))
958 (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
959 '('BVB c n :tab r1 "," w))
962 (opcode posn-encoding)
963 (if (eq posn :variable)
966 (emit-conditional-branch segment opcode posn-encoding
967 (reg-tn-encoding reg)
968 (if cond 2 6) target nullify))))
971 ;;;; Computation Instructions
973 (define-bitfield-emitter emit-r3-inst 32
974 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
975 (byte 1 12) (byte 7 5) (byte 5 0))
977 (macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
978 `(define-instruction ,name (segment r1 r2 res &optional cond)
979 (:declare (type tn res r1 r2))
983 '((:dependencies (reads r1) (reads r2) (writes res))))
984 (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
987 ,@(when (eq name 'or)
988 `((:printer r3-inst ((op ,opcode) (r2 0)
989 (c nil :type ',(symbolicate cond-kind
991 `('COPY :tab r1 "," t))))
995 (,(symbolicate cond-kind "-CONDITION") cond)
996 (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
997 cond (if false 1 0) ,opcode
998 (reg-tn-encoding res)))))))
999 (define-r3-inst add add #x30)
1000 (define-r3-inst addl add #x50)
1001 (define-r3-inst addo add #x70)
1002 (define-r3-inst addc add #x38)
1003 (define-r3-inst addco add #x78)
1004 (define-r3-inst sh1add add #x32)
1005 (define-r3-inst sh1addl add #x52)
1006 (define-r3-inst sh1addo add #x72)
1007 (define-r3-inst sh2add add #x34)
1008 (define-r3-inst sh2addl add #x54)
1009 (define-r3-inst sh2addo add #x74)
1010 (define-r3-inst sh3add add #x36)
1011 (define-r3-inst sh3addl add #x56)
1012 (define-r3-inst sh3addo add #x76)
1013 (define-r3-inst sub compare #x20)
1014 (define-r3-inst subo compare #x60)
1015 (define-r3-inst subb compare #x28)
1016 (define-r3-inst subbo compare #x68)
1017 (define-r3-inst subt compare #x26)
1018 (define-r3-inst subto compare #x66)
1019 (define-r3-inst ds compare #x22)
1020 (define-r3-inst comclr compare #x44)
1021 (define-r3-inst or logical #x12 t) ; as a nop it must be pinned
1022 (define-r3-inst xor logical #x14)
1023 (define-r3-inst and logical #x10)
1024 (define-r3-inst andcm logical #x00)
1025 (define-r3-inst uxor unit #x1C)
1026 (define-r3-inst uaddcm unit #x4C)
1027 (define-r3-inst uaddcmt unit #x4E)
1028 (define-r3-inst dcor unit #x5C)
1029 (define-r3-inst idcor unit #x5E))
1031 (define-bitfield-emitter emit-imm-inst 32
1032 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1033 (byte 1 12) (byte 1 11) (byte 11 0))
1035 (macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
1036 `(define-instruction ,name (segment imm src dst &optional cond)
1037 (:declare (type tn dst src)
1038 (type (signed-byte 11) imm))
1040 (:printer imm-inst ((op ,opcode) (o ,subcode)
1042 ',(symbolicate cond-kind "-CONDITION"))))
1043 (:dependencies (reads imm) (reads src) (writes dst))
1045 (multiple-value-bind (cond false)
1046 (,(symbolicate cond-kind "-CONDITION") cond)
1047 (emit-imm-inst segment ,opcode (reg-tn-encoding src)
1048 (reg-tn-encoding dst) cond
1049 (if false 1 0) ,subcode
1050 (encode-imm11 imm)))))))
1051 (define-imm-inst addi add #x2D 0)
1052 (define-imm-inst addio add #x2D 1)
1053 (define-imm-inst addit add #x2C 0)
1054 (define-imm-inst addito add #x2C 1)
1055 (define-imm-inst subi compare #x25 0)
1056 (define-imm-inst subio compare #x25 1)
1057 (define-imm-inst comiclr compare #x24 0))
1059 (define-bitfield-emitter emit-extract/deposit-inst 32
1060 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1061 (byte 3 10) (byte 5 5) (byte 5 0))
1063 (define-instruction shd (segment r1 r2 count res &optional cond)
1064 (:declare (type tn res r1 r2)
1065 (type (or (member :variable) (integer 0 31)) count))
1068 (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
1069 '(:name c :tab r1 "," r2 "," cp "," t/clen))
1070 (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
1071 '('VSHD c :tab r1 "," r2 "," t/clen))
1075 (emit-extract/deposit-inst segment #x34
1076 (reg-tn-encoding r2) (reg-tn-encoding r1)
1077 (extract/deposit-condition cond)
1078 0 0 (reg-tn-encoding res)))
1080 (emit-extract/deposit-inst segment #x34
1081 (reg-tn-encoding r2) (reg-tn-encoding r1)
1082 (extract/deposit-condition cond)
1084 (reg-tn-encoding res))))))
1086 (macrolet ((define-extract-inst (name opcode)
1087 `(define-instruction ,name (segment src posn len res &optional cond)
1088 (:declare (type tn res src)
1089 (type (or (member :variable) (integer 0 31)) posn)
1090 (type (integer 1 32) len))
1092 (:dependencies (reads src) (writes res))
1093 (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
1095 '(:name c :tab r2 "," cp "," t/clen "," r1))
1096 (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
1097 '('V :name c :tab r2 "," t/clen "," r1))
1101 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1102 (reg-tn-encoding res)
1103 (extract/deposit-condition cond)
1104 ,(- opcode 2) 0 (- 32 len)))
1106 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1107 (reg-tn-encoding res)
1108 (extract/deposit-condition cond)
1109 ,opcode posn (- 32 len))))))))
1110 (define-extract-inst extru 6)
1111 (define-extract-inst extrs 7))
1113 (macrolet ((define-deposit-inst (name opcode)
1114 `(define-instruction ,name (segment src posn len res &optional cond)
1115 (:declare (type tn res)
1116 (type (or tn (signed-byte 5)) src)
1117 (type (or (member :variable) (integer 0 31)) posn)
1118 (type (integer 1 32) len))
1120 (:dependencies (reads src) (writes res))
1121 (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1122 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1123 (if (= opcode 0) (cons ''Z base) base)))
1124 (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1125 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1126 (if (= opcode 0) (cons ''Z base) base)))
1127 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1128 (op2 ,(+ 4 opcode)))
1129 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1130 (if (= opcode 0) (cons ''Z base) base)))
1131 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1132 (op2 ,(+ 6 opcode)))
1133 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1134 (if (= opcode 0) (cons ''Z base) base)))
1136 (multiple-value-bind
1137 (opcode src-encoding)
1140 (values ,opcode (reg-tn-encoding src)))
1142 (values ,(+ opcode 4) (im5-encoding src))))
1143 (multiple-value-bind
1144 (opcode posn-encoding)
1149 (values (+ opcode 2) (- 31 posn))))
1150 (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1152 (extract/deposit-condition cond)
1153 opcode posn-encoding (- 32 len))))))))
1155 (define-deposit-inst dep 1)
1156 (define-deposit-inst zdep 0))
1160 ;;;; System Control Instructions.
1162 (define-bitfield-emitter emit-break 32
1163 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1165 (define-instruction break (segment &optional (im5 0) (im13 0))
1166 (:declare (type (unsigned-byte 13) im13)
1167 (type (unsigned-byte 5) im5))
1171 (:printer break () :default :control #'break-control)
1173 (emit-break segment 0 im13 0 im5)))
1175 (define-bitfield-emitter emit-system-inst 32
1176 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1178 (define-instruction ldsid (segment res base &optional (space 0))
1179 (:declare (type tn res base)
1180 (type (integer 0 3) space))
1183 (:printer system-inst ((op2 #x85) (c nil :type 'space)
1184 (s nil :printer #(0 0 1 1 2 2 3 3)))
1185 `(:name :tab "(" s r1 ")," r3))
1187 (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1188 (reg-tn-encoding res))))
1190 (define-instruction mtsp (segment reg space)
1191 (:declare (type tn reg) (type (integer 0 7) space))
1194 (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1196 (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1199 (define-instruction mfsp (segment space reg)
1200 (:declare (type tn reg) (type (integer 0 7) space))
1203 (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1205 (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1206 (reg-tn-encoding reg))))
1208 (deftype control-reg ()
1209 '(or (unsigned-byte 5) (member :sar)))
1211 (defun control-reg (reg)
1212 (declare (type control-reg reg)
1213 #+nil (values (unsigned-byte 32)))
1214 (if (typep reg '(unsigned-byte 5))
1219 (define-instruction mtctl (segment reg ctrl-reg)
1220 (:declare (type tn reg) (type control-reg ctrl-reg))
1223 (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1225 (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1228 (define-instruction mfctl (segment ctrl-reg reg)
1229 (:declare (type tn reg) (type control-reg ctrl-reg))
1232 (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1234 (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1235 (reg-tn-encoding reg))))
1239 ;;;; Floating point instructions.
1241 (define-bitfield-emitter emit-fp-load/store 32
1242 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1243 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1245 (define-instruction fldx (segment index base result &key modify scale side)
1246 (:declare (type tn index base result)
1247 (type (member t nil) modify scale)
1248 (type (member nil 0 1) side))
1251 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1252 `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t))
1253 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1254 `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
1256 (multiple-value-bind
1257 (result-encoding double-p)
1258 (fp-reg-tn-encoding result)
1261 (setf double-p nil))
1262 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1263 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1264 (or side 0) (if modify 1 0) result-encoding))))
1266 (define-instruction fstx (segment value index base &key modify scale side)
1267 (:declare (type tn index base value)
1268 (type (member t nil) modify scale)
1269 (type (member nil 0 1) side))
1272 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1273 `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")"))
1274 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1275 `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
1277 (multiple-value-bind
1278 (value-encoding double-p)
1279 (fp-reg-tn-encoding value)
1282 (setf double-p nil))
1283 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1284 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1285 (or side 0) (if modify 1 0) value-encoding))))
1287 (define-instruction flds (segment disp base result &key modify side)
1288 (:declare (type tn base result)
1289 (type (signed-byte 5) disp)
1290 (type (member :before :after nil) modify)
1291 (type (member nil 0 1) side))
1294 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1295 `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t))
1296 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1297 `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
1299 (multiple-value-bind
1300 (result-encoding double-p)
1301 (fp-reg-tn-encoding result)
1304 (setf double-p nil))
1305 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1306 (short-disp-encoding segment disp) 0
1307 (if (eq modify :before) 1 0) 1 0 0
1308 (or side 0) (if modify 1 0) result-encoding))))
1310 (define-instruction fsts (segment value disp base &key modify side)
1311 (:declare (type tn base value)
1312 (type (signed-byte 5) disp)
1313 (type (member :before :after nil) modify)
1314 (type (member nil 0 1) side))
1317 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1318 `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1319 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1320 `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1322 (multiple-value-bind
1323 (value-encoding double-p)
1324 (fp-reg-tn-encoding value)
1327 (setf double-p nil))
1328 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1329 (short-disp-encoding segment disp) 0
1330 (if (eq modify :before) 1 0) 1 0 1
1331 (or side 0) (if modify 1 0) value-encoding))))
1334 (define-bitfield-emitter emit-fp-class-0-inst 32
1335 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1336 (byte 3 6) (byte 1 5) (byte 5 0))
1338 (define-bitfield-emitter emit-fp-class-1-inst 32
1339 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1340 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1342 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1343 ;;; seperate emitters.
1345 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1351 (define-instruction funop (segment op from to)
1352 (:declare (type funop op)
1356 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1357 '('FCPY fmt :tab r "," t))
1358 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1359 '('FABS fmt :tab r "," t))
1360 (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1361 '('FSQRT fmt :tab r "," t))
1362 (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1363 '('FRND fmt :tab r "," t))
1365 (multiple-value-bind
1366 (from-encoding from-double-p)
1367 (fp-reg-tn-encoding from)
1368 (multiple-value-bind
1369 (to-encoding to-double-p)
1370 (fp-reg-tn-encoding to)
1371 (aver (eq from-double-p to-double-p))
1372 (emit-fp-class-0-inst segment #x0C from-encoding 0
1373 (+ 2 (or (position op funops)
1374 (error "Bogus FUNOP: ~S" op)))
1375 (if to-double-p 1 0) 0 0 0 to-encoding)))))
1377 (macrolet ((define-class-1-fp-inst (name subcode)
1378 `(define-instruction ,name (segment from to)
1379 (:declare (type tn from to))
1381 (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1382 '(:name sf df :tab r "," t))
1384 (multiple-value-bind
1385 (from-encoding from-double-p)
1386 (fp-reg-tn-encoding from)
1387 (multiple-value-bind
1388 (to-encoding to-double-p)
1389 (fp-reg-tn-encoding to)
1390 (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1391 (if to-double-p 1 0) (if from-double-p 1 0)
1392 1 0 0 to-encoding)))))))
1394 (define-class-1-fp-inst fcnvff 0)
1395 (define-class-1-fp-inst fcnvxf 1)
1396 (define-class-1-fp-inst fcnvfx 2)
1397 (define-class-1-fp-inst fcnvfxt 3))
1399 (define-instruction fcmp (segment cond r1 r2)
1400 (:declare (type (unsigned-byte 5) cond)
1404 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1405 '(:name fmt t :tab r "," x1))
1407 (multiple-value-bind
1408 (r1-encoding r1-double-p)
1409 (fp-reg-tn-encoding r1)
1410 (multiple-value-bind
1411 (r2-encoding r2-double-p)
1412 (fp-reg-tn-encoding r2)
1413 (aver (eq r1-double-p r2-double-p))
1414 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1415 (if r1-double-p 1 0) 2 0 0 cond)))))
1417 (define-instruction ftest (segment)
1420 (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1422 (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1424 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1428 `(member ,@fbinops))
1430 (define-instruction fbinop (segment op r1 r2 result)
1431 (:declare (type fbinop op)
1432 (type tn r1 r2 result))
1435 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1436 '('FADD fmt :tab r "," x1 "," t))
1437 (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1438 '('FSUB fmt :tab r "," x1 "," t))
1439 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1440 '('FMPY fmt :tab r "," x1 "," t))
1441 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1442 '('FDIV fmt :tab r "," x1 "," t))
1444 (multiple-value-bind
1445 (r1-encoding r1-double-p)
1446 (fp-reg-tn-encoding r1)
1447 (multiple-value-bind
1448 (r2-encoding r2-double-p)
1449 (fp-reg-tn-encoding r2)
1450 (aver (eq r1-double-p r2-double-p))
1451 (multiple-value-bind
1452 (result-encoding result-double-p)
1453 (fp-reg-tn-encoding result)
1454 (aver (eq r1-double-p result-double-p))
1455 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1456 (or (position op fbinops)
1457 (error "Bogus FBINOP: ~S" op))
1458 (if r1-double-p 1 0) 3 0 0
1459 result-encoding))))))
1463 ;;;; Instructions built out of other insts.
1465 (define-instruction-macro move (src dst &optional cond)
1466 `(inst or ,src zero-tn ,dst ,cond))
1468 (define-instruction-macro nop (&optional cond)
1469 `(inst or zero-tn zero-tn zero-tn ,cond))
1471 (define-instruction li (segment value reg)
1472 (:declare (type tn reg)
1473 (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1475 (:dependencies (reads reg))
1478 (assemble (segment vop)
1481 (inst ldil value reg)
1482 (inst ldo value reg reg :unsigned t))
1484 (inst ldo value zero-tn reg))
1485 ((or (signed-byte 32) (unsigned-byte 32))
1486 (let ((lo (ldb (byte 11 0) value)))
1487 (inst ldil value reg)
1488 (inst ldo lo reg reg :unsigned t)))))))
1490 (define-instruction-macro sll (src count result &optional cond)
1491 (once-only ((result result) (src src) (count count) (cond cond))
1492 `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1494 (define-instruction-macro sra (src count result &optional cond)
1495 (once-only ((result result) (src src) (count count) (cond cond))
1496 `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1498 (define-instruction-macro srl (src count result &optional cond)
1499 (once-only ((result result) (src src) (count count) (cond cond))
1500 `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1502 (defun maybe-negate-cond (cond negate)
1504 (multiple-value-bind
1506 (compare-condition cond)
1508 (nth value compare-conditions)
1509 (nth (+ value 8) compare-conditions)))
1512 (define-instruction bc (segment cond not-p r1 r2 target)
1513 (:declare (type compare-condition cond)
1514 (type (member t nil) not-p)
1516 (type label target))
1518 (:dependencies (reads r1) (reads r2))
1521 (emit-chooser segment 8 2
1522 (lambda (segment posn delta)
1523 (let ((disp (label-relative-displacement target posn delta)))
1524 (when (<= 0 disp (1- (ash 1 11)))
1525 (assemble (segment vop)
1526 (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1529 (lambda (segment posn)
1530 (let ((disp (label-relative-displacement target posn)))
1531 (assemble (segment vop)
1532 (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1533 (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1534 (inst nop)) ; FIXME-lav, cant nullify when backward branch
1536 (inst comclr r1 r2 zero-tn
1537 (maybe-negate-cond cond (not not-p)))
1538 (inst b target :nullify t)))))))))
1540 (define-instruction bci (segment cond not-p imm reg target)
1541 (:declare (type compare-condition cond)
1542 (type (member t nil) not-p)
1543 (type (signed-byte 11) imm)
1545 (type label target))
1547 (:dependencies (reads reg))
1550 (emit-chooser segment 8 2
1551 (lambda (segment posn delta-if-after)
1552 (let ((disp (label-relative-displacement target posn delta-if-after)))
1553 (when (and (<= 0 disp (1- (ash 1 11)))
1554 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1555 (assemble (segment vop)
1556 (inst comib (maybe-negate-cond cond not-p) imm reg target
1559 (lambda (segment posn)
1560 (let ((disp (label-relative-displacement target posn)))
1561 (assemble (segment vop)
1562 (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1563 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1564 (inst comib (maybe-negate-cond cond not-p) imm reg target)
1567 (inst comiclr imm reg zero-tn
1568 (maybe-negate-cond cond (not not-p)))
1569 (inst b target :nullify t)))))))))
1572 ;;;; Instructions to convert between code ptrs, functions, and lras.
1574 (defun emit-header-data (segment type)
1577 (lambda (segment posn)
1580 (ash (+ posn (component-header-length))
1581 (- n-widetag-bits word-shift)))))))
1583 (define-instruction simple-fun-header-word (segment)
1588 (emit-header-data segment simple-fun-header-widetag)))
1590 (define-instruction lra-header-word (segment)
1595 (emit-header-data segment return-pc-header-widetag)))
1598 (defun emit-compute-inst (segment vop src label temp dst calc)
1600 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1602 ;; This is the best-case that emits one instruction ( 4 bytes )
1603 (lambda (segment posn delta-if-after)
1604 (let ((delta (funcall calc label posn delta-if-after)))
1605 ;; WHEN, Why not AVER ?
1606 (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1607 (emit-back-patch segment 4
1608 (lambda (segment posn)
1609 (assemble (segment vop)
1610 (inst addi (funcall calc label posn 0) src
1613 ;; This is the worst-case that emits three instruction ( 12 bytes )
1614 (lambda (segment posn)
1615 (let ((delta (funcall calc label posn 0)))
1616 ;; FIXME-lav: why do we hit below check ?
1617 ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1618 ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
1619 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1620 ;; intermediate value would be tagged but pointing into space.
1621 ;; Does above note mean that the intermediate value would be
1622 ;; a bogus pointer that would be GCed wrongly ?
1623 ;; Also what I can see addil would also overwrite NFP (r1) ???
1624 (assemble (segment vop)
1625 ;; Three instructions (4 * 3) this is the reason for 12 bytes
1626 (inst ldil delta temp)
1627 (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
1628 (inst add src temp dst))))))
1630 (macrolet ((compute ((name) &body body)
1631 `(define-instruction ,name (segment src label temp dst)
1632 (:declare (type tn src dst temp) (type label label))
1633 (:attributes variable-length)
1634 (:dependencies (reads src) (writes dst) (writes temp))
1638 (emit-compute-inst segment vop src label temp dst
1640 (compute (compute-code-from-lip)
1641 (lambda (label posn delta-if-after)
1642 (- other-pointer-lowtag
1643 (label-position label posn delta-if-after)
1644 (component-header-length))))
1645 (compute (compute-code-from-lra)
1646 (lambda (label posn delta-if-after)
1647 (- (+ (label-position label posn delta-if-after)
1648 (component-header-length)))))
1649 (compute (compute-lra-from-code)
1650 (lambda (label posn delta-if-after)
1651 (+ (label-position label posn delta-if-after)
1652 (component-header-length)))))
1654 ;;;; Data instructions.
1655 (define-bitfield-emitter emit-word 32
1658 (macrolet ((data (size type)
1659 `(define-instruction ,size (segment ,size)
1660 (:declare (type ,type ,size))
1665 (,(symbolicate "EMIT-" size) segment ,size)))))
1666 (data byte (or (unsigned-byte 8) (signed-byte 8)))
1667 (data short (or (unsigned-byte 16) (signed-byte 16)))
1668 (data word (or (unsigned-byte 23) (signed-byte 23))))