From 81879632d61b81f562f5d20fce79a63a870f97e0 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Tue, 1 Apr 2003 21:22:20 +0000
Subject: [PATCH] Add functions to extract out the operation and args of a
 floating-point instruction from a sigcontext.

---
 compiler/sparc/float.lisp | 62 ++++++++++++++++++++++++++++++++++++++-
 1 file changed, 61 insertions(+), 1 deletion(-)

diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
index f35274bb2..faca965fc 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))))))
-- 
GitLab