From 39072d554baa7fba8c68722b930fe73ddf5760c1 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 14 Nov 2006 04:49:05 +0000
Subject: [PATCH] Implement GET-FP-OPERANDS so that more information can be
 printed out during arithmetic errors.

---
 compiler/ppc/float.lisp | 53 ++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 52 insertions(+), 1 deletion(-)

diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp
index 1b0a8d47e..5ecbd03bf 100644
--- a/compiler/ppc/float.lisp
+++ b/compiler/ppc/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.7 2006/07/01 13:52:48 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.8 2006/11/14 04:49:05 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1364,3 +1364,54 @@
   (:variant :imag))
 
 ); progn
+
+
+(in-package "VM")
+(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 at the offending FP instruction.
+	 (opcode (sap-ref-32 pc 0))
+	 (format (ldb (byte 6 26) opcode))
+	 (ra (ldb (byte 5 16) opcode))
+	 (op (ldb (byte 5 1) opcode)))
+    #+nil
+    (progn
+      (format t "pc     = ~A~%" pc)
+      (format t "opcode = #x~8,'0x~%" opcode)
+      (format t "format = ~D~%" format)
+      (format t "ra     = ~D~%" ra)
+      (format t "op     = ~D~%" op))
+    ;; Handle only the ones we know about.
+    (unless (and (member format '(59 63))
+		 (member op '(21 18 25 20)))
+      (return-from get-fp-operation (values nil nil nil nil)))
+    (multiple-value-bind (fop rb)
+	(case op
+	  (21
+	   (values '+ (ldb (byte 5 11) opcode)))
+	  (20
+	   (values '- (ldb (byte 5 11) opcode)))
+	  (25
+	   (values '* (ldb (byte 5 6) opcode)))
+	  (18
+	   (values '/ (ldb (byte 5 11) opcode))))
+      (let ((format (case format
+		      (59 'single-float)
+		      (63 'double-float))))
+	(values fop format ra rb)))))
+
+(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