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 (typep disp '(signed-byte 17)))
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 ; emit-conditional-branch is used by instruction emitters: MOVB, COMB, ADDB and BB
867 ; which assembles an immediate of total 12 bits (including sign bit).
868 (aver (typep disp '(signed-byte 12)))
869 (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
870 (ldb (byte 1 10) disp)))
871 (w (ldb (byte 1 11) disp))) ; take out the sign bit
872 (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
874 (defun im5-encoding (value)
875 (declare (type (signed-byte 5) value)
876 #+nil (values (unsigned-byte 5)))
877 (dpb (ldb (byte 4 0) value)
879 (ldb (byte 1 4) value)))
881 (macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
883 (let* ((conditional (symbolicate cond-kind "-CONDITION"))
884 (false-conditional (symbolicate conditional "-FALSE")))
886 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
887 (:declare (type ,conditional cond)
890 (type (member t nil) nullify))
894 '((:dependencies (reads r1) (reads r2) (writes r2))))
898 '((:dependencies (reads r1) (reads r2)))))
900 ; '((:dependencies (reads r1) (reads r2) (writes r2)))
901 ; '((:dependencies (reads r1) (reads r2))))
902 (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
903 '(:name c n :tab r1 "," r2 "," w))
904 ,@(unless (= r-opcode #x32)
905 `((:printer branch12 ((op1 ,(+ 2 r-opcode))
906 (c nil :type ',false-conditional))
907 '(:name c n :tab r1 "," r2 "," w))))
910 (cond-encoding false)
912 (emit-conditional-branch
913 segment (if false ,(+ r-opcode 2) ,r-opcode)
914 (reg-tn-encoding r2) (reg-tn-encoding r1)
915 cond-encoding target nullify))))
916 (define-instruction ,i-name (segment cond imm reg target &key nullify)
917 (:declare (type ,conditional cond)
918 (type (signed-byte 5) imm)
920 (type (member t nil) nullify))
923 ; '((:dependencies (reads reg) (writes reg)))
924 ; '((:dependencies (reads reg))))
927 '((:dependencies (reads r1) (reads r2) (writes r2))))
931 '((:dependencies (reads r1) (reads r2)))))
932 (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
933 (c nil :type ',conditional))
934 '(:name c n :tab r1 "," r2 "," w))
935 ,@(unless (= r-opcode #x32)
936 `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
937 (c nil :type ',false-conditional))
938 '(:name c n :tab r1 "," r2 "," w))))
941 (cond-encoding false)
943 (emit-conditional-branch
944 segment (if false (+ ,i-opcode 2) ,i-opcode)
945 (reg-tn-encoding reg) (im5-encoding imm)
946 cond-encoding target nullify))))))))
947 (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
948 (define-branch-inst comb #x20 comib #x21 compare :pinned)
949 (define-branch-inst addb #x28 addib #x29 add :write-reg))
951 (define-instruction bb (segment cond reg posn target &key nullify)
952 (:declare (type (member t nil) cond nullify)
954 (type (or (member :variable) (unsigned-byte 5)) posn))
956 (:dependencies (reads reg))
957 (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
958 '('BVB c n :tab r1 "," w))
961 (opcode posn-encoding)
962 (if (eq posn :variable)
965 (emit-conditional-branch segment opcode posn-encoding
966 (reg-tn-encoding reg)
967 (if cond 2 6) target nullify))))
970 ;;;; Computation Instructions
972 (define-bitfield-emitter emit-r3-inst 32
973 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
974 (byte 1 12) (byte 7 5) (byte 5 0))
976 (macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
977 `(define-instruction ,name (segment r1 r2 res &optional cond)
978 (:declare (type tn res r1 r2))
982 '((:dependencies (reads r1) (reads r2) (writes res))))
983 (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
986 ,@(when (eq name 'or)
987 `((:printer r3-inst ((op ,opcode) (r2 0)
988 (c nil :type ',(symbolicate cond-kind
990 `('COPY :tab r1 "," t))))
994 (,(symbolicate cond-kind "-CONDITION") cond)
995 (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
996 cond (if false 1 0) ,opcode
997 (reg-tn-encoding res)))))))
998 (define-r3-inst add add #x30)
999 (define-r3-inst addl add #x50)
1000 (define-r3-inst addo add #x70)
1001 (define-r3-inst addc add #x38)
1002 (define-r3-inst addco add #x78)
1003 (define-r3-inst sh1add add #x32)
1004 (define-r3-inst sh1addl add #x52)
1005 (define-r3-inst sh1addo add #x72)
1006 (define-r3-inst sh2add add #x34)
1007 (define-r3-inst sh2addl add #x54)
1008 (define-r3-inst sh2addo add #x74)
1009 (define-r3-inst sh3add add #x36)
1010 (define-r3-inst sh3addl add #x56)
1011 (define-r3-inst sh3addo add #x76)
1012 (define-r3-inst sub compare #x20)
1013 (define-r3-inst subo compare #x60)
1014 (define-r3-inst subb compare #x28)
1015 (define-r3-inst subbo compare #x68)
1016 (define-r3-inst subt compare #x26)
1017 (define-r3-inst subto compare #x66)
1018 (define-r3-inst ds compare #x22)
1019 (define-r3-inst comclr compare #x44)
1020 (define-r3-inst or logical #x12 t) ; as a nop it must be pinned
1021 (define-r3-inst xor logical #x14)
1022 (define-r3-inst and logical #x10)
1023 (define-r3-inst andcm logical #x00)
1024 (define-r3-inst uxor unit #x1C)
1025 (define-r3-inst uaddcm unit #x4C)
1026 (define-r3-inst uaddcmt unit #x4E)
1027 (define-r3-inst dcor unit #x5C)
1028 (define-r3-inst idcor unit #x5E))
1030 (define-bitfield-emitter emit-imm-inst 32
1031 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1032 (byte 1 12) (byte 1 11) (byte 11 0))
1034 (macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
1035 `(define-instruction ,name (segment imm src dst &optional cond)
1036 (:declare (type tn dst src)
1037 (type (signed-byte 11) imm))
1039 (:printer imm-inst ((op ,opcode) (o ,subcode)
1041 ',(symbolicate cond-kind "-CONDITION"))))
1042 (:dependencies (reads imm) (reads src) (writes dst))
1044 (multiple-value-bind (cond false)
1045 (,(symbolicate cond-kind "-CONDITION") cond)
1046 (emit-imm-inst segment ,opcode (reg-tn-encoding src)
1047 (reg-tn-encoding dst) cond
1048 (if false 1 0) ,subcode
1049 (encode-imm11 imm)))))))
1050 (define-imm-inst addi add #x2D 0)
1051 (define-imm-inst addio add #x2D 1)
1052 (define-imm-inst addit add #x2C 0)
1053 (define-imm-inst addito add #x2C 1)
1054 (define-imm-inst subi compare #x25 0)
1055 (define-imm-inst subio compare #x25 1)
1056 (define-imm-inst comiclr compare #x24 0))
1058 (define-bitfield-emitter emit-extract/deposit-inst 32
1059 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
1060 (byte 3 10) (byte 5 5) (byte 5 0))
1062 (define-instruction shd (segment r1 r2 count res &optional cond)
1063 (:declare (type tn res r1 r2)
1064 (type (or (member :variable) (integer 0 31)) count))
1067 (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
1068 '(:name c :tab r1 "," r2 "," cp "," t/clen))
1069 (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
1070 '('VSHD c :tab r1 "," r2 "," t/clen))
1074 (emit-extract/deposit-inst segment #x34
1075 (reg-tn-encoding r2) (reg-tn-encoding r1)
1076 (extract/deposit-condition cond)
1077 0 0 (reg-tn-encoding res)))
1079 (emit-extract/deposit-inst segment #x34
1080 (reg-tn-encoding r2) (reg-tn-encoding r1)
1081 (extract/deposit-condition cond)
1083 (reg-tn-encoding res))))))
1085 (macrolet ((define-extract-inst (name opcode)
1086 `(define-instruction ,name (segment src posn len res &optional cond)
1087 (:declare (type tn res src)
1088 (type (or (member :variable) (integer 0 31)) posn)
1089 (type (integer 1 32) len))
1091 (:dependencies (reads src) (writes res))
1092 (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
1094 '(:name c :tab r2 "," cp "," t/clen "," r1))
1095 (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
1096 '('V :name c :tab r2 "," t/clen "," r1))
1100 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1101 (reg-tn-encoding res)
1102 (extract/deposit-condition cond)
1103 ,(- opcode 2) 0 (- 32 len)))
1105 (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
1106 (reg-tn-encoding res)
1107 (extract/deposit-condition cond)
1108 ,opcode posn (- 32 len))))))))
1109 (define-extract-inst extru 6)
1110 (define-extract-inst extrs 7))
1112 (macrolet ((define-deposit-inst (name opcode)
1113 `(define-instruction ,name (segment src posn len res &optional cond)
1114 (:declare (type tn res)
1115 (type (or tn (signed-byte 5)) src)
1116 (type (or (member :variable) (integer 0 31)) posn)
1117 (type (integer 1 32) len))
1119 (:dependencies (reads src) (writes res))
1120 (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
1121 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
1122 (if (= opcode 0) (cons ''Z base) base)))
1123 (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
1124 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
1125 (if (= opcode 0) (cons ''Z base) base)))
1126 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1127 (op2 ,(+ 4 opcode)))
1128 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
1129 (if (= opcode 0) (cons ''Z base) base)))
1130 (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
1131 (op2 ,(+ 6 opcode)))
1132 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
1133 (if (= opcode 0) (cons ''Z base) base)))
1135 (multiple-value-bind
1136 (opcode src-encoding)
1139 (values ,opcode (reg-tn-encoding src)))
1141 (values ,(+ opcode 4) (im5-encoding src))))
1142 (multiple-value-bind
1143 (opcode posn-encoding)
1148 (values (+ opcode 2) (- 31 posn))))
1149 (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
1151 (extract/deposit-condition cond)
1152 opcode posn-encoding (- 32 len))))))))
1154 (define-deposit-inst dep 1)
1155 (define-deposit-inst zdep 0))
1159 ;;;; System Control Instructions.
1161 (define-bitfield-emitter emit-break 32
1162 (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
1164 (define-instruction break (segment &optional (im5 0) (im13 0))
1165 (:declare (type (unsigned-byte 13) im13)
1166 (type (unsigned-byte 5) im5))
1170 (:printer break () :default :control #'break-control)
1172 (emit-break segment 0 im13 0 im5)))
1174 (define-bitfield-emitter emit-system-inst 32
1175 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
1177 (define-instruction ldsid (segment res base &optional (space 0))
1178 (:declare (type tn res base)
1179 (type (integer 0 3) space))
1182 (:printer system-inst ((op2 #x85) (c nil :type 'space)
1183 (s nil :printer #(0 0 1 1 2 2 3 3)))
1184 `(:name :tab "(" s r1 ")," r3))
1186 (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
1187 (reg-tn-encoding res))))
1189 (define-instruction mtsp (segment reg space)
1190 (:declare (type tn reg) (type (integer 0 7) space))
1193 (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
1195 (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
1198 (define-instruction mfsp (segment space reg)
1199 (:declare (type tn reg) (type (integer 0 7) space))
1202 (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
1204 (emit-system-inst segment 0 0 0 (space-encoding space) #x25
1205 (reg-tn-encoding reg))))
1207 (deftype control-reg ()
1208 '(or (unsigned-byte 5) (member :sar)))
1210 (defun control-reg (reg)
1211 (declare (type control-reg reg)
1212 #+nil (values (unsigned-byte 32)))
1213 (if (typep reg '(unsigned-byte 5))
1218 (define-instruction mtctl (segment reg ctrl-reg)
1219 (:declare (type tn reg) (type control-reg ctrl-reg))
1222 (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
1224 (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
1227 (define-instruction mfctl (segment ctrl-reg reg)
1228 (:declare (type tn reg) (type control-reg ctrl-reg))
1231 (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
1233 (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
1234 (reg-tn-encoding reg))))
1238 ;;;; Floating point instructions.
1240 (define-bitfield-emitter emit-fp-load/store 32
1241 (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
1242 (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
1244 (define-instruction fldx (segment index base result &key modify scale side)
1245 (:declare (type tn index base result)
1246 (type (member t nil) modify scale)
1247 (type (member nil 0 1) side))
1250 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
1251 `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t))
1252 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
1253 `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
1255 (multiple-value-bind
1256 (result-encoding double-p)
1257 (fp-reg-tn-encoding result)
1260 (setf double-p nil))
1261 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1262 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
1263 (or side 0) (if modify 1 0) result-encoding))))
1265 (define-instruction fstx (segment value index base &key modify scale side)
1266 (:declare (type tn index base value)
1267 (type (member t nil) modify scale)
1268 (type (member nil 0 1) side))
1271 (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
1272 `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")"))
1273 (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
1274 `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
1276 (multiple-value-bind
1277 (value-encoding double-p)
1278 (fp-reg-tn-encoding value)
1281 (setf double-p nil))
1282 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1283 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
1284 (or side 0) (if modify 1 0) value-encoding))))
1286 (define-instruction flds (segment disp base result &key modify side)
1287 (:declare (type tn base result)
1288 (type (signed-byte 5) disp)
1289 (type (member :before :after nil) modify)
1290 (type (member nil 0 1) side))
1293 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1294 `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t))
1295 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
1296 `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
1298 (multiple-value-bind
1299 (result-encoding double-p)
1300 (fp-reg-tn-encoding result)
1303 (setf double-p nil))
1304 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1305 (short-disp-encoding segment disp) 0
1306 (if (eq modify :before) 1 0) 1 0 0
1307 (or side 0) (if modify 1 0) result-encoding))))
1309 (define-instruction fsts (segment value disp base &key modify side)
1310 (:declare (type tn base value)
1311 (type (signed-byte 5) disp)
1312 (type (member :before :after nil) modify)
1313 (type (member nil 0 1) side))
1316 (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1317 `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1318 (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
1319 `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
1321 (multiple-value-bind
1322 (value-encoding double-p)
1323 (fp-reg-tn-encoding value)
1326 (setf double-p nil))
1327 (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
1328 (short-disp-encoding segment disp) 0
1329 (if (eq modify :before) 1 0) 1 0 1
1330 (or side 0) (if modify 1 0) value-encoding))))
1333 (define-bitfield-emitter emit-fp-class-0-inst 32
1334 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
1335 (byte 3 6) (byte 1 5) (byte 5 0))
1337 (define-bitfield-emitter emit-fp-class-1-inst 32
1338 (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
1339 (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
1341 ;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
1342 ;;; seperate emitters.
1344 (defconstant-eqx funops '(:copy :abs :sqrt :rnd)
1350 (define-instruction funop (segment op from to)
1351 (:declare (type funop op)
1355 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
1356 '('FCPY fmt :tab r "," t))
1357 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
1358 '('FABS fmt :tab r "," t))
1359 (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
1360 '('FSQRT fmt :tab r "," t))
1361 (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
1362 '('FRND fmt :tab r "," t))
1364 (multiple-value-bind
1365 (from-encoding from-double-p)
1366 (fp-reg-tn-encoding from)
1367 (multiple-value-bind
1368 (to-encoding to-double-p)
1369 (fp-reg-tn-encoding to)
1370 (aver (eq from-double-p to-double-p))
1371 (emit-fp-class-0-inst segment #x0C from-encoding 0
1372 (+ 2 (or (position op funops)
1373 (error "Bogus FUNOP: ~S" op)))
1374 (if to-double-p 1 0) 0 0 0 to-encoding)))))
1376 (macrolet ((define-class-1-fp-inst (name subcode)
1377 `(define-instruction ,name (segment from to)
1378 (:declare (type tn from to))
1380 (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
1381 '(:name sf df :tab r "," t))
1383 (multiple-value-bind
1384 (from-encoding from-double-p)
1385 (fp-reg-tn-encoding from)
1386 (multiple-value-bind
1387 (to-encoding to-double-p)
1388 (fp-reg-tn-encoding to)
1389 (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
1390 (if to-double-p 1 0) (if from-double-p 1 0)
1391 1 0 0 to-encoding)))))))
1393 (define-class-1-fp-inst fcnvff 0)
1394 (define-class-1-fp-inst fcnvxf 1)
1395 (define-class-1-fp-inst fcnvfx 2)
1396 (define-class-1-fp-inst fcnvfxt 3))
1398 (define-instruction fcmp (segment cond r1 r2)
1399 (:declare (type (unsigned-byte 5) cond)
1403 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
1404 '(:name fmt t :tab r "," x1))
1406 (multiple-value-bind
1407 (r1-encoding r1-double-p)
1408 (fp-reg-tn-encoding r1)
1409 (multiple-value-bind
1410 (r2-encoding r2-double-p)
1411 (fp-reg-tn-encoding r2)
1412 (aver (eq r1-double-p r2-double-p))
1413 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
1414 (if r1-double-p 1 0) 2 0 0 cond)))))
1416 (define-instruction ftest (segment)
1419 (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
1421 (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
1423 (defconstant-eqx fbinops '(:add :sub :mpy :div)
1427 `(member ,@fbinops))
1429 (define-instruction fbinop (segment op r1 r2 result)
1430 (:declare (type fbinop op)
1431 (type tn r1 r2 result))
1434 (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
1435 '('FADD fmt :tab r "," x1 "," t))
1436 (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
1437 '('FSUB fmt :tab r "," x1 "," t))
1438 (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
1439 '('FMPY fmt :tab r "," x1 "," t))
1440 (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
1441 '('FDIV fmt :tab r "," x1 "," t))
1443 (multiple-value-bind
1444 (r1-encoding r1-double-p)
1445 (fp-reg-tn-encoding r1)
1446 (multiple-value-bind
1447 (r2-encoding r2-double-p)
1448 (fp-reg-tn-encoding r2)
1449 (aver (eq r1-double-p r2-double-p))
1450 (multiple-value-bind
1451 (result-encoding result-double-p)
1452 (fp-reg-tn-encoding result)
1453 (aver (eq r1-double-p result-double-p))
1454 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
1455 (or (position op fbinops)
1456 (error "Bogus FBINOP: ~S" op))
1457 (if r1-double-p 1 0) 3 0 0
1458 result-encoding))))))
1462 ;;;; Instructions built out of other insts.
1464 (define-instruction-macro move (src dst &optional cond)
1465 `(inst or ,src zero-tn ,dst ,cond))
1467 (define-instruction-macro nop (&optional cond)
1468 `(inst or zero-tn zero-tn zero-tn ,cond))
1470 (define-instruction li (segment value reg)
1471 (:declare (type tn reg)
1472 (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
1474 (:dependencies (reads reg))
1477 (assemble (segment vop)
1480 (inst ldil value reg)
1481 (inst ldo value reg reg :unsigned t))
1483 (inst ldo value zero-tn reg))
1484 ((or (signed-byte 32) (unsigned-byte 32))
1485 (let ((lo (ldb (byte 11 0) value)))
1486 (inst ldil value reg)
1487 (inst ldo lo reg reg :unsigned t)))))))
1489 (define-instruction-macro sll (src count result &optional cond)
1490 (once-only ((result result) (src src) (count count) (cond cond))
1491 `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1493 (define-instruction-macro sra (src count result &optional cond)
1494 (once-only ((result result) (src src) (count count) (cond cond))
1495 `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1497 (define-instruction-macro srl (src count result &optional cond)
1498 (once-only ((result result) (src src) (count count) (cond cond))
1499 `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
1501 (defun maybe-negate-cond (cond negate)
1503 (multiple-value-bind
1505 (compare-condition cond)
1507 (nth value compare-conditions)
1508 (nth (+ value 8) compare-conditions)))
1511 (define-instruction bc (segment cond not-p r1 r2 target)
1512 (:declare (type compare-condition cond)
1513 (type (member t nil) not-p)
1515 (type label target))
1517 (:dependencies (reads r1) (reads r2))
1520 (emit-chooser segment 8 2
1521 (lambda (segment posn delta)
1522 (let ((disp (label-relative-displacement target posn delta)))
1523 (when (<= 0 disp (1- (ash 1 11)))
1524 (assemble (segment vop)
1525 (inst comb (maybe-negate-cond cond not-p) r1 r2 target
1528 (lambda (segment posn)
1529 (let ((disp (label-relative-displacement target posn)))
1530 (assemble (segment vop)
1531 (cond ((typep disp '(signed-byte 12))
1532 (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
1533 (inst nop)) ; FIXME-lav, cant nullify when backward branch
1535 (inst comclr r1 r2 zero-tn
1536 (maybe-negate-cond cond (not not-p)))
1537 (inst b target :nullify t)))))))))
1539 (define-instruction bci (segment cond not-p imm reg target)
1540 (:declare (type compare-condition cond)
1541 (type (member t nil) not-p)
1542 (type (signed-byte 11) imm)
1544 (type label target))
1546 (:dependencies (reads reg))
1549 (emit-chooser segment 8 2
1550 (lambda (segment posn delta-if-after)
1551 (let ((disp (label-relative-displacement target posn delta-if-after)))
1552 (when (and (<= 0 disp (1- (ash 1 11)))
1553 (typep imm '(signed-byte 5)))
1554 (assemble (segment vop)
1555 (inst comib (maybe-negate-cond cond not-p) imm reg target
1558 (lambda (segment posn)
1559 (let ((disp (label-relative-displacement target posn)))
1560 (assemble (segment vop)
1561 (cond ((and (typep disp '(signed-byte 12))
1562 (typep imm '(signed-byte 5)))
1563 (inst comib (maybe-negate-cond cond not-p) imm reg target)
1566 (inst comiclr imm reg zero-tn
1567 (maybe-negate-cond cond (not not-p)))
1568 (inst b target :nullify t)))))))))
1571 ;;;; Instructions to convert between code ptrs, functions, and lras.
1573 (defun emit-header-data (segment type)
1576 (lambda (segment posn)
1579 (ash (+ posn (component-header-length))
1580 (- n-widetag-bits word-shift)))))))
1582 (define-instruction simple-fun-header-word (segment)
1587 (emit-header-data segment simple-fun-header-widetag)))
1589 (define-instruction lra-header-word (segment)
1594 (emit-header-data segment return-pc-header-widetag)))
1597 (defun emit-compute-inst (segment vop src label temp dst calc)
1599 ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
1601 ;; This is the best-case that emits one instruction ( 4 bytes )
1602 (lambda (segment posn delta-if-after)
1603 (let ((delta (funcall calc label posn delta-if-after)))
1604 ;; WHEN, Why not AVER ?
1605 (when (typep delta '(signed-byte 11))
1606 (emit-back-patch segment 4
1607 (lambda (segment posn)
1608 (assemble (segment vop)
1609 (inst addi (funcall calc label posn 0) src
1612 ;; This is the worst-case that emits three instruction ( 12 bytes )
1613 (lambda (segment posn)
1614 (let ((delta (funcall calc label posn 0)))
1615 ;; FIXME-lav: why do we hit below check ?
1616 ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
1617 ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
1618 ;; Note: if we used addil/ldo to do this in 2 instructions then the
1619 ;; intermediate value would be tagged but pointing into space.
1620 ;; Does above note mean that the intermediate value would be
1621 ;; a bogus pointer that would be GCed wrongly ?
1622 ;; Also what I can see addil would also overwrite NFP (r1) ???
1623 (assemble (segment vop)
1624 ;; Three instructions (4 * 3) this is the reason for 12 bytes
1625 (inst ldil delta temp)
1626 (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
1627 (inst add src temp dst))))))
1629 (macrolet ((compute ((name) &body body)
1630 `(define-instruction ,name (segment src label temp dst)
1631 (:declare (type tn src dst temp) (type label label))
1632 (:attributes variable-length)
1633 (:dependencies (reads src) (writes dst) (writes temp))
1637 (emit-compute-inst segment vop src label temp dst
1639 (compute (compute-code-from-lip)
1640 (lambda (label posn delta-if-after)
1641 (- other-pointer-lowtag
1642 (label-position label posn delta-if-after)
1643 (component-header-length))))
1644 (compute (compute-code-from-lra)
1645 (lambda (label posn delta-if-after)
1646 (- (+ (label-position label posn delta-if-after)
1647 (component-header-length)))))
1648 (compute (compute-lra-from-code)
1649 (lambda (label posn delta-if-after)
1650 (+ (label-position label posn delta-if-after)
1651 (component-header-length)))))
1653 ;;;; Data instructions.
1654 (define-bitfield-emitter emit-word 32
1657 (macrolet ((data (size type)
1658 `(define-instruction ,size (segment ,size)
1659 (:declare (type ,type ,size))
1664 (,(symbolicate "EMIT-" size) segment ,size)))))
1665 (data byte (or (unsigned-byte 8) (signed-byte 8)))
1666 (data short (or (unsigned-byte 16) (signed-byte 16)))
1667 (data word (or (unsigned-byte 23) (signed-byte 23))))