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))
38 (complex-single-reg (values (tn-offset tn) nil))
39 (complex-double-reg (values (tn-offset tn) t))))
41 (defconstant-eqx compare-conditions
42 '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
45 (deftype compare-condition ()
46 `(member nil ,@compare-conditions))
48 (defun compare-condition (cond)
49 (declare (type compare-condition cond))
51 (let ((result (or (position cond compare-conditions :test #'eq)
52 (error "Bogus Compare/Subtract condition: ~S" cond))))
53 (values (ldb (byte 3 0) result)
57 (defconstant-eqx add-conditions
58 '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev)
61 (deftype add-condition ()
62 `(member nil ,@add-conditions))
64 (defun add-condition (cond)
65 (declare (type add-condition cond))
67 (let ((result (or (position cond add-conditions :test #'eq)
68 (error "Bogus Add condition: ~S" cond))))
69 (values (ldb (byte 3 0) result)
73 (defconstant-eqx logical-conditions
74 '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev)
77 (deftype logical-condition ()
78 `(member nil ,@(remove nil logical-conditions)))
80 (defun logical-condition (cond)
81 (declare (type logical-condition cond))
83 (let ((result (or (position cond logical-conditions :test #'eq)
84 (error "Bogus Logical condition: ~S" cond))))
85 (values (ldb (byte 3 0) result)
89 (defconstant-eqx unit-conditions
90 '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc)
93 (deftype unit-condition ()
94 `(member nil ,@(remove nil unit-conditions)))
96 (defun unit-condition (cond)
97 (declare (type unit-condition cond))
99 (let ((result (or (position cond unit-conditions :test #'eq)
100 (error "Bogus Unit condition: ~S" cond))))
101 (values (ldb (byte 3 0) result)
105 (defconstant-eqx extract/deposit-conditions
106 '(:never := :< :od :tr :<> :>= :ev)
109 (deftype extract/deposit-condition ()
110 `(member nil ,@extract/deposit-conditions))
112 (defun extract/deposit-condition (cond)
113 (declare (type extract/deposit-condition cond))
115 (or (position cond extract/deposit-conditions :test #'eq)
116 (error "Bogus Extract/Deposit condition: ~S" cond))
120 (defun space-encoding (space)
121 (declare (type (unsigned-byte 3) space))
122 (dpb (ldb (byte 2 0) space)
124 (ldb (byte 1 2) space)))
127 ;;;; Initial disassembler setup.
129 ;;; FIXME-lav: is this still used, if so , why use package prefix
130 ;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
132 (defvar *disassem-use-lisp-reg-names* t)
134 ; In each define-instruction the form (:dependencies ...)
135 ; contains read and write howto that passed as LOC here.
136 ; Example: (:dependencies (reads src) (writes dst) (writes temp))
137 ; src, dst and temp is passed each in loc, and can be a register
138 ; immediate or anything else.
139 ; this routine will return an location-number
140 ; this number must be less than *assem-max-locations*
141 (!def-vm-support-routine location-number (loc)
148 (ecase (sb-name (sc-sb (tn-sc loc)))
150 ;; Can happen if $ZERO or $NULL are passed in.
153 (unless (zerop (tn-offset loc))
159 (defparameter reg-symbols
162 (cond ((null name) nil)
163 (t (make-symbol (concatenate 'string "$" name)))))
166 (sb!disassem:define-arg-type reg
167 :printer (lambda (value stream dstate)
168 (declare (stream stream) (fixnum value))
169 (let ((regname (aref reg-symbols value)))
170 (princ regname stream)
171 (sb!disassem:maybe-note-associated-storage-ref
177 (defparameter float-reg-symbols
179 (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
182 (sb!disassem:define-arg-type fp-reg
183 :printer (lambda (value stream dstate)
184 (declare (stream stream) (fixnum value))
185 (let ((regname (aref float-reg-symbols value)))
186 (princ regname stream)
187 (sb!disassem:maybe-note-associated-storage-ref
193 (sb!disassem:define-arg-type fp-fmt-0c
194 :printer (lambda (value stream dstate)
195 (declare (ignore dstate) (stream stream) (fixnum value))
197 (0 (format stream "~A" '\,SGL))
198 (1 (format stream "~A" '\,DBL))
199 (3 (format stream "~A" '\,QUAD)))))
201 (defun low-sign-extend (x n)
202 (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
204 (logior (ash -1 (1- n)) normal)
207 (defun sign-extend (x n)
208 (if (logbitp (1- n) x)
209 (logior (ash -1 (1- n)) x)
212 (defun assemble-bits (x list)
215 (dolist (e (reverse list))
216 (setf result (logior result (ash (ldb e x) offset)))
217 (incf offset (byte-size e)))
220 (macrolet ((define-imx-decode (name bits)
221 `(sb!disassem:define-arg-type ,name
222 :printer (lambda (value stream dstate)
223 (declare (ignore dstate) (stream stream) (fixnum value))
224 (format stream "~S" (low-sign-extend value ,bits))))))
225 (define-imx-decode im5 5)
226 (define-imx-decode im11 11)
227 (define-imx-decode im14 14))
229 (sb!disassem:define-arg-type im3
230 :printer (lambda (value stream dstate)
231 (declare (ignore dstate) (stream stream) (fixnum value))
232 (format stream "~S" (assemble-bits value `(,(byte 1 0)
235 (sb!disassem:define-arg-type im21
236 :printer (lambda (value stream dstate)
237 (declare (ignore dstate) (stream stream) (fixnum value))
239 (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
240 ,(byte 2 14) ,(byte 5 16)
243 (sb!disassem:define-arg-type cp
244 :printer (lambda (value stream dstate)
245 (declare (ignore dstate) (stream stream) (fixnum value))
246 (format stream "~S" (- 31 value))))
248 (sb!disassem:define-arg-type clen
249 :printer (lambda (value stream dstate)
250 (declare (ignore dstate) (stream stream) (fixnum value))
251 (format stream "~S" (- 32 value))))
253 (sb!disassem:define-arg-type compare-condition
254 :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
255 \,> \,>>= \,>> \,NSV \,EV))
257 (sb!disassem:define-arg-type compare-condition-false
258 :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
259 "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
261 (sb!disassem:define-arg-type add-condition
262 :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
265 (sb!disassem:define-arg-type add-condition-false
266 :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
267 "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
269 (sb!disassem:define-arg-type logical-condition
270 :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
272 (sb!disassem:define-arg-type unit-condition
273 :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
276 (sb!disassem:define-arg-type extract/deposit-condition
277 :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
279 (sb!disassem:define-arg-type extract/deposit-condition-false
280 :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
282 (sb!disassem:define-arg-type nullify
285 (sb!disassem:define-arg-type fcmp-cond
286 :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
287 \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
288 \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
290 (sb!disassem:define-arg-type integer
291 :printer (lambda (value stream dstate)
292 (declare (ignore dstate) (stream stream) (fixnum value))
293 (format stream "~S" value)))
295 (sb!disassem:define-arg-type space
296 :printer #("" |1,| |2,| |3,|))
299 ;;;; Define-instruction-formats for disassembler.
301 (sb!disassem:define-instruction-format
303 (op :field (byte 6 26))
304 (b :field (byte 5 21) :type 'reg)
305 (t/r :field (byte 5 16) :type 'reg)
306 (s :field (byte 2 14) :type 'space)
307 (im14 :field (byte 14 0) :type 'im14))
309 (defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
310 (:cond ((m :constant 1) '\,M)))
313 (defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
314 (:cond ((s :constant 0) '\,MA)
318 (defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
320 (:cond ((m :constant 1) '\,M)))
323 (sb!disassem:define-instruction-format
324 (extended-load/store 32)
325 (op1 :field (byte 6 26) :value 3)
326 (b :field (byte 5 21) :type 'reg)
327 (x/im5/r :field (byte 5 16) :type 'reg)
328 (s :field (byte 2 14) :type 'space)
329 (u :field (byte 1 13))
330 (op2 :field (byte 3 10))
331 (ext4/c :field (byte 4 6))
332 (m :field (byte 1 5))
333 (t/im5 :field (byte 5 0) :type 'reg))
335 (sb!disassem:define-instruction-format
336 (ldil 32 :default-printer '(:name :tab im21 "," t))
337 (op :field (byte 6 26))
338 (t :field (byte 5 21) :type 'reg)
339 (im21 :field (byte 21 0) :type 'im21))
341 (sb!disassem:define-instruction-format
343 (op1 :field (byte 6 26))
344 (t :field (byte 5 21) :type 'reg)
345 (w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
347 (lambda (value dstate)
348 (declare (type sb!disassem:disassem-state dstate) (list value))
349 (let ((x (logior (ash (first value) 12) (ash (second value) 1)
352 (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
353 ,(byte 10 2))) 17) 2)
354 (sb!disassem:dstate-cur-addr dstate) 8))))
355 (op2 :field (byte 3 13))
356 (n :field (byte 1 1) :type 'nullify))
358 (sb!disassem:define-instruction-format
360 (op1 :field (byte 6 26))
361 (r2 :field (byte 5 21) :type 'reg)
362 (r1 :field (byte 5 16) :type 'reg)
363 (w :fields `(,(byte 11 2) ,(byte 1 0))
365 (lambda (value dstate)
366 (declare (type sb!disassem:disassem-state dstate) (list value))
367 (let ((x (logior (ash (first value) 1) (second value))))
369 (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
371 (sb!disassem:dstate-cur-addr dstate) 8))))
372 (c :field (byte 3 13))
373 (n :field (byte 1 1) :type 'nullify))
375 (sb!disassem:define-instruction-format
377 (op1 :field (byte 6 26))
378 (t :field (byte 5 21) :type 'reg)
379 (x :field (byte 5 16) :type 'reg)
380 (op2 :field (byte 3 13))
381 (x1 :field (byte 11 2))
382 (n :field (byte 1 1) :type 'nullify)
383 (x2 :field (byte 1 0)))
385 (sb!disassem:define-instruction-format
386 (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
387 (r3 :field (byte 6 26) :value 2)
388 (r2 :field (byte 5 21) :type 'reg)
389 (r1 :field (byte 5 16) :type 'reg)
390 (c :field (byte 3 13))
391 (f :field (byte 1 12))
392 (op :field (byte 7 5))
393 (t :field (byte 5 0) :type 'reg))
395 (sb!disassem:define-instruction-format
396 (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
397 (op :field (byte 6 26))
398 (r :field (byte 5 21) :type 'reg)
399 (t :field (byte 5 16) :type 'reg)
400 (c :field (byte 3 13))
401 (f :field (byte 1 12))
402 (o :field (byte 1 11))
403 (im11 :field (byte 11 0) :type 'im11))
405 (sb!disassem:define-instruction-format
406 (extract/deposit-inst 32)
407 (op1 :field (byte 6 26))
408 (r2 :field (byte 5 21) :type 'reg)
409 (r1 :field (byte 5 16) :type 'reg)
410 (c :field (byte 3 13) :type 'extract/deposit-condition)
411 (op2 :field (byte 3 10))
412 (cp :field (byte 5 5) :type 'cp)
413 (t/clen :field (byte 5 0) :type 'clen))
415 (sb!disassem:define-instruction-format
416 (break 32 :default-printer '(:name :tab im13 "," im5))
417 (op1 :field (byte 6 26) :value 0)
418 (im13 :field (byte 13 13))
419 (q2 :field (byte 8 5) :value 0)
420 (im5 :field (byte 5 0)))
422 (defun snarf-error-junk (sap offset &optional length-only)
423 (let* ((length (sb!sys:sap-ref-8 sap offset))
424 (vector (make-array length :element-type '(unsigned-byte 8))))
425 (declare (type sb!sys:system-area-pointer sap)
426 (type (unsigned-byte 8) length)
427 (type (simple-array (unsigned-byte 8) (*)) vector))
429 (values 0 (1+ length) nil nil))
431 (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
433 (collect ((sc-offsets)
435 (lengths 1) ; the length byte
437 (error-number (sb!c:read-var-integer vector index)))
440 (when (>= index length)
442 (let ((old-index index))
443 (sc-offsets (sb!c:read-var-integer vector index))
444 (lengths (- index old-index))))
450 (defun break-control (chunk inst stream dstate)
451 (declare (ignore inst))
452 (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
453 (case (break-im5 chunk dstate)
456 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
459 (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
461 (nt "Breakpoint trap"))
462 (#.pending-interrupt-trap
463 (nt "Pending interrupt trap"))
466 (#.fun-end-breakpoint-trap
467 (nt "Function end breakpoint trap"))
468 (#.single-step-around-trap
469 (nt "Single step around trap")))))
471 (sb!disassem:define-instruction-format
473 (op1 :field (byte 6 26) :value 0)
474 (r1 :field (byte 5 21) :type 'reg)
475 (r2 :field (byte 5 16) :type 'reg)
476 (s :field (byte 3 13))
477 (op2 :field (byte 8 5))
478 (r3 :field (byte 5 0) :type 'reg))
480 (sb!disassem:define-instruction-format
482 (op :field (byte 6 26))
483 (b :field (byte 5 21) :type 'reg)
484 (x :field (byte 5 16) :type 'reg)
485 (s :field (byte 2 14) :type 'space)
486 (u :field (byte 1 13))
487 (x1 :field (byte 1 12))
488 (x2 :field (byte 2 10))
489 (x3 :field (byte 1 9))
490 (x4 :field (byte 3 6))
491 (m :field (byte 1 5))
492 (t :field (byte 5 0) :type 'fp-reg))
494 (sb!disassem:define-instruction-format
496 (op1 :field (byte 6 26))
497 (r :field (byte 5 21) :type 'fp-reg)
498 (x1 :field (byte 5 16) :type 'fp-reg)
499 (op2 :field (byte 3 13))
500 (fmt :field (byte 2 11) :type 'fp-fmt-0c)
501 (x2 :field (byte 2 9))
502 (x3 :field (byte 3 6))
503 (x4 :field (byte 1 5))
504 (t :field (byte 5 0) :type 'fp-reg))
506 (sb!disassem:define-instruction-format
508 (op1 :field (byte 6 26))
509 (r :field (byte 5 21) :type 'fp-reg)
510 (x1 :field (byte 4 17) :value 0)
511 (x2 :field (byte 2 15))
512 (df :field (byte 2 13) :type 'fp-fmt-0c)
513 (sf :field (byte 2 11) :type 'fp-fmt-0c)
514 (x3 :field (byte 2 9) :value 1)
515 (x4 :field (byte 3 6) :value 0)
516 (x5 :field (byte 1 5) :value 0)
517 (t :field (byte 5 0) :type 'fp-reg))
521 ;;;; Load and Store stuff.
523 (define-bitfield-emitter emit-load/store 32
530 (defun encode-imm21 (segment value)
531 (declare (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
532 (cond ((fixup-p value)
533 (note-fixup segment :hi value)
534 (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
537 (let ((hi (ldb (byte 21 11) value)))
538 (logior (ash (ldb (byte 5 2) hi) 16)
539 (ash (ldb (byte 2 7) hi) 14)
540 (ash (ldb (byte 2 0) hi) 12)
541 (ash (ldb (byte 11 9) hi) 1)
542 (ldb (byte 1 20) hi))))))
544 (defun encode-imm11 (value)
545 (declare (type (signed-byte 11) value))
546 (dpb (ldb (byte 10 0) value)
548 (ldb (byte 1 10) value)))
550 (defun encode-imm11u (value)
551 (declare (type (or (signed-byte 32) (unsigned-byte 32)) value))
552 (declare (type (unsigned-byte 11) value))
553 (dpb (ldb (byte 11 0) value)
557 (defun encode-imm14 (value)
558 (declare (type (signed-byte 14) value))
559 (dpb (ldb (byte 13 0) value)
561 (ldb (byte 1 13) value)))
563 (defun encode-disp/fixup (segment disp imm-bits)
566 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
568 (note-fixup segment :load11u disp)
569 (note-fixup segment :load disp))
574 (encode-imm14 disp)))))
576 ; LDO can be used in two ways: to load an 14bit-signed value
577 ; or load an 11bit-unsigned value. The latter is used for
578 ; example in an LDIL/LDO pair. The key :unsigned specifies this.
579 (macrolet ((define-load-inst (name opcode &optional imm-bits)
580 `(define-instruction ,name (segment disp base reg &key unsigned)
581 (:declare (type tn reg base)
582 (type (member t nil) unsigned)
583 (type (or fixup (signed-byte 14)) disp))
585 (:printer load/store ((op ,opcode) (s 0))
586 '(:name :tab im14 "(" s b ")," t/r))
587 (:dependencies (reads base) (reads :memory) (writes reg))
589 (emit-load/store segment ,opcode
590 (reg-tn-encoding base) (reg-tn-encoding reg) 0
592 (encode-disp/fixup segment disp t)
593 (encode-disp/fixup segment disp nil))))))
594 (define-store-inst (name opcode &optional imm-bits)
595 `(define-instruction ,name (segment reg disp base)
596 (:declare (type tn reg base)
597 (type (or fixup (signed-byte 14)) disp))
599 (:printer load/store ((op ,opcode) (s 0))
600 '(:name :tab t/r "," im14 "(" s b ")"))
601 (:dependencies (reads base) (reads reg) (writes :memory))
603 (emit-load/store segment ,opcode
604 (reg-tn-encoding base) (reg-tn-encoding reg) 0
605 (encode-disp/fixup segment disp ,imm-bits))))))
606 (define-load-inst ldw #x12)
607 (define-load-inst ldh #x11)
608 (define-load-inst ldb #x10)
609 (define-load-inst ldwm #x13)
610 (define-load-inst ldo #x0D)
611 (define-store-inst stw #x1A)
612 (define-store-inst sth #x19)
613 (define-store-inst stb #x18)
614 (define-store-inst stwm #x1B))
616 (define-bitfield-emitter emit-extended-load/store 32
617 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
618 (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
620 (macrolet ((define-load-indexed-inst (name opcode)
621 `(define-instruction ,name (segment index base reg &key modify scale)
622 (:declare (type tn reg base index)
623 (type (member t nil) modify scale))
625 (:dependencies (reads index) (reads base) (writes reg) (reads :memory))
626 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
628 `(:name ,@cmplt-index-print :tab x/im5/r
631 (emit-extended-load/store
632 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
633 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
634 (reg-tn-encoding reg))))))
635 (define-load-indexed-inst ldwx 2)
636 (define-load-indexed-inst ldhx 1)
637 (define-load-indexed-inst ldbx 0)
638 (define-load-indexed-inst ldcwx 7))
640 (defun short-disp-encoding (segment disp)
641 (declare (type (or fixup (signed-byte 5)) disp))
642 (cond ((fixup-p disp)
643 (note-fixup segment :load-short disp)
644 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
647 (dpb (ldb (byte 4 0) disp)
649 (ldb (byte 1 4) disp)))))
651 (macrolet ((define-load-short-inst (name opcode)
652 `(define-instruction ,name (segment base disp reg &key modify)
653 (:declare (type tn base reg)
654 (type (or fixup (signed-byte 5)) disp)
655 (type (member :before :after nil) modify))
657 (:dependencies (reads base) (writes reg) (reads :memory))
658 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
660 `(:name ,@cmplt-disp-print :tab x/im5/r
667 (:after (values 1 0))
668 (:before (values 1 1)))
669 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
670 (short-disp-encoding segment disp)
672 (reg-tn-encoding reg))))))
673 (define-store-short-inst (name opcode)
674 `(define-instruction ,name (segment reg base disp &key modify)
675 (:declare (type tn reg base)
676 (type (or fixup (signed-byte 5)) disp)
677 (type (member :before :after nil) modify))
679 (:dependencies (reads base) (reads reg) (writes :memory))
680 (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
682 `(:name ,@cmplt-disp-print :tab x/im5/r
683 "," t/im5 "(" s b ")"))
689 (:after (values 1 0))
690 (:before (values 1 1)))
691 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
692 (short-disp-encoding segment disp)
694 (reg-tn-encoding reg)))))))
695 (define-load-short-inst ldws 2)
696 (define-load-short-inst ldhs 1)
697 (define-load-short-inst ldbs 0)
698 (define-load-short-inst ldcws 7)
700 (define-store-short-inst stws 10)
701 (define-store-short-inst sths 9)
702 (define-store-short-inst stbs 8))
704 (define-instruction stbys (segment reg base disp where &key modify)
705 (:declare (type tn reg base)
706 (type (signed-byte 5) disp)
707 (type (member :begin :end) where)
708 (type (member t nil) modify))
710 (:dependencies (reads base) (reads reg) (writes :memory))
711 (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
712 `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
714 (emit-extended-load/store segment #x03 (reg-tn-encoding base)
715 (reg-tn-encoding reg) 0
716 (ecase where (:begin 0) (:end 1))
717 4 #xC (if modify 1 0)
718 (short-disp-encoding segment disp))))
721 ;;;; Immediate 21-bit Instructions.
722 ;;; Note the heavy scrambling of the immediate value to instruction memory
724 (define-bitfield-emitter emit-imm21 32
729 (define-instruction ldil (segment value reg)
730 (:declare (type tn reg)
731 (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
733 (:dependencies (writes reg))
734 (:printer ldil ((op #x08)))
736 (emit-imm21 segment #x08 (reg-tn-encoding reg)
737 (encode-imm21 segment value))))
739 ; this one overwrites number stack ?
740 (define-instruction addil (segment value reg)
741 (:declare (type tn reg)
742 (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
744 (:dependencies (writes reg))
745 (:printer ldil ((op #x0A)))
747 (emit-imm21 segment #x0A (reg-tn-encoding reg)
748 (encode-imm21 segment value))))
751 ;;;; Branch instructions.
753 (define-bitfield-emitter emit-branch 32
754 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
755 (byte 11 2) (byte 1 1) (byte 1 0))
757 (defun label-relative-displacement (label posn &optional delta-if-after)
758 (declare (type label label) (type index posn))
759 (ash (- (if delta-if-after
760 (label-position label posn delta-if-after)
761 (label-position label))
764 (defun decompose-branch-disp (segment disp)
765 (declare (type (or fixup (signed-byte 17)) disp))
766 (cond ((fixup-p disp)
767 (note-fixup segment :branch disp)
768 (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
771 (values (ldb (byte 5 11) disp)
772 (dpb (ldb (byte 10 0) disp)
774 (ldb (byte 1 10) disp))
775 (ldb (byte 1 16) disp)))))
777 (defun emit-relative-branch (segment opcode link sub-opcode target nullify)
778 (declare (type (unsigned-byte 6) opcode)
779 (type (unsigned-byte 5) link)
780 (type (unsigned-byte 1) sub-opcode)
782 (type (member t nil) nullify))
783 (emit-back-patch segment 4
784 (lambda (segment posn)
785 (let ((disp (label-relative-displacement target posn)))
786 (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
789 (decompose-branch-disp segment disp)
790 (emit-branch segment opcode link w1 sub-opcode w2
791 (if nullify 1 0) w))))))
793 (define-instruction b (segment target &key nullify)
794 (:declare (type label target) (type (member t nil) nullify))
797 (emit-relative-branch segment #x3A 0 0 target nullify)))
799 (define-instruction bl (segment target reg &key nullify)
800 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
801 (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
803 (:dependencies (writes reg))
805 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
807 (define-instruction gateway (segment target reg &key nullify)
808 (:declare (type tn reg) (type label target) (type (member t nil) nullify))
809 (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
811 (:dependencies (writes reg))
813 (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
815 ;;; BLR is useless because we have no way to generate the offset.
817 (define-instruction bv (segment base &key nullify offset)
818 (:declare (type tn base)
819 (type (member t nil) nullify)
820 (type (or tn null) offset))
822 (:dependencies (reads base))
823 (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
825 (emit-branch segment #x3A (reg-tn-encoding base)
826 (if offset (reg-tn-encoding offset) 0)
827 6 0 (if nullify 1 0) 0)))
829 (define-instruction be (segment disp space base &key nullify)
830 (:declare (type (or fixup (signed-byte 17)) disp)
832 (type (unsigned-byte 3) space)
833 (type (member t nil) nullify))
835 (:dependencies (reads base))
836 (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
837 '(:name n :tab w "(" op2 "," t ")"))
841 (decompose-branch-disp segment disp)
842 (emit-branch segment #x38 (reg-tn-encoding base) w1
843 (space-encoding space) w2 (if nullify 1 0) w))))
845 (define-instruction ble (segment disp space base &key nullify)
846 (:declare (type (or fixup (signed-byte 17)) disp)
848 (type (unsigned-byte 3) space)
849 (type (member t nil) nullify))
851 (:dependencies (reads base))
852 (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
853 '(:name n :tab w "(" op2 "," t ")"))
854 (:dependencies (writes lip-tn))
858 (decompose-branch-disp segment disp)
859 (emit-branch segment #x39 (reg-tn-encoding base) w1
860 (space-encoding space) w2 (if nullify 1 0) w))))
862 (defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
863 (emit-back-patch segment 4
864 (lambda (segment posn)
865 (let ((disp (label-relative-displacement target posn)))
866 (when (not (<= (- (ash 1 11)) disp (1- (ash 1 11))))
867 (format t "AVER fail: disp = ~s~%" disp)
868 (format t "target = ~s~%" target)
869 (format t "posn = ~s~%" posn)
871 (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
872 (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
873 (ldb (byte 1 10) disp)))
874 (w (ldb (byte 1 11) disp)))
875 (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
877 (defun im5-encoding (value)
878 (declare (type (signed-byte 5) value)
879 #+nil (values (unsigned-byte 5)))
880 (dpb (ldb (byte 4 0) value)
882 (ldb (byte 1 4) value)))
884 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
886 (let* ((conditional (symbolicate cond-kind "-CONDITION"))
887 (false-conditional (symbolicate conditional "-FALSE")))
889 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
890 (:declare (type ,conditional cond)
893 (type (member t nil) nullify))
897 '((:dependencies (reads r1) (reads r2) (writes r2))))
901 '((:dependencies (reads r1) (reads r2)))))
903 ; '((:dependencies (reads r1) (reads r2) (writes r2)))
904 ; '((:dependencies (reads r1) (reads r2))))
905 (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
906 '(:name c n :tab r1 "," r2 "," w))
907 ,@(unless (= r-opcode #x32)
908 `((:printer branch12 ((op1 ,(+ 2 r-opcode))
909 (c nil :type ',false-conditional))
910 '(:name c n :tab r1 "," r2 "," w))))
913 (cond-encoding false)
915 (emit-conditional-branch
916 segment (if false ,(+ r-opcode 2) ,r-opcode)
917 (reg-tn-encoding r2) (reg-tn-encoding r1)
918 cond-encoding target nullify))))
919 (define-instruction ,i-name (segment cond imm reg target &key nullify)
920 (:declare (type ,conditional cond)
921 (type (signed-byte 5) imm)
923 (type (member t nil) nullify))
926 ; '((:dependencies (reads reg) (writes reg)))
927 ; '((:dependencies (reads reg))))
930 '((:dependencies (reads r1) (reads r2) (writes r2))))
934 '((:dependencies (reads r1) (reads r2)))))
935 (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
936 (c nil :type ',conditional))
937 '(:name c n :tab r1 "," r2 "," w))
938 ,@(unless (= r-opcode #x32)
939 `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
940 (c nil :type ',false-conditional))
941 '(:name c n :tab r1 "," r2 "," w))))
944 (cond-encoding false)
946 (emit-conditional-branch
947 segment (if false (+ ,i-opcode 2) ,i-opcode)
948 (reg-tn-encoding reg) (im5-encoding imm)
949 cond-encoding target nullify))))))))
950 (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
951 (define-branch-inst comb #x20 comib #x21 compare :pinned)
952 (define-branch-inst addb #x28 addib #x29 add :write-reg))
954 (define-instruction bb (segment cond reg posn target &key nullify)
955 (:declare (type (member t nil) cond nullify)
957 (type (or (member :variable) (unsigned-byte 5)) posn))
959 (:dependencies (reads reg))
960 (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
961 '('BVB c n :tab r1 "," w))
964 (opcode posn-encoding)
965 (if (eq posn :variable)
968 (emit-conditional-branch segment opcode posn-encoding
969 (reg-tn-encoding reg)
970 (if cond 2 6) target nullify))))
973 ;;;; Computation Instructions
975 (define-bitfield-emitter emit-r3-inst 32
976 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
977 (byte 1 12) (byte 7 5) (byte 5 0))
979 (macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
980 `(define-instruction ,name (segment r1 r2 res &optional cond)
981 (:declare (type tn res r1 r2))
985 '((:dependencies (reads r1) (reads r2) (writes res))))
986 (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
989 ,@(when (eq name 'or)
990 `((:printer r3-inst ((op ,opcode) (r2 0)
991 (c nil :type ',(symbolicate cond-kind
993 `('COPY :tab r1 "," t))))
997 (,(symbolicate cond-kind "-CONDITION") cond)
998 (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
999 cond (if false 1 0) ,opcode
1000 (reg-tn-encoding res)))))))
1001 (define-r3-inst add add #x30)
1002 (define-r3-inst addl add #x50)
1003 (define-r3-inst addo add #x70)
1004 (define-r3-inst addc add #x38)
1005 (define-r3-inst addco add #x78)
1006 (define-r3-inst sh1add add #x32)
1007 (define-r3-inst sh1addl add #x52)
1008 (define-r3-inst sh1addo add #x72)
1009 (define-r3-inst sh2add add #x34)
1010 (define-r3-inst sh2addl add #x54)
1011 (define-r3-inst sh2addo add #x74)
1012 (define-r3-inst sh3add add #x36)
1013 (define-r3-inst sh3addl add #x56)
1014 (define-r3-inst sh3addo add #x76)
1015 (define-r3-inst sub compare #x20)
1016 (define-r3-inst subo compare #x60)
1017 (define-r3-inst subb compare #x28)
1018 (define-r3-inst subbo compare #x68)
1019 (define-r3-inst subt compare #x26)
1020 (define-r3-inst subto compare #x66)
1021 (define-r3-inst ds compare #x22)
1022 (define-r3-inst comclr compare #x44)
1023 (define-r3-inst or logical #x12 t) ; as a nop it must be pinned
1024 (define-r3-inst xor logical #x14)
1025 (define-r3-inst and logical #x10)
1026 (define-r3-inst andcm logical #x00)
1027 (define-r3-inst uxor unit #x1C)
1028 (define-r3-inst uaddcm unit #x4C)
1029 (define-r3-inst uaddcmt unit #x4E)
1030 (define-r3-inst dcor unit #x5C)
1031 (define-r3-inst idcor unit #x5E))
1033 (define-bitfield-emitter emit-imm-inst 32
1034 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1035 (byte 1 12) (byte 1 11) (byte 11 0))
1037 (macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
1038 `(define-instruction ,name (segment imm src dst &optional cond)
1039 (:declare (type tn dst src)
1040 (type (signed-byte 11) imm))
1042 (:printer imm-inst ((op ,opcode) (o ,subcode)
1044 ',(symbolicate cond-kind "-CONDITION"))))
1045 (:dependencies (reads imm) (reads src) (writes dst))
1047 (multiple-value-bind (cond false)
1048 (,(symbolicate cond-kind "-CONDITION") cond)
1049 (emit-imm-inst segment ,opcode (reg-tn-encoding src)
1050 (reg-tn-encoding dst) cond
1051 (if false 1 0) ,subcode
1052 (encode-imm11 imm)))))))
1053 (define-imm-inst addi add #x2D 0)
1054 (define-imm-inst addio add #x2D 1)
1055 (define-imm-inst addit add #x2C 0)
1056 (define-imm-inst addito add #x2C 1)
1057 (define-imm-inst subi compare #x25 0)
1058 (define-imm-inst subio compare #x25 1)
1059 (define-imm-inst comiclr compare #x24 0))
1061 (define-bitfield-emitter emit-extract/deposit-inst 32
1062 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1063 (byte 3 10) (byte 5 5) (byte 5 0))
1065 (define-instruction shd (segment r1 r2 count res &optional cond)
1066 (:declare (type tn res r1 r2)
1067 (type (or (member :variable) (integer 0 31)) count))
1070 (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
1071 '(:name c :tab r1 "," r2 "," cp "," t/clen))
1072 (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
1073 '('VSHD c :tab r1 "," r2 "," t/clen))
1077 (emit-extract/deposit-inst segment #x34
1078 (reg-tn-encoding r2) (reg-tn-encoding r1)
1079 (extract/deposit-condition cond)
1080 0 0 (reg-tn-encoding res)))
1082 (emit-extract/deposit-inst segment #x34
1083 (reg-tn-encoding r2) (reg-tn-encoding r1)
1084 (extract/deposit-condition cond)
1086 (reg-tn-encoding res))))))
1088 (macrolet ((define-extract-inst (name opcode)
1089 `(define-instruction ,name (segment src posn len res &optional cond)
1090 (:declare (type tn res src)
1091 (type (or (member :variable) (integer 0 31)) posn)
1092 (type (integer 1 32) len))
1094 (:dependencies (reads src) (writes res))
1095 (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
1097 '(:name c :tab r2 "," cp "," t/clen "," r1))
1098 (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
1099 '('V :name c :tab r2 "," t/clen "," r1))
1103 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1104 (reg-tn-encoding res)
1105 (extract/deposit-condition cond)
1106 ,(- opcode 2) 0 (- 32 len)))
1108 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1109 (reg-tn-encoding res)
1110 (extract/deposit-condition cond)
1111 ,opcode posn (- 32 len))))))))
1112 (define-extract-inst extru 6)
1113 (define-extract-inst extrs 7))
1115 (macrolet ((define-deposit-inst (name opcode)
1116 `(define-instruction ,name (segment src posn len res &optional cond)
1117 (:declare (type tn res)
1118 (type (or tn (signed-byte 5)) src)
1119 (type (or (member :variable) (integer 0 31)) posn)
1120 (type (integer 1 32) len))
1122 (:dependencies (reads src) (writes res))
1123 (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1124 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1125 (if (= opcode 0) (cons ''Z base) base)))
1126 (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1127 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1128 (if (= opcode 0) (cons ''Z base) base)))
1129 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1130 (op2 ,(+ 4 opcode)))
1131 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1132 (if (= opcode 0) (cons ''Z base) base)))
1133 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1134 (op2 ,(+ 6 opcode)))
1135 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1136 (if (= opcode 0) (cons ''Z base) base)))
1138 (multiple-value-bind
1139 (opcode src-encoding)
1142 (values ,opcode (reg-tn-encoding src)))
1144 (values ,(+ opcode 4) (im5-encoding src))))
1145 (multiple-value-bind
1146 (opcode posn-encoding)
1151 (values (+ opcode 2) (- 31 posn))))
1152 (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1154 (extract/deposit-condition cond)
1155 opcode posn-encoding (- 32 len))))))))
1157 (define-deposit-inst dep 1)
1158 (define-deposit-inst zdep 0))
1162 ;;;; System Control Instructions.
1164 (define-bitfield-emitter emit-break 32
1165 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1167 (define-instruction break (segment &optional (im5 0) (im13 0))
1168 (:declare (type (unsigned-byte 13) im13)
1169 (type (unsigned-byte 5) im5))
1173 (:printer break () :default :control #'break-control)
1175 (emit-break segment 0 im13 0 im5)))
1177 (define-bitfield-emitter emit-system-inst 32
1178 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1180 (define-instruction ldsid (segment res base &optional (space 0))
1181 (:declare (type tn res base)
1182 (type (integer 0 3) space))
1185 (:printer system-inst ((op2 #x85) (c nil :type 'space)
1186 (s nil :printer #(0 0 1 1 2 2 3 3)))
1187 `(:name :tab "(" s r1 ")," r3))
1189 (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1190 (reg-tn-encoding res))))
1192 (define-instruction mtsp (segment reg space)
1193 (:declare (type tn reg) (type (integer 0 7) space))
1196 (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1198 (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1201 (define-instruction mfsp (segment space reg)
1202 (:declare (type tn reg) (type (integer 0 7) space))
1205 (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1207 (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1208 (reg-tn-encoding reg))))
1210 (deftype control-reg ()
1211 '(or (unsigned-byte 5) (member :sar)))
1213 (defun control-reg (reg)
1214 (declare (type control-reg reg)
1215 #+nil (values (unsigned-byte 32)))
1216 (if (typep reg '(unsigned-byte 5))
1221 (define-instruction mtctl (segment reg ctrl-reg)
1222 (:declare (type tn reg) (type control-reg ctrl-reg))
1225 (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1227 (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1230 (define-instruction mfctl (segment ctrl-reg reg)
1231 (:declare (type tn reg) (type control-reg ctrl-reg))
1234 (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1236 (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1237 (reg-tn-encoding reg))))
1241 ;;;; Floating point instructions.
1243 (define-bitfield-emitter emit-fp-load/store 32
1244 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1245 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1247 (define-instruction fldx (segment index base result &key modify scale side)
1248 (:declare (type tn index base result)
1249 (type (member t nil) modify scale)
1250 (type (member nil 0 1) side))
1253 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1254 `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t))
1255 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1256 `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
1258 (multiple-value-bind
1259 (result-encoding double-p)
1260 (fp-reg-tn-encoding result)
1263 (setf double-p nil))
1264 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1265 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1266 (or side 0) (if modify 1 0) result-encoding))))
1268 (define-instruction fstx (segment value index base &key modify scale side)
1269 (:declare (type tn index base value)
1270 (type (member t nil) modify scale)
1271 (type (member nil 0 1) side))
1274 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1275 `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")"))
1276 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1277 `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
1279 (multiple-value-bind
1280 (value-encoding double-p)
1281 (fp-reg-tn-encoding value)
1284 (setf double-p nil))
1285 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1286 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1287 (or side 0) (if modify 1 0) value-encoding))))
1289 (define-instruction flds (segment disp base result &key modify side)
1290 (:declare (type tn base result)
1291 (type (signed-byte 5) disp)
1292 (type (member :before :after nil) modify)
1293 (type (member nil 0 1) side))
1296 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1297 `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t))
1298 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1299 `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
1301 (multiple-value-bind
1302 (result-encoding double-p)
1303 (fp-reg-tn-encoding result)
1306 (setf double-p nil))
1307 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1308 (short-disp-encoding segment disp) 0
1309 (if (eq modify :before) 1 0) 1 0 0
1310 (or side 0) (if modify 1 0) result-encoding))))
1312 (define-instruction fsts (segment value disp base &key modify side)
1313 (:declare (type tn base value)
1314 (type (signed-byte 5) disp)
1315 (type (member :before :after nil) modify)
1316 (type (member nil 0 1) side))
1319 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1320 `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1321 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1322 `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1324 (multiple-value-bind
1325 (value-encoding double-p)
1326 (fp-reg-tn-encoding value)
1329 (setf double-p nil))
1330 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1331 (short-disp-encoding segment disp) 0
1332 (if (eq modify :before) 1 0) 1 0 1
1333 (or side 0) (if modify 1 0) value-encoding))))
1336 (define-bitfield-emitter emit-fp-class-0-inst 32
1337 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1338 (byte 3 6) (byte 1 5) (byte 5 0))
1340 (define-bitfield-emitter emit-fp-class-1-inst 32
1341 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1342 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1344 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1345 ;;; seperate emitters.
1347 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1353 (define-instruction funop (segment op from to)
1354 (:declare (type funop op)
1358 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1359 '('FCPY fmt :tab r "," t))
1360 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1361 '('FABS fmt :tab r "," t))
1362 (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1363 '('FSQRT fmt :tab r "," t))
1364 (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1365 '('FRND fmt :tab r "," t))
1367 (multiple-value-bind
1368 (from-encoding from-double-p)
1369 (fp-reg-tn-encoding from)
1370 (multiple-value-bind
1371 (to-encoding to-double-p)
1372 (fp-reg-tn-encoding to)
1373 (aver (eq from-double-p to-double-p))
1374 (emit-fp-class-0-inst segment #x0C from-encoding 0
1375 (+ 2 (or (position op funops)
1376 (error "Bogus FUNOP: ~S" op)))
1377 (if to-double-p 1 0) 0 0 0 to-encoding)))))
1379 (macrolet ((define-class-1-fp-inst (name subcode)
1380 `(define-instruction ,name (segment from to)
1381 (:declare (type tn from to))
1383 (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1384 '(:name sf df :tab r "," t))
1386 (multiple-value-bind
1387 (from-encoding from-double-p)
1388 (fp-reg-tn-encoding from)
1389 (multiple-value-bind
1390 (to-encoding to-double-p)
1391 (fp-reg-tn-encoding to)
1392 (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1393 (if to-double-p 1 0) (if from-double-p 1 0)
1394 1 0 0 to-encoding)))))))
1396 (define-class-1-fp-inst fcnvff 0)
1397 (define-class-1-fp-inst fcnvxf 1)
1398 (define-class-1-fp-inst fcnvfx 2)
1399 (define-class-1-fp-inst fcnvfxt 3))
1401 (define-instruction fcmp (segment cond r1 r2)
1402 (:declare (type (unsigned-byte 5) cond)
1406 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1407 '(:name fmt t :tab r "," x1))
1409 (multiple-value-bind
1410 (r1-encoding r1-double-p)
1411 (fp-reg-tn-encoding r1)
1412 (multiple-value-bind
1413 (r2-encoding r2-double-p)
1414 (fp-reg-tn-encoding r2)
1415 (aver (eq r1-double-p r2-double-p))
1416 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1417 (if r1-double-p 1 0) 2 0 0 cond)))))
1419 (define-instruction ftest (segment)
1422 (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1424 (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1426 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1430 `(member ,@fbinops))
1432 (define-instruction fbinop (segment op r1 r2 result)
1433 (:declare (type fbinop op)
1434 (type tn r1 r2 result))
1437 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1438 '('FADD fmt :tab r "," x1 "," t))
1439 (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1440 '('FSUB fmt :tab r "," x1 "," t))
1441 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1442 '('FMPY fmt :tab r "," x1 "," t))
1443 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1444 '('FDIV fmt :tab r "," x1 "," t))
1446 (multiple-value-bind
1447 (r1-encoding r1-double-p)
1448 (fp-reg-tn-encoding r1)
1449 (multiple-value-bind
1450 (r2-encoding r2-double-p)
1451 (fp-reg-tn-encoding r2)
1452 (aver (eq r1-double-p r2-double-p))
1453 (multiple-value-bind
1454 (result-encoding result-double-p)
1455 (fp-reg-tn-encoding result)
1456 (aver (eq r1-double-p result-double-p))
1457 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1458 (or (position op fbinops)
1459 (error "Bogus FBINOP: ~S" op))
1460 (if r1-double-p 1 0) 3 0 0
1461 result-encoding))))))
1465 ;;;; Instructions built out of other insts.
1467 (define-instruction-macro move (src dst &optional cond)
1468 `(inst or ,src zero-tn ,dst ,cond))
1470 (define-instruction-macro nop (&optional cond)
1471 `(inst or zero-tn zero-tn zero-tn ,cond))
1473 (define-instruction li (segment value reg)
1474 (:declare (type tn reg)
1475 (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1477 (:dependencies (reads reg))
1480 (assemble (segment vop)
1483 (inst ldil value reg)
1484 (inst ldo value reg reg :unsigned t))
1486 (inst ldo value zero-tn reg))
1487 ((or (signed-byte 32) (unsigned-byte 32))
1488 (let ((lo (ldb (byte 11 0) value)))
1489 (inst ldil value reg)
1490 (inst ldo lo reg reg :unsigned t)))))))
1492 (define-instruction-macro sll (src count result &optional cond)
1493 (once-only ((result result) (src src) (count count) (cond cond))
1494 `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1496 (define-instruction-macro sra (src count result &optional cond)
1497 (once-only ((result result) (src src) (count count) (cond cond))
1498 `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1500 (define-instruction-macro srl (src count result &optional cond)
1501 (once-only ((result result) (src src) (count count) (cond cond))
1502 `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1504 (defun maybe-negate-cond (cond negate)
1506 (multiple-value-bind
1508 (compare-condition cond)
1510 (nth value compare-conditions)
1511 (nth (+ value 8) compare-conditions)))
1514 (define-instruction bc (segment cond not-p r1 r2 target)
1515 (:declare (type compare-condition cond)
1516 (type (member t nil) not-p)
1518 (type label target))
1520 (:dependencies (reads r1) (reads r2))
1523 (emit-chooser segment 8 2
1524 (lambda (segment posn delta)
1525 (let ((disp (label-relative-displacement target posn delta)))
1526 (when (<= 0 disp (1- (ash 1 11)))
1527 (assemble (segment vop)
1528 (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1531 (lambda (segment posn)
1532 (let ((disp (label-relative-displacement target posn)))
1533 (assemble (segment vop)
1534 (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
1535 (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1536 (inst nop)) ; FIXME-lav, cant nullify when backward branch
1538 (inst comclr r1 r2 zero-tn
1539 (maybe-negate-cond cond (not not-p)))
1540 (inst b target :nullify t)))))))))
1542 (define-instruction bci (segment cond not-p imm reg target)
1543 (:declare (type compare-condition cond)
1544 (type (member t nil) not-p)
1545 (type (signed-byte 11) imm)
1547 (type label target))
1549 (:dependencies (reads reg))
1552 (emit-chooser segment 8 2
1553 (lambda (segment posn delta-if-after)
1554 (let ((disp (label-relative-displacement target posn delta-if-after)))
1555 (when (and (<= 0 disp (1- (ash 1 11)))
1556 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1557 (assemble (segment vop)
1558 (inst comib (maybe-negate-cond cond not-p) imm reg target
1561 (lambda (segment posn)
1562 (let ((disp (label-relative-displacement target posn)))
1563 (assemble (segment vop)
1564 (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
1565 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
1566 (inst comib (maybe-negate-cond cond not-p) imm reg target)
1569 (inst comiclr imm reg zero-tn
1570 (maybe-negate-cond cond (not not-p)))
1571 (inst b target :nullify t)))))))))
1574 ;;;; Instructions to convert between code ptrs, functions, and lras.
1576 (defun emit-header-data (segment type)
1579 (lambda (segment posn)
1582 (ash (+ posn (component-header-length))
1583 (- n-widetag-bits word-shift)))))))
1585 (define-instruction simple-fun-header-word (segment)
1590 (emit-header-data segment simple-fun-header-widetag)))
1592 (define-instruction lra-header-word (segment)
1597 (emit-header-data segment return-pc-header-widetag)))
1600 (defun emit-compute-inst (segment vop src label temp dst calc)
1602 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1604 ;; This is the best-case that emits one instruction ( 4 bytes )
1605 (lambda (segment posn delta-if-after)
1606 (let ((delta (funcall calc label posn delta-if-after)))
1607 ;; WHEN, Why not AVER ?
1608 (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1609 (emit-back-patch segment 4
1610 (lambda (segment posn)
1611 (assemble (segment vop)
1612 (inst addi (funcall calc label posn 0) src
1615 ;; This is the worst-case that emits three instruction ( 12 bytes )
1616 (lambda (segment posn)
1617 (let ((delta (funcall calc label posn 0)))
1618 ;; FIXME-lav: why do we hit below check ?
1619 ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1620 ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
1621 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1622 ;; intermediate value would be tagged but pointing into space.
1623 ;; Does above note mean that the intermediate value would be
1624 ;; a bogus pointer that would be GCed wrongly ?
1625 ;; Also what I can see addil would also overwrite NFP (r1) ???
1626 (assemble (segment vop)
1627 ;; Three instructions (4 * 3) this is the reason for 12 bytes
1628 (inst ldil delta temp)
1629 (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
1630 (inst add src temp dst))))))
1632 (macrolet ((compute ((name) &body body)
1633 `(define-instruction ,name (segment src label temp dst)
1634 (:declare (type tn src dst temp) (type label label))
1635 (:attributes variable-length)
1636 (:dependencies (reads src) (writes dst) (writes temp))
1640 (emit-compute-inst segment vop src label temp dst
1642 (compute (compute-code-from-lip)
1643 (lambda (label posn delta-if-after)
1644 (- other-pointer-lowtag
1645 (label-position label posn delta-if-after)
1646 (component-header-length))))
1647 (compute (compute-code-from-lra)
1648 (lambda (label posn delta-if-after)
1649 (- (+ (label-position label posn delta-if-after)
1650 (component-header-length)))))
1651 (compute (compute-lra-from-code)
1652 (lambda (label posn delta-if-after)
1653 (+ (label-position label posn delta-if-after)
1654 (component-header-length)))))
1656 ;;;; Data instructions.
1657 (define-bitfield-emitter emit-word 32
1660 (macrolet ((data (size type)
1661 `(define-instruction ,size (segment ,size)
1662 (:declare (type ,type ,size))
1667 (,(symbolicate "EMIT-" size) segment ,size)))))
1668 (data byte (or (unsigned-byte 8) (signed-byte 8)))
1669 (data short (or (unsigned-byte 16) (signed-byte 16)))
1670 (data word (or (unsigned-byte 23) (signed-byte 23))))