- (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))))
+ (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))))
- (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))))
+ (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))))
- (declare (type (signed-byte 21) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ (declare (type (signed-byte 21) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
(define-memory ldl #x28)
(define-memory ldq #x29)
(define-memory ldl_l #x2a)
(define-memory ldq_q #x2b)
(define-memory ldq_u #x0b)
(define-memory ldl #x28)
(define-memory ldq #x29)
(define-memory ldl_l #x2a)
(define-memory ldq_q #x2b)
(define-memory ldq_u #x0b)
(macrolet ((define-branch (name op &optional (float nil))
`(define-instruction ,name (segment ra target)
(macrolet ((define-branch (name op &optional (float nil))
`(define-instruction ,name (segment ra target)
- (emit-branch segment ,op
- ,@(if float
- '((fp-reg-tn-encoding ra))
+ (emit-branch segment ,op
+ ,@(if float
+ '((fp-reg-tn-encoding ra))
(define-operate s8addq #x10 #x32)
(define-operate s8subl #x10 #x1b)
(define-operate s8subq #x10 #x3b)
(define-operate s8addq #x10 #x32)
(define-operate s8subl #x10 #x1b)
(define-operate s8subq #x10 #x3b)
(define-operate and #x11 #x00)
(define-operate bic #x11 #x08)
(define-operate cmoveq #x11 #x24)
(define-operate and #x11 #x00)
(define-operate bic #x11 #x08)
(define-operate cmoveq #x11 #x24)
(define-operate eqv #x11 #x48)
(define-operate cmovle #x11 #x64)
(define-operate cmovgt #x11 #x66)
(define-operate eqv #x11 #x48)
(define-operate cmovle #x11 #x64)
(define-operate cmovgt #x11 #x66)
(define-operate sll #x12 #x39)
(define-operate extbl #x12 #x06)
(define-operate extwl #x12 #x16)
(define-operate sll #x12 #x39)
(define-operate extbl #x12 #x06)
(define-operate extwl #x12 #x16)
(define-operate mskqh #x12 #x72)
(define-operate zap #x12 #x30)
(define-operate zapnot #x12 #x31)
(define-operate mskqh #x12 #x72)
(define-operate zap #x12 #x30)
(define-operate zapnot #x12 #x31)
(define-operate mull #x13 #x00)
(define-operate mulq/v #x13 #x60)
(define-operate mull/v #x13 #x40)
(define-operate umulh #x13 #x30)
(define-operate mull #x13 #x00)
(define-operate mulq/v #x13 #x60)
(define-operate mull/v #x13 #x40)
(define-operate umulh #x13 #x30)
- (define-operate mulq #x13 #x20))
+ (define-operate mulq #x13 #x20)
+
+ (define-operate ctpop #x1c #x30) ; CIX extension
+ (define-operate ctlz #x1c #x32) ; CIX extension
+ (define-operate cttz #x1c #x33)) ; CIX extension
- (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 +su+ #x500) ; software, underflow enabled
+ (def!constant +sui+ #x700) ; software, inexact & underflow enabled
+ (def!constant +sv+ #x500) ; software, interger overflow enabled
(def!constant +sud+ #x5c0)
(def!constant +svid+ #x7c0)
(def!constant +suid+ #x7c0)
(def!constant +sud+ #x5c0)
(def!constant +svid+ #x7c0)
(def!constant +suid+ #x7c0)
(define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2)
(define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 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-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))
- (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 reg low zero-tn)
- (unless (= extra 0)
- (inst ldah reg extra reg))
- (unless (= high 0)
- (inst ldah reg high reg)))))
+ (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 reg low zero-tn)
+ (unless (= extra 0)
+ (inst ldah reg extra reg))
+ (unless (= high 0)
+ (inst ldah reg high reg)))))
((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
;; Since it took NJF and CSR a good deal of puzzling to work out
;; (a) what a previous version of this was doing and (b) why it
;; was wrong:
;;
((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
;; Since it took NJF and CSR a good deal of puzzling to work out
;; (a) what a previous version of this was doing and (b) why it
;; was wrong:
;;
;; + a_47 * 2^47 + a_32-46 * 2^32
;; + a_31 * 2^31 + a_16-30 * 2^16
;; + a_15 * 2^15 + a_0-14
;;
;; then, because of the wonders of sign-extension and
;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA
;; + a_47 * 2^47 + a_32-46 * 2^32
;; + a_31 * 2^31 + a_16-30 * 2^16
;; + a_15 * 2^15 + a_0-14
;;
;; then, because of the wonders of sign-extension and
;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA
;;
;; So we need to add that 65536 back on, which is what this
;; LOGBITP business is doing. The same applies for bits 31 and
;;
;; So we need to add that 65536 back on, which is what this
;; LOGBITP business is doing. The same applies for bits 31 and
;;
;; I think, anyway. -- CSR, 2003-09-26
(let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
;;
;; I think, anyway. -- CSR, 2003-09-26
(let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
- (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1))
- (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2)))
+ (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1))
+ (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2)))
(inst lda reg (ldb (byte 16 32) value2) zero-tn)
;; FIXME: Don't yet understand these conditionals. If I'm
;; right, surely we can just consider the zeroness of the
;; particular bitfield, not the zeroness of the whole thing?
;; -- CSR, 2003-09-26
(unless (= value3 0)
(inst lda reg (ldb (byte 16 32) value2) zero-tn)
;; FIXME: Don't yet understand these conditionals. If I'm
;; right, surely we can just consider the zeroness of the
;; particular bitfield, not the zeroness of the whole thing?
;; -- CSR, 2003-09-26
(unless (= value3 0)
(fixup
(inst lda reg value zero-tn :bits-47-32)
(inst ldah reg value reg :bits-63-48)
(inst sll reg 32 reg)
(inst lda reg value reg)
(inst ldah reg value reg))))
(fixup
(inst lda reg value zero-tn :bits-47-32)
(inst ldah reg value reg :bits-63-48)
(inst sll reg 32 reg)
(inst lda reg value reg)
(inst ldah reg value reg))))
(lambda (segment posn delta-if-after)
(let ((delta (funcall calc label posn delta-if-after)))
(when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
(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)))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst lda dst
+ (funcall calc label posn 0)
+ src))))
+ t)))
- (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)))))))
+ (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)
;; code = fn - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment dst src label temp)
- (lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- (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)
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; = lra - (header + label-offset)
- (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)
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment 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))))))