From 9fde59c0e56e9982c0fa96643341975962d3fe81 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 20 Mar 2007 18:21:39 +0000
Subject: [PATCH] Was not getting the right instruction for the faulting
 floating-point exception.

This was happening when the faulting FP instruction was in the delay
slot of a branch.  The PC was incremented to the branch target, and
hence had the wrong information.  The FPQ structure has the right
information.

code/sparc-svr4-vm.lisp:
o Add FPQ structure so we can access the information about the
  faulting FP instruction.

compiler/sparc/float.lisp:
o Extract the correct information about the faulting FP instruction
  instead of from the PC.
---
 code/sparc-svr4-vm.lisp   |  9 +++-
 compiler/sparc/float.lisp | 92 ++++++++++++++++++++++-----------------
 2 files changed, 60 insertions(+), 41 deletions(-)

diff --git a/code/sparc-svr4-vm.lisp b/code/sparc-svr4-vm.lisp
index 3cff4b5b3..ea805f9a4 100644
--- a/code/sparc-svr4-vm.lisp
+++ b/code/sparc-svr4-vm.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/code/sparc-svr4-vm.lisp,v 1.8 2006/01/03 17:58:20 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.9 2007/03/20 18:21:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -62,6 +62,13 @@
 ;; This means the XRS entry is valid.
 (defconstant +xrs-id-valid+ #x78727300)
 
+(def-alien-type fpq
+  (struct nil
+    ;; Address of faulting FP instruction
+    (fpq-addr system-area-pointer)
+    ;; The instruction itself
+    (fpq-inst c-call:unsigned-long)))
+
 ; In the include files (sys/ucontext.h) this structure consists of 3
 ; structures: struct ucontext, that includes struct mcontext which
 ; includes; struct fpu. Because the fpu structure contains doubles, it
diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
index f8fc0b27f..9e3cc9eed 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.47 2006/11/16 15:37:04 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.48 2007/03/20 18:21:39 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2869,50 +2869,62 @@
 (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.
-  (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))))))
+  (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)
-- 
GitLab