(in-package "SB!VM")
-;;;FIXME: the analogue is commented out in alpha/insts.lisp
-;;;(def-assembler-params
-;;; :scheduler-p t
-;;; :max-locations 100)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf sb!assem:*assem-scheduler-p* t)
+ (setf sb!assem:*assem-max-locations* 100))
\f
;;; Constants, types, conversion functions, some disassembler stuff.
(defun reg-tn-encoding (tn)
(error "~S isn't a floating-point register." tn))
(let ((offset (tn-offset tn)))
(cond ((> offset 31)
- ;; Use the sparc v9 double float register encoding.
- #!-:sparc-v9 (error ":sparc-v9 should be on the target features")
- ;; (assert (backend-featurep :sparc-v9))
+ (assert (member :sparc-v9 *backend-subfeatures*))
;; No single register encoding greater than reg 31.
(assert (zerop (mod offset 2)))
;; Upper bit of the register number is encoded in the low bit.
(- val (ash 1 13))
val))
-;;; Oh, come on, this is ridiculous. I'm not going to solve
-;;; bootstrapping issues for a disassembly note. Does this make me
-;;; lazy? Christophe, 2001-09-02. FIXME
-#+nil
-(macrolet
- ((frob (&rest names)
- (let ((results (mapcar (lambda (n)
- (let ((nn (intern (concatenate 'string (string n)
- "-TYPE"))))
- `(,(eval nn) ,nn)))
- names)))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant header-word-type-alist
- ',results)))))
- ;; This is the same list as in objdefs.
- (frob bignum
- ratio
- single-float
- double-float
- #!+long-float long-float
- complex
- complex-single-float
- complex-double-float
- #!+long-float complex-long-float
-
- simple-array
- simple-string
- simple-bit-vector
- simple-vector
- simple-array-unsigned-byte-2
- simple-array-unsigned-byte-4
- simple-array-unsigned-byte-8
- simple-array-unsigned-byte-16
- simple-array-unsigned-byte-32
- simple-array-signed-byte-8
- simple-array-signed-byte-16
- simple-array-signed-byte-30
- simple-array-signed-byte-32
- simple-array-single-float
- simple-array-double-float
- #!+long-float simple-array-long-float
- simple-array-complex-single-float
- simple-array-complex-double-float
- #!+long-float simple-array-complex-long-float
- complex-string
- complex-bit-vector
- complex-vector
- complex-array
-
- code-header
- function-header
- closure-header
- funcallable-instance-header
- byte-code-function
- byte-code-closure
- closure-function-header
- #!-gengc return-pc-header
- #!+gengc forwarding-pointer
- value-cell-header
- symbol-header
- base-char
- sap
- unbound-marker
- weak-pointer
- instance-header
- fdefn
- #!+(or gengc gencgc) scavenger-hook))
-
;; Look at the current instruction and see if we can't add some notes
;; about what's happening.
(rd (ldb (byte 5 25) word))
(immed-p (not (zerop (ldb (byte 1 13) word))))
(immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
+ (declare (ignore immed-p))
;; Only the value of format and rd are guaranteed to be correct
;; because the disassembler is trying to print out the value of a
;; register. The other values may not be right.
dstate)))))))
(defun handle-jmpl-inst (rs1 immed-val rd dstate)
+ (declare (ignore rd))
(let* ((sethi (assoc rs1 *note-sethi-inst*)))
(when sethi
;; RS1 was used in a SETHI instruction. Assume that
(maybe-add-notes value dstate))))
(defparameter float-reg-symbols
- (coerce
- (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
- 'vector))
+ #.(coerce
+ (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
+ 'vector))
(sb!disassem:define-arg-type fp-reg
:printer (lambda (value stream dstate)
(sb!disassem:define-arg-type relative-label
:sign-extend t
:use-label (lambda (value dstate)
- (declare (type (signed-byte 13) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ (declare (type (signed-byte 22) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
(defconstant-eqx branch-conditions
'(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
(error "Unknown branch condition: ~S~%Must be one of: ~S"
condition branch-conditions)))
-(defconstant branch-cond-true
+(def!constant branch-cond-true
#b1000)
(defconstant-eqx branch-fp-conditions
(defun cond-move-condition (condition-reg)
(or (position condition-reg cond-move-condition-registers)
- (error "Unknown conditional move condition register: ~S~%")))
+ (error "Unknown conditional move condition register: ~S~%"
+ condition-reg)))
(defconstant-eqx cond-move-printer
`(:name cond :tab
(defun register-condition (rcond)
(or (position rcond cond-move-integer-conditions)
- (error "Unknown register condition: ~S~%")))
+ (error "Unknown register condition: ~S~%" rcond)))
(sb!disassem:define-instruction-format
(format-4-cond-move-integer 32 :default-printer cond-move-integer-printer)
(eval-when (:compile-toplevel :execute)
-;;; have to do this because defconstant is evalutated in the null lex env.
+;;; have to do this because def!constant is evalutated in the null lex env.
(defmacro with-ref-format (printer)
`(let* ((addend
'(:choose (:plus-integer immed) ("+" rs2)))
(with-ref-format `(:NAME :TAB rd ", " ,ref-format))
#'equalp)
-) ; eval-when (compile eval)
+) ; EVAL-WHEN
(macrolet ((define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
(printer :default) reads writes flushable print-name)
;; registers.
(define-instruction rdy (segment dst)
(:declare (type tn dst))
- (:printer format-3-immed ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
+ (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
'('RD :tab '%Y ", " rd))
(:dependencies (reads :y) (writes dst))
(:delay 0)
- (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
- 0 0 0)))
+ (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b101000
+ 0 0 0 0)))
(defconstant-eqx wry-printer
'('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
(error "Offset of BA must be positive"))
offset)))))
-#!+sparc-v9
(defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
(declare (type integer-condition-register cc))
+ (assert (member :sparc-v9 *backend-subfeatures*))
(emit-back-patch segment 4
(lambda (segment posn)
(unless target
(error "Offset of BA must be positive"))
offset)))))
-#!+sparc-v9
(defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
+ (assert (member :sparc-v9 *backend-subfeatures*))
(emit-back-patch segment 4
(lambda (segment posn)
(unless target
;; just get translated to the branch with prediction
;; instructions. However, the disassembler uses the correct V9
;; mnemonic.
-#!-sparc-v9
-(define-instruction b (segment cond-or-target &optional target)
- (:declare (type (or label branch-condition) cond-or-target)
- (type (or label null) target))
+(define-instruction b (segment cond-or-target &rest args)
+ (:declare (type (or label branch-condition) cond-or-target))
(:printer format-2-branch ((op #b00) (op2 #b010)))
(:attributes branch)
(:dependencies (reads :psr))
(:delay 1)
(:emitter
- (emit-relative-branch segment 0 #b010 cond-or-target target)))
-
-#!+sparc-v9
-(define-instruction b (segment cond-or-target &optional target pred cc)
+ (cond
+ ((member :sparc-v9 *backend-subfeatures*)
+ (destructuring-bind (&optional target pred cc) args
+ (declare (type (or label null) target))
+ (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+ (t
+ (destructuring-bind (&optional target) args
+ (declare (type (or label null) target))
+ (emit-relative-branch segment 0 #b010 cond-or-target target))))))
+
+(define-instruction bp (segment cond-or-target &optional target pred cc)
(:declare (type (or label branch-condition) cond-or-target)
(type (or label null) target))
(:printer format-2-branch-pred ((op #b00) (op2 #b001))
(:emitter
(emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
-#!-sparc-v9
-(define-instruction ba (segment cond-or-target &optional target)
- (:declare (type (or label branch-condition) cond-or-target)
- (type (or label null) target))
+(define-instruction ba (segment cond-or-target &rest args)
+ (:declare (type (or label branch-condition) cond-or-target))
(:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
nil
:print-name 'b)
(:dependencies (reads :psr))
(:delay 0)
(:emitter
- (emit-relative-branch segment 1 #b010 cond-or-target target)))
-
-#!+sparc-v9
-(define-instruction ba (segment cond-or-target &optional target pred cc)
+ (cond
+ ((member :sparc-v9 *backend-subfeatures*)
+ (destructuring-bind (&optional target pred cc) args
+ (declare (type (or label null) target))
+ (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+ (t
+ (destructuring-bind (&optional target) args
+ (declare (type (or label null) target))
+ (emit-relative-branch segment 1 #b010 cond-or-target target))))))
+
+(define-instruction bpa (segment cond-or-target &optional target pred cc)
(:declare (type (or label branch-condition) cond-or-target)
(type (or label null) target))
(:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
;; Definition 2.4.1 says only trap numbers 16-31 are allowed for user
;; code. All other trap numbers have other uses. The restriction on
;; target will prevent us from using bad trap numbers by mistake.
-#!-sparc-v9
-(define-instruction t (segment condition target)
+
+(define-instruction t (segment condition target &optional cc)
(:declare (type branch-condition condition)
- ;; KLUDGE
+ ;; KLUDGE: see comments in vm.lisp regarding
+ ;; pseudo-atomic-trap.
#!-linux
(type (integer 16 31) target))
(:printer format-3-immed ((op #b10)
(:attributes branch)
(:dependencies (reads :psr))
(:delay 0)
- (:emitter (emit-format-3-immed segment #b10 (branch-condition condition)
- #b111010 0 1 target)))
-
-#!+sparc-v9
-(define-instruction t (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
+ (:emitter
+ (cond
+ ((member :sparc-v9 *backend-subfeatures*)
+ (unless cc
+ (setf cc :icc))
+ (emit-format-4-trap segment
+ #b10
+ (branch-condition condition)
+ #b111010 0 1
+ (integer-condition cc)
+ target))
+ (t
+ (assert (null cc))
+ (emit-format-3-immed segment #b10 (branch-condition condition)
+ #b111010 0 1 target)))))
+
+;;; KLUDGE: we leave this commented out, as these two (T and TCC)
+;;; operations are actually indistinguishable from their bitfields,
+;;; breaking the disassembler if these are left in. The printer isn't
+;;; terribly smart, but the emitted code is right. - CSR, 2002-08-04
+#+nil
+(define-instruction tcc (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
(:declare (type branch-condition condition)
+ ;; KLUDGE: see above.
#!-linux
(type (integer 16 31) target)
(type integer-condition-register cc))
;; Same as for the branch instructions. On the Sparc V9, we will use
;; the FP branch with prediction instructions instead.
-#!-sparc-v9
-(define-instruction fb (segment condition target)
+
+(define-instruction fb (segment condition target &rest args)
(:declare (type fp-branch-condition condition) (type label target))
(:printer format-2-branch ((op #B00)
(cond nil :type 'branch-fp-condition)
(:dependencies (reads :fsr))
(:delay 1)
(:emitter
- (emit-relative-branch segment 0 #b110 condition target t)))
-
-#!+sparc-v9
-(define-instruction fb (segment condition target &optional fcc pred)
+ (cond
+ ((member :sparc-v9 *backend-subfeatures*)
+ (destructuring-bind (&optional fcc pred) args
+ (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
+ (t
+ (assert (null args))
+ (emit-relative-branch segment 0 #b110 condition target t)))))
+
+(define-instruction fbp (segment condition target &optional fcc pred)
(:declare (type fp-branch-condition condition) (type label target))
(:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
fp-branch-pred-printer
(reads src2)
(writes :fsr))
;; The Sparc V9 doesn't need a delay after a FP compare.
- (:delay #!-sparc-v9 1 #!+sparc-v9 0)
+ ;;
+ ;; KLUDGE FIXME YAARGH -- how to express that? I guess for now we
+ ;; do the worst case, and hope to fix it.
+ ;; (:delay #-sparc-v9 1 #+sparc-v9 0)
+ (:delay 1)
(:emitter
(emit-format-3-fpop2 segment #b10
(or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
(define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t) ; v9
- ;; I (toy@rtp.ericsson.se) don't think these f{sd}toir instructions
- ;; exist on any Ultrasparc, but I only have a V9 manual. The code in
+ ;; I (Raymond Toy) don't think these f{sd}toir instructions exist on
+ ;; any Ultrasparc, but I only have a V9 manual. The code in
;; float.lisp seems to indicate that they only existed on non-sun4
;; machines (sun3 68K machines?).
(define-unary-fp-inst fstoir #b011000001 :reads :fsr)
projects / sbcl.git / blobdiff