1 ;;; -*- Package: ALPHA -*-
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
9 ;;; **********************************************************************
11 ;;; This file contains the instruction set definition for the Alpha.
13 ;;; Written by Sean Hallgren.
19 ;;;(def-assembler-params
22 ;;; ../x86/insts contains the invocation
23 ;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
24 ;;; which apparently was another use of def-assembler-params
27 ;;;; Utility functions.
29 (defun reg-tn-encoding (tn)
31 (values (unsigned-byte 5)))
36 (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
39 (defun fp-reg-tn-encoding (tn)
40 (declare (type tn tn))
42 (fp-single-zero (tn-offset fp-single-zero-tn))
43 (fp-double-zero (tn-offset fp-double-zero-tn))
45 (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
46 (error "~S isn't a floating-point register." tn))
50 ;;;; Initial disassembler setup.
52 ;; XXX find out what this was supposed to do
53 ;; (sb!disassem:set-disassem-params :instruction-alignment 32)
55 (defvar *disassem-use-lisp-reg-names* t)
57 (defparameter reg-symbols
60 (cond ((null name) nil)
61 (t (make-symbol (concatenate 'string "$" name)))))
64 (sb!disassem:define-argument-type reg
65 :printer #'(lambda (value stream dstate)
66 (declare (stream stream) (fixnum value))
67 (let ((regname (aref reg-symbols value)))
68 (princ regname stream)
69 (sb!disassem:maybe-note-associated-storage-ref
75 (defparameter float-reg-symbols
77 (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n)))
80 (sb!disassem:define-argument-type fp-reg
81 :printer #'(lambda (value stream dstate)
82 (declare (stream stream) (fixnum value))
83 (let ((regname (aref float-reg-symbols value)))
84 (princ regname stream)
85 (sb!disassem:maybe-note-associated-storage-ref
91 (sb!disassem:define-argument-type relative-label
93 :use-label #'(lambda (value dstate)
94 (declare (type (signed-byte 21) value)
95 (type sb!disassem:disassem-state dstate))
96 (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
100 ;;;; Define-instruction-formats for disassembler.
101 (sb!disassem:define-instruction-format
102 (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
103 (op :field (byte 6 26))
104 (ra :field (byte 5 21) :type 'reg)
105 (rb :field (byte 5 16) :type 'reg)
106 (disp :field (byte 16 0) :sign-extend t))
108 (sb!disassem:define-instruction-format
109 (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint))
110 (op :field (byte 6 26))
111 (ra :field (byte 5 21) :type 'reg)
112 (rb :field (byte 5 16) :type 'reg)
113 (subop :field (byte 2 14))
114 (hint :field (byte 14 0)))
116 (sb!disassem:define-instruction-format
117 (branch 32 :default-printer '(:name :tab ra "," disp))
118 (op :field (byte 6 26))
119 (ra :field (byte 5 21) :type 'reg)
120 (disp :field (byte 21 0) :type 'relative-label))
122 (sb!disassem:define-instruction-format
123 (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc))
124 (op :field (byte 6 26))
125 (ra :field (byte 5 21) :type 'reg)
126 (rb :field (byte 5 16) :type 'reg)
127 (sbz :field (byte 3 13))
128 (f :field (byte 1 12) :value 0)
129 (fn :field (byte 7 5))
130 (rc :field (byte 5 0) :type 'reg))
132 (sb!disassem:define-instruction-format
133 (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc))
134 (op :field (byte 6 26))
135 (ra :field (byte 5 21) :type 'reg)
136 (lit :field (byte 8 13))
137 (f :field (byte 1 12) :value 1)
138 (fn :field (byte 7 5))
139 (rc :field (byte 5 0) :type 'reg))
141 (sb!disassem:define-instruction-format
142 (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc))
143 (op :field (byte 6 26))
144 (fa :field (byte 5 21) :type 'fp-reg)
145 (fb :field (byte 5 16) :type 'fp-reg)
146 (fn :field (byte 11 5))
147 (fc :field (byte 5 0) :type 'fp-reg))
149 (sb!disassem:define-instruction-format
150 (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name))
151 (op :field (byte 6 26) :value 0)
152 (palcode :field (byte 26 0)))
156 (define-bitfield-emitter emit-word 16
159 (define-bitfield-emitter emit-lword 32
162 (define-bitfield-emitter emit-qword 64
165 (define-bitfield-emitter emit-memory 32
166 (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
168 (define-bitfield-emitter emit-branch 32
169 (byte 6 26) (byte 5 21) (byte 21 0))
171 (define-bitfield-emitter emit-reg-operate 32
172 (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5)
175 (define-bitfield-emitter emit-lit-operate 32
176 (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0))
178 (define-bitfield-emitter emit-fp-operate 32
179 (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0))
181 (define-bitfield-emitter emit-pal 32
182 (byte 6 26) (byte 26 0))
185 ;;;; Macros for instructions.
186 (macrolet ((define-memory (name op &optional fixup float)
187 `(define-instruction ,name (segment ra disp rb ,@(if fixup
189 (:declare (type tn ra rb)
190 ,@(if fixup ; ### unsigned-byte 16 bad idea?
191 '((type (or (unsigned-byte 16) (signed-byte 16) fixup)
193 '((type (or (unsigned-byte 16) (signed-byte 16)) disp))))
194 (:printer memory ((op ,op)))
197 `((when (fixup-p disp)
198 (note-fixup segment (or type ,fixup) disp)
200 (emit-memory segment ,op ,@(if float
201 '((fp-reg-tn-encoding ra))
202 '((reg-tn-encoding ra)))
205 (define-memory lda #x08 :lda)
206 (define-memory ldah #x09 :ldah)
207 (define-memory ldl #x28)
208 (define-memory ldq #x29)
209 (define-memory ldl_l #x2a)
210 (define-memory ldq_q #x2b)
211 (define-memory ldq_u #x0b)
212 (define-memory stl #x2c)
213 (define-memory stq #x2d)
214 (define-memory stl_c #x2e)
215 (define-memory stq_c #x2f)
216 (define-memory stq_u #x0f)
217 (define-memory ldf #x20 nil t)
218 (define-memory ldg #x21 nil t)
219 (define-memory lds #x22 nil t)
220 (define-memory ldt #x23 nil t)
221 (define-memory stf #x24 nil t)
222 (define-memory stg #x25 nil t)
223 (define-memory sts #x26 nil t)
224 (define-memory stt #x27 nil t))
226 (macrolet ((define-jump (name subop)
227 `(define-instruction ,name (segment ra rb &optional (hint 0))
228 (:declare (type tn ra rb)
229 (type (or (unsigned-byte 14) fixup) hint))
230 (:printer jump ((op #x1a) (subop ,subop)))
233 (note-fixup segment :jmp-hint hint)
235 (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
236 (logior (ash ,subop 14) hint))))))
240 (define-jump jsr-coroutine 3))
243 (macrolet ((define-branch (name op &optional (float nil))
244 `(define-instruction ,name (segment ra target)
245 (:declare (type tn ra)
247 (:printer branch ((op ,op)
249 '((ra nil :type 'fp-reg)))))
251 (emit-back-patch segment 4
252 #'(lambda (segment posn)
253 (emit-branch segment ,op
255 '((fp-reg-tn-encoding ra))
256 '((reg-tn-encoding ra)))
257 (ash (- (label-position target)
260 (define-branch br #x30)
261 (define-branch bsr #x34)
262 (define-branch blbc #x38)
263 (define-branch blbs #x3c)
264 (define-branch fbeq #x31 t)
265 (define-branch fbne #x35 t)
266 (define-branch beq #x39)
267 (define-branch bne #x3d)
268 (define-branch fblt #x32 t)
269 (define-branch fbge #x36 t)
270 (define-branch blt #x3a)
271 (define-branch bge #x3e)
272 (define-branch fble #x33 t)
273 (define-branch fbgt #x37 t)
274 (define-branch ble #x3b)
275 (define-branch bgt #x3f))
277 (macrolet ((define-operate (name op fn)
278 `(define-instruction ,name (segment ra rb rc)
279 (:declare (type tn ra rc)
280 (type (or tn (unsigned-byte 8)) rb))
281 (:printer reg-operate ((op ,op) (fn ,fn)))
282 (:printer lit-operate ((op ,op) (fn ,fn)))
283 ,@(when (and (= op #x11) (= fn #x20))
284 `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
285 '('move :tab rb "," rc))
286 (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
291 (emit-reg-operate segment ,op (reg-tn-encoding ra)
292 (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
294 (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
295 (reg-tn-encoding rc))))))))
296 (define-operate addl #x10 #x00)
297 (define-operate addl/v #x10 #x40)
298 (define-operate addq #x10 #x20)
299 (define-operate addq/v #x10 #x60)
300 (define-operate cmpule #x10 #x3d)
301 (define-operate cmpbge #x10 #x0f)
302 (define-operate subl #x10 #x09)
303 (define-operate subl/v #x10 #x49)
304 (define-operate subq #x10 #x29)
305 (define-operate subq/v #x10 #x69)
306 (define-operate cmpeq #x10 #x2d)
307 (define-operate cmplt #x10 #x4d)
308 (define-operate cmple #x10 #x6d)
309 (define-operate cmpult #x10 #x1d)
310 (define-operate s4addl #x10 #x02)
311 (define-operate s4addq #x10 #x22)
312 (define-operate s4subl #x10 #x0b)
313 (define-operate s4subq #x10 #x2b)
314 (define-operate s8addl #x10 #x12)
315 (define-operate s8addq #x10 #x32)
316 (define-operate s8subl #x10 #x1b)
317 (define-operate s8subq #x10 #x3b)
319 (define-operate and #x11 #x00)
320 (define-operate bic #x11 #x08)
321 (define-operate cmoveq #x11 #x24)
322 (define-operate cmovne #x11 #x26)
323 (define-operate cmovlbs #x11 #x14)
324 (define-operate bis #x11 #x20)
325 (define-operate ornot #x11 #x28)
326 (define-operate cmovlt #x11 #x44)
327 (define-operate cmovge #x11 #x46)
328 (define-operate cmovlbc #x11 #x16)
329 (define-operate xor #x11 #x40)
330 (define-operate eqv #x11 #x48)
331 (define-operate cmovle #x11 #x64)
332 (define-operate cmovgt #x11 #x66)
334 (define-operate sll #x12 #x39)
335 (define-operate extbl #x12 #x06)
336 (define-operate extwl #x12 #x16)
337 (define-operate extll #x12 #x26)
338 (define-operate extql #x12 #x36)
339 (define-operate extwh #x12 #x5a)
340 (define-operate extlh #x12 #x6a)
341 (define-operate extqh #x12 #x7a)
342 (define-operate sra #x12 #x3c)
343 (define-operate insbl #x12 #x0b)
344 (define-operate inswl #x12 #x1b)
345 (define-operate insll #x12 #x2b)
346 (define-operate insql #x12 #x3b)
347 (define-operate inswh #x12 #x57)
348 (define-operate inslh #x12 #x67)
349 (define-operate insqh #x12 #x77)
350 (define-operate srl #x12 #x34)
351 (define-operate mskbl #x12 #x02)
352 (define-operate mskwl #x12 #x12)
353 (define-operate mskll #x12 #x22)
354 (define-operate mskql #x12 #x32)
355 (define-operate mskwh #x12 #x52)
356 (define-operate msklh #x12 #x62)
357 (define-operate mskqh #x12 #x72)
358 (define-operate zap #x12 #x30)
359 (define-operate zapnot #x12 #x31)
361 (define-operate mull #x13 #x00)
362 (define-operate mulq/v #x13 #x60)
363 (define-operate mull/v #x13 #x40)
364 (define-operate umulh #x13 #x30)
365 (define-operate mulq #x13 #x20))
368 (macrolet ((define-fp-operate (name op fn &optional (args 3))
369 `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
370 (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
371 (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
373 '('(:name :tab fb "," fc))))
374 ,@(when (and (= op #x17) (= fn #x20))
375 `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
376 '('fabs :tab fb "," fc))))
378 (emit-fp-operate segment ,op ,@(if (= args 3)
379 '((fp-reg-tn-encoding fa))
381 (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))))
382 (define-fp-operate cpys #x17 #x020)
383 (define-fp-operate mf_fpcr #x17 #x025)
384 (define-fp-operate cpysn #x17 #x021)
385 (define-fp-operate mt_fpcr #x17 #x024)
386 (define-fp-operate cpyse #x17 #x022)
387 (define-fp-operate cvtql/sv #x17 #x530 2)
388 (define-fp-operate cvtlq #x17 #x010 2)
389 (define-fp-operate cvtql #x17 #x030 2)
390 (define-fp-operate cvtql/v #x17 #x130 2)
391 (define-fp-operate fcmoveq #x17 #x02a)
392 (define-fp-operate fcmovne #x17 #x02b)
393 (define-fp-operate fcmovlt #x17 #x02c)
394 (define-fp-operate fcmovge #x17 #x02d)
395 (define-fp-operate fcmovle #x17 #x02e)
396 (define-fp-operate fcmovgt #x17 #x02f)
398 (define-fp-operate cvtqs #x16 #x0bc 2)
399 (define-fp-operate cvtqt #x16 #x0be 2)
400 (define-fp-operate cvtts #x16 #x0ac 2)
401 (define-fp-operate cvttq #x16 #x0af 2)
402 (define-fp-operate cvttq/c #x16 #x02f 2)
403 (define-fp-operate cmpteq #x16 #x5a5)
404 (define-fp-operate cmptlt #x16 #x5a6)
405 (define-fp-operate cmptle #x16 #x5a7)
406 (define-fp-operate cmptun #x16 #x5a4)
407 (define-fp-operate adds #x16 #x080)
408 (define-fp-operate addt #x16 #x0a0)
409 (define-fp-operate divs #x16 #x083)
410 (define-fp-operate divt #x16 #x0a3)
411 (define-fp-operate muls #x16 #x082)
412 (define-fp-operate mult #x16 #x0a2)
413 (define-fp-operate subs #x16 #x081)
414 (define-fp-operate subt #x16 #x0a1)
417 (defconstant +su+ #x500) ; software, underflow enabled
418 (defconstant +sui+ #x700) ; software, inexact & underflow enabled
419 (defconstant +sv+ #x500) ; software, interger overflow enabled
420 (defconstant +svi+ #x700)
421 (defconstant +rnd+ #x0c0) ; dynamic rounding mode
422 (defconstant +sud+ #x5c0)
423 (defconstant +svid+ #x7c0)
424 (defconstant +suid+ #x7c0)
426 (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
427 (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
428 (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
430 (define-fp-operate adds_su #x16 (logior +su+ #x080))
431 (define-fp-operate addt_su #x16 (logior +su+ #x0a0))
432 (define-fp-operate divs_su #x16 (logior +su+ #x083))
433 (define-fp-operate divt_su #x16 (logior +su+ #x0a3))
434 (define-fp-operate muls_su #x16 (logior +su+ #x082))
435 (define-fp-operate mult_su #x16 (logior +su+ #x0a2))
436 (define-fp-operate subs_su #x16 (logior +su+ #x081))
437 (define-fp-operate subt_su #x16 (logior +su+ #x0a1)))
439 (define-instruction excb (segment)
440 (:emitter (emit-lword segment #x63ff0400)))
442 (define-instruction trapb (segment)
443 (:emitter (emit-lword segment #x63ff0000)))
445 (define-instruction gentrap (segment code)
446 (:printer call-pal ((palcode #xaa0000)))
448 (emit-lword segment #x000080)
449 (emit-lword segment code)))
451 (define-instruction-macro move (src dst)
452 `(inst bis zero-tn ,src ,dst))
454 (define-instruction-macro not (src dst)
455 `(inst ornot zero-tn ,src ,dst))
457 (define-instruction-macro fmove (src dst)
458 `(inst cpys ,src ,src ,dst))
460 (define-instruction-macro fabs (src dst)
461 `(inst cpys fp-single-zero-tn ,src ,dst))
463 (define-instruction-macro fneg (src dst)
464 `(inst cpysn ,src ,src ,dst))
466 (define-instruction-macro nop ()
467 `(inst bis zero-tn zero-tn zero-tn))
469 (defun %li (value reg)
472 (inst lda reg value zero-tn))
475 (let ((x (logand x (lognot (ash -1 n)))))
476 (if (logbitp (1- n) x)
477 (logior (ash -1 (1- n)) x)
479 (let* ((value (se value 32))
480 (low (ldb (byte 16 0) value))
481 (tmp1 (- value (se low 16)))
482 (high (ldb (byte 16 16) tmp1))
483 (tmp2 (- tmp1 (se (ash high 16) 32)))
487 (setf tmp1 (- tmp1 #x40000000))
488 (setf high (ldb (byte 16 16) tmp1)))
489 (inst lda reg low zero-tn)
491 (inst ldah reg extra reg))
493 (inst ldah reg high reg)))))
494 ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
495 (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
496 (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1))
497 (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2)))
498 (inst lda reg (ldb (byte 16 32) value2) zero-tn)
500 (inst ldah reg (ldb (byte 16 48) value3) reg))
501 (unless (and (= value2 0) (= value3 0))
502 (inst sll reg 32 reg))
504 (inst lda reg (ldb (byte 16 0) value) reg))
506 (inst ldah reg (ldb (byte 16 16) value1) reg))))
508 (inst lda reg value zero-tn :bits-47-32)
509 (inst ldah reg value reg :bits-63-48)
510 (inst sll reg 32 reg)
511 (inst lda reg value reg)
512 (inst ldah reg value reg))))
514 (define-instruction-macro li (value reg)
520 (define-instruction lword (segment lword)
521 (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
524 (emit-lword segment lword)))
526 (define-instruction short (segment word)
527 (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
530 (emit-word segment word)))
532 (define-instruction byte (segment byte)
533 (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
536 (emit-byte segment byte)))
538 (defun emit-header-data (segment type)
541 #'(lambda (segment posn)
544 (ash (+ posn (component-header-length))
545 (- type-bits word-shift)))))))
547 (define-instruction function-header-word (segment)
550 (emit-header-data segment function-header-type)))
552 (define-instruction lra-header-word (segment)
555 (emit-header-data segment return-pc-header-type)))
557 (defun emit-compute-inst (segment vop dst src label temp calc)
558 (declare (ignore temp))
560 ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
562 #'(lambda (segment posn delta-if-after)
563 (let ((delta (funcall calc label posn delta-if-after)))
564 (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
565 (emit-back-patch segment 4
566 #'(lambda (segment posn)
567 (assemble (segment vop)
569 (funcall calc label posn 0)
572 #'(lambda (segment posn)
573 (assemble (segment vop)
575 (let ((x (logand x (lognot (ash -1 n)))))
576 (if (logbitp (1- n) x)
577 (logior (ash -1 (1- n)) x)
579 (let* ((value (se (funcall calc label posn 0) 32))
580 (low (ldb (byte 16 0) value))
581 (tmp1 (- value (se low 16)))
582 (high (ldb (byte 16 16) tmp1))
583 (tmp2 (- tmp1 (se (ash high 16) 32)))
587 (setf tmp1 (- tmp1 #x40000000))
588 (setf high (ldb (byte 16 16) tmp1)))
589 (inst lda dst low src)
590 (inst ldah dst extra dst)
591 (inst ldah dst high dst)))))))
593 ;; code = fn - header - label-offset + other-pointer-tag
594 (define-instruction compute-code-from-fn (segment dst src label temp)
595 (:declare (type tn dst src temp) (type label label))
598 (emit-compute-inst segment vop dst src label temp
599 #'(lambda (label posn delta-if-after)
600 (- other-pointer-type
601 (label-position label posn delta-if-after)
602 (component-header-length))))))
604 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
605 ;; = lra - (header + label-offset)
606 (define-instruction compute-code-from-lra (segment dst src label temp)
607 (:declare (type tn dst src temp) (type label label))
610 (emit-compute-inst segment vop dst src label temp
611 #'(lambda (label posn delta-if-after)
612 (- (+ (label-position label posn delta-if-after)
613 (component-header-length)))))))
615 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
616 (define-instruction compute-lra-from-code (segment dst src label temp)
617 (:declare (type tn dst src temp) (type label label))
620 (emit-compute-inst segment vop dst src label temp
621 #'(lambda (label posn delta-if-after)
622 (+ (label-position label posn delta-if-after)
623 (component-header-length))))))