Commit 0bef43c3 authored by rtoy's avatar rtoy
Browse files

Move the GET-FP-OPERANDS stuff from compiler/sparc/float.lisp to

code/sparc-svr4-vm.lisp, which is probably where it all belonged
originally.   This gets rid of some errors (about the alien struct FPQ
being undefined) during sparc cross-compiles.
parent b182e46d
Loading
Loading
Loading
Loading
+67 −1
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.9 2007/03/20 18:21:38 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.10 2008/04/22 20:18:01 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -409,3 +409,69 @@

;;; Enable/Disable scavenging of the read-only space.
(defvar *scavenge-read-only-space* nil)

(defun get-fp-fault-info (scp)
  (declare (type (alien (* sigcontext)) scp))
  ;; The FPQ structure in the context has the faulting FP address and
  ;; the faulting FP instruction.  Return both.
  (let ((fpq (alien:sap-alien
	      (with-alien ((scp (* sigcontext) scp))
		(slot scp 'fpq))
	      (* fpq))))
    (with-alien ((fpq (* fpq) fpq))
      (values (slot fpq 'fpq-addr)
	      (slot fpq 'fpq-inst)))))
    
(defun get-fp-operation (scp)
  (declare (type (alien (* sigcontext)) scp))
  ;; Get the offending FP instruction from the context.  We return the
  ;; operation associated with the FP instruction, the precision of
  ;; the operation, and the operands of the instruction.
  (multiple-value-bind (addr opcode)
      (get-fp-fault-info scp)
    (declare (ignore addr))
    (let* ((format (ldb (byte 2 30) opcode))
	   (op3 (ldb (byte 6 19) opcode))
	   (rs1 (ldb (byte 5 14) opcode))
	   (opf (ldb (byte 8  5) opcode))
	   (rs2 (ldb (byte 5  0) opcode)))
      ;; Handle only the ones we know about.
      (unless (and (= format #b10) (= op3 #b110100))
	(return-from get-fp-operation (values nil nil nil nil)))
      (let ((fop (case (ldb (byte 6 2) opf)
		   (#b0010000 '+)
		   (#b0010001 '-)
		   (#b0010010 '*)
		   (#b0010011 '/)
		   (#b0001010
		    ;; The fsqrt instruction only uses the rs2 field.
		    (setf rs1 nil)
		    'sqrt)))
	    (format (case (ldb (byte 2 0) opf)
		      (#b01 'single-float)
		      (#b10 'double-float)
		      (#b11 'long-float))))
	(flet ((fix-up-reg-index (index)
		 (if (eq format 'single-float)
		     index
		     (when index
		       ;; For double-float (and long-float), the
		       ;; register is coded in a special way since the
		       ;; register address must be even, but we only
		       ;; have 5 bits to encode the register.  Hence the
		       ;; LSB is used to indicate the upper 32
		       ;; registers.
		       (+ (ash (logand index 1) 5)
			  (ash (ldb (byte 4 1) index) 1))))))
	  (values fop format (fix-up-reg-index rs1) (fix-up-reg-index rs2)))))))

(defun get-fp-operands (scp modes)
  (declare (type (alien (* sigcontext)) scp)
	   (ignore modes))
  ;; From the offending FP instruction, get the operation and
  ;; operands, if we can.
  (multiple-value-bind (fop format rs1 rs2)
      (get-fp-operation scp)
    (let ((fs1 (and fop rs1 (sigcontext-float-register scp rs1 format)))
	  (fs2 (and fop rs2 (sigcontext-float-register scp rs2 format))))
      (values fop (remove nil (list fs1 fs2))))))
+2 −71
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.55 2007/05/29 15:01:34 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.56 2008/04/22 20:18:01 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -2877,77 +2877,8 @@




(in-package "SPARC")
(export 'get-fp-operands)


(defun get-fp-fault-info (scp)
  (declare (type (alien (* sigcontext)) scp))
  ;; The FPQ structure in the context has the faulting FP address and
  ;; the faulting FP instruction.  Return both.
  (let ((fpq (alien:sap-alien
	      (with-alien ((scp (* sigcontext) scp))
		(slot scp 'fpq))
	      (* fpq))))
    (with-alien ((fpq (* fpq) fpq))
      (values (slot fpq 'fpq-addr)
	      (slot fpq 'fpq-inst)))))
    
(defun get-fp-operation (scp)
  (declare (type (alien (* sigcontext)) scp))
  ;; Get the offending FP instruction from the context.  We return the
  ;; operation associated with the FP instruction, the precision of
  ;; the operation, and the operands of the instruction.
  (multiple-value-bind (addr opcode)
      (get-fp-fault-info scp)
    (declare (ignore addr))
    (let* ((format (ldb (byte 2 30) opcode))
	   (op3 (ldb (byte 6 19) opcode))
	   (rs1 (ldb (byte 5 14) opcode))
	   (opf (ldb (byte 8  5) opcode))
	   (rs2 (ldb (byte 5  0) opcode))
	   )
      ;; Handle only the ones we know about.
      (unless (and (= format #b10) (= op3 #b110100))
	(return-from get-fp-operation (values nil nil nil nil)))
      (let ((fop (case (ldb (byte 6 2) opf)
		   (#b0010000 '+)
		   (#b0010001 '-)
		   (#b0010010 '*)
		   (#b0010011 '/)
		   (#b0001010
		    ;; The fsqrt instruction only uses the rs2 field.
		    (setf rs1 nil)
		    'sqrt)))
	    (format (case (ldb (byte 2 0) opf)
		      (#b01 'single-float)
		      (#b10 'double-float)
		      (#b11 'long-float))))
	(flet ((fix-up-reg-index (index)
		 (if (eq format 'single-float)
		     index
		     (when index
		       ;; For double-float (and long-float), the
		       ;; register is coded in a special way since the
		       ;; register address must be even, but we only
		       ;; have 5 bits to encode the register.  Hence the
		       ;; LSB is used to indicate the upper 32
		       ;; registers.
		       (+ (ash (logand index 1) 5)
			  (ash (ldb (byte 4 1) index) 1))))))
	  (values fop format (fix-up-reg-index rs1) (fix-up-reg-index rs2)))))))

(defun get-fp-operands (scp modes)
  (declare (type (alien (* sigcontext)) scp)
	   (ignore modes))
  ;; From the offending FP instruction, get the operation and
  ;; operands, if we can.
  (multiple-value-bind (fop format rs1 rs2)
      (get-fp-operation scp)
    (let ((fs1 (and fop rs1 (sigcontext-float-register scp rs1 format)))
	  (fs2 (and fop rs2 (sigcontext-float-register scp rs2 format))))
      (values fop (remove nil (list fs1 fs2))))))


;;; Support for double-double floats