diff --git a/code/sparc-svr4-vm.lisp b/code/sparc-svr4-vm.lisp index ea805f9a44b54fcd017aaecd340c0e57515fe4d8..57e4cc7c15111089f317c45be86e30ba2bbcac02 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.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)))))) diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp index 2ad30e765526e226f5ef5ec8c3d9a0d4305bc345..90cdebfd7d6eadaf1fa4284e1e696bf7f50490f4 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.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