X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Finsts.lisp;h=801be79e9cdb31c8ae4dcef9f00063b4af49b3f2;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=1da473038278ae2b830608ef2ce5ead78415149b;hpb=68fd2d2dd6f265669a8957accd8a33e62786a97e;p=sbcl.git diff --git a/src/compiler/sparc/insts.lisp b/src/compiler/sparc/insts.lisp index 1da4730..801be79 100644 --- a/src/compiler/sparc/insts.lisp +++ b/src/compiler/sparc/insts.lisp @@ -11,10 +11,9 @@ (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)) ;;; Constants, types, conversion functions, some disassembler stuff. (defun reg-tn-encoding (tn) @@ -33,9 +32,7 @@ (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. @@ -119,74 +116,6 @@ about function addresses and register values.") (- 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. @@ -201,6 +130,7 @@ about function addresses and register values.") (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. @@ -278,6 +208,7 @@ about function addresses and register values.") 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 @@ -327,9 +258,9 @@ about function addresses and register values.") (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) @@ -360,9 +291,9 @@ about function addresses and register values.") (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) @@ -383,7 +314,7 @@ about function addresses and register values.") (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 @@ -701,7 +632,8 @@ about function addresses and register values.") (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 @@ -764,7 +696,7 @@ about function addresses and register values.") (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) @@ -931,7 +863,7 @@ about function addresses and register values.") (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))) @@ -948,7 +880,7 @@ about function addresses and register values.") (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) @@ -1212,12 +1144,12 @@ about function addresses and register values.") ;; 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) @@ -1326,9 +1258,9 @@ about function addresses and register values.") (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 @@ -1345,8 +1277,8 @@ about function addresses and register values.") (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 @@ -1368,19 +1300,24 @@ about function addresses and register values.") ;; 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)) @@ -1392,10 +1329,8 @@ about function addresses and register values.") (: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) @@ -1403,10 +1338,17 @@ about function addresses and register values.") (: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)) @@ -1424,10 +1366,11 @@ about function addresses and register values.") ;; 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) @@ -1438,12 +1381,30 @@ about function addresses and register values.") (: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)) @@ -1464,8 +1425,8 @@ about function addresses and register values.") ;; 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) @@ -1474,10 +1435,15 @@ about function addresses and register values.") (: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 @@ -1620,7 +1586,11 @@ about function addresses and register values.") (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)) @@ -1639,8 +1609,8 @@ about function addresses and register values.") (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)