X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Finsts.lisp;h=bc91214fa338e71795ea5a4c903c1b1e2fcd1112;hb=a4c3562138e342465826de31fb8c324ae8a4b594;hp=098dfaa5c34b8a2e973427cae6e7b8100d5173a3;hpb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;p=sbcl.git diff --git a/src/compiler/alpha/insts.lisp b/src/compiler/alpha/insts.lisp index 098dfaa..bc91214 100644 --- a/src/compiler/alpha/insts.lisp +++ b/src/compiler/alpha/insts.lisp @@ -49,44 +49,44 @@ (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))) - '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 + #.(coerce + (loop for n from 0 to 31 collect (make-symbol (format nil "~D" n))) + 'vector)) + +(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)))) @@ -199,11 +199,15 @@ disp))))) (define-memory lda #x08 :lda) (define-memory ldah #x09 :ldah) + (define-memory ldbu #x0a) ; BWX extension + (define-memory ldwu #x0c) ; BWX extension (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 stw #x0d) ; BWX extension + (define-memory stb #x0e) ; BWX extension (define-memory stl #x2c) (define-memory stq #x2d) (define-memory stl_c #x2e) @@ -244,14 +248,14 @@ '((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) @@ -357,7 +361,11 @@ (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 (macrolet ((define-fp-operate (name op fn &optional (args 3)) @@ -409,19 +417,24 @@ (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)) @@ -437,6 +450,9 @@ (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 @@ -487,10 +503,36 @@ (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: + ;; + ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48 + ;; + 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 + ;; (which sign-extends its argument) will add + ;; + ;; (a_15 * 2^15 + a_0-14 - 65536). + ;; + ;; So we need to add that 65536 back on, which is what this + ;; LOGBITP business is doing. The same applies for bits 31 and + ;; 47 (bit 63 is taken care of by the fact that all of this + ;; arithmetic is mod 2^64 anyway), but we have to be careful that + ;; we consider the altered value, not the original value. + ;; + ;; I think, anyway. -- CSR, 2003-09-26 (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1)) - (value3 (if (logbitp 47 value) (+ value (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 ldah reg (ldb (byte 16 48) value3) reg)) (unless (and (= value2 0) (= value3 0)) @@ -533,57 +575,57 @@ (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 simple-fun-header-word (segment) (:cost 0) (:emitter - (emit-header-data segment simple-fun-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) @@ -591,10 +633,10 @@ (: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) @@ -603,9 +645,9 @@ (: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) @@ -613,6 +655,6 @@ (: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))))))