-;;; -*- Package: ALPHA -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the instruction set definition for the Alpha.
-;;;
-;;; Written by Sean Hallgren.
-;;;
+;;; the instruction set definition for the Alpha
-(in-package "SB!VM")
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+(in-package "SB!VM")
;;;(def-assembler-params
;;; :scheduler-p nil)
;;; ../x86/insts contains the invocation
;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
;;; which apparently was another use of def-assembler-params
-
\f
-;;;; Utility functions.
+;;;; utility functions
(defun reg-tn-encoding (tn)
(declare (type tn tn)
(unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
(error "~S isn't a floating-point register." tn))
(tn-offset tn))))
-
\f
-;;;; Initial disassembler setup.
+;;;; initial disassembler setup
;; XXX find out what this was supposed to do
;; (sb!disassem:set-disassem-params :instruction-alignment 32)
(defparameter reg-symbols
(map 'vector
- #'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
-(sb!disassem:define-argument-type reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'registers
- regname
- dstate))))
+(sb!disassem:define-arg-type reg
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
(defparameter float-reg-symbols
(coerce
- (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n)))
+ (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n)))
'vector))
-(sb!disassem:define-argument-type fp-reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
-
-(sb!disassem:define-argument-type relative-label
+(sb!disassem:define-arg-type fp-reg
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
+
+(sb!disassem:define-arg-type relative-label
:sign-extend t
- :use-label #'(lambda (value dstate)
- (declare (type (signed-byte 21) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ :use-label (lambda (value dstate)
+ (declare (type (signed-byte 21) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
\f
-;;;; Define-instruction-formats for disassembler.
+;;;; DEFINE-INSTRUCTION-FORMATs for the disassembler
+
(sb!disassem:define-instruction-format
(memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
(op :field (byte 6 26))
(palcode :field (byte 26 0)))
\f
-;;;; Emitters.
+;;;; emitters
+
(define-bitfield-emitter emit-word 16
(byte 16 0))
(define-bitfield-emitter emit-pal 32
(byte 6 26) (byte 26 0))
-
\f
-;;;; Macros for instructions.
+;;;; macros for instructions
+
(macrolet ((define-memory (name op &optional fixup float)
`(define-instruction ,name (segment ra disp rb ,@(if fixup
'(&optional type)))
'((ra nil :type 'fp-reg)))))
(:emitter
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (emit-branch segment ,op
- ,@(if float
- '((fp-reg-tn-encoding ra))
+ (lambda (segment posn)
+ (emit-branch segment ,op
+ ,@(if float
+ '((fp-reg-tn-encoding ra))
'((reg-tn-encoding ra)))
- (ash (- (label-position target)
- (+ posn 4))
- -2))))))))
+ (ash (- (label-position target)
+ (+ posn 4))
+ -2))))))))
(define-branch br #x30)
(define-branch bsr #x34)
(define-branch blbc #x38)
(define-fp-operate subt #x16 #x0a1)
;;; IEEE support
- (defconstant +su+ #x500) ; software, underflow enabled
- (defconstant +sui+ #x700) ; software, inexact & underflow enabled
- (defconstant +sv+ #x500) ; software, interger overflow enabled
- (defconstant +svi+ #x700)
- (defconstant +rnd+ #x0c0) ; dynamic rounding mode
- (defconstant +sud+ #x5c0)
- (defconstant +svid+ #x7c0)
- (defconstant +suid+ #x7c0)
+ (def!constant +su+ #x500) ; software, underflow enabled
+ (def!constant +sui+ #x700) ; software, inexact & underflow enabled
+ (def!constant +sv+ #x500) ; software, interger overflow enabled
+ (def!constant +svi+ #x700)
+ (def!constant +rnd+ #x0c0) ; dynamic rounding mode
+ (def!constant +sud+ #x5c0)
+ (def!constant +svid+ #x7c0)
+ (def!constant +suid+ #x7c0)
(define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
+ (define-fp-operate cvtqs_sui #x16 (logior +sui+ #x0bc) 2)
(define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
+ (define-fp-operate cvtqt_sui #x16 (logior +sui+ #x0be) 2)
(define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
+ (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
+ (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2)
+
(define-fp-operate adds_su #x16 (logior +su+ #x080))
(define-fp-operate addt_su #x16 (logior +su+ #x0a0))
(define-fp-operate divs_su #x16 (logior +su+ #x083))
(define-instruction trapb (segment)
(:emitter (emit-lword segment #x63ff0000)))
+(define-instruction imb (segment)
+ (:emitter (emit-lword segment #x00000086)))
+
(define-instruction gentrap (segment code)
(:printer call-pal ((palcode #xaa0000)))
(:emitter
- (emit-lword segment #x000080)
+ (emit-lword segment #x000081) ;actually bugchk
(emit-lword segment code)))
(define-instruction-macro move (src dst)
(defun emit-header-data (segment type)
(emit-back-patch
segment 4
- #'(lambda (segment posn)
- (emit-lword segment
- (logior type
- (ash (+ posn (component-header-length))
- (- type-bits word-shift)))))))
+ (lambda (segment posn)
+ (emit-lword segment
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
-(define-instruction function-header-word (segment)
+(define-instruction simple-fun-header-word (segment)
(:cost 0)
(:emitter
- (emit-header-data segment function-header-type)))
+ (emit-header-data segment simple-fun-header-widetag)))
(define-instruction lra-header-word (segment)
(:cost 0)
(:emitter
- (emit-header-data segment return-pc-header-type)))
+ (emit-header-data segment return-pc-header-widetag)))
(defun emit-compute-inst (segment vop dst src label temp calc)
(declare (ignore temp))
(emit-chooser
;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
segment 12 3
- #'(lambda (segment posn delta-if-after)
- (let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst lda dst
- (funcall calc label posn 0)
- src))))
- t)))
- #'(lambda (segment posn)
- (assemble (segment vop)
- (flet ((se (x n)
- (let ((x (logand x (lognot (ash -1 n)))))
- (if (logbitp (1- n) x)
- (logior (ash -1 (1- n)) x)
- x))))
- (let* ((value (se (funcall calc label posn 0) 32))
- (low (ldb (byte 16 0) value))
- (tmp1 (- value (se low 16)))
- (high (ldb (byte 16 16) tmp1))
- (tmp2 (- tmp1 (se (ash high 16) 32)))
- (extra 0))
- (unless (= tmp2 0)
- (setf extra #x4000)
- (setf tmp1 (- tmp1 #x40000000))
- (setf high (ldb (byte 16 16) tmp1)))
- (inst lda dst low src)
- (inst ldah dst extra dst)
- (inst ldah dst high dst)))))))
+ (lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst lda dst
+ (funcall calc label posn 0)
+ src))))
+ t)))
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (flet ((se (x n)
+ (let ((x (logand x (lognot (ash -1 n)))))
+ (if (logbitp (1- n) x)
+ (logior (ash -1 (1- n)) x)
+ x))))
+ (let* ((value (se (funcall calc label posn 0) 32))
+ (low (ldb (byte 16 0) value))
+ (tmp1 (- value (se low 16)))
+ (high (ldb (byte 16 16) tmp1))
+ (tmp2 (- tmp1 (se (ash high 16) 32)))
+ (extra 0))
+ (unless (= tmp2 0)
+ (setf extra #x4000)
+ (setf tmp1 (- tmp1 #x40000000))
+ (setf high (ldb (byte 16 16) tmp1)))
+ (inst lda dst low src)
+ (inst ldah dst extra dst)
+ (inst ldah dst high dst)))))))
;; code = fn - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- other-pointer-type
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; = lra - (header + label-offset)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ (lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))