diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp index f35274bb20cbd3352612a10253a5d6f2a3876c1e..faca965fcc71ea2d71c0e55e6df53ee371d51c86 100644 --- a/compiler/sparc/float.lisp +++ b/compiler/sparc/float.lisp @@ -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.37 2002/11/26 15:50:58 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.38 2003/04/01 21:22:20 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2643,3 +2643,63 @@ ) + + + +(in-package "SPARC") +(export 'get-fp-operands) + +(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. + (let* ((pc (sigcontext-program-counter scp)) + ;; The trap seems to happen just after the offending FP + ;; instruction, so back up one. + (opcode (sap-ref-32 pc -4)) + (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) + (declare (type (alien (* sigcontext)) scp)) + ;; 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))))))