From 147cf2143f314cbb8da84c3b001379db90e1a72e Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Tue, 1 Apr 2003 21:19:24 +0000
Subject: [PATCH] o Add the prxregset structure and add support for the V8+ ABI
 changes   to the sigcontext. o Enable reading the extra FP registers and the
 high 32-bits of the %g   and %o registers for V8+ ABI. o Change MACHINE-TYPE
 and MACHINE-VERSION to say Ultrasparc instead of   SPARCstation when compiled
 for :sparc-v9.

---
 code/sparc-svr4-vm.lisp | 113 +++++++++++++++++++++++++++++++++-------
 1 file changed, 94 insertions(+), 19 deletions(-)

diff --git a/code/sparc-svr4-vm.lisp b/code/sparc-svr4-vm.lisp
index 1740cab39..e09fe3cd2 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.5 2002/10/24 20:38:57 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.6 2003/04/01 21:19:24 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -33,11 +33,40 @@
     (ss-size unsigned-long)
     (ss-flags unsigned-long)))
 
-; In the include files this structure consists of 3 structures:
-; struct ucontext, that includes struct mcontext which includes; struct fpu.
-; Because the fpu structure contains doubles, it must be aligned on
-; 8 byte bounderies, consequently so must struct mcontext and struct
-; ucontext.
+;; The prxregset structure for the extra register info for V8+.  See
+;; struct prxregset in procfs_isa.h.
+
+(def-alien-type prxregset
+    (struct prxregset
+      (pr-type unsigned-long)
+      (pr-align unsigned-long)
+      ;; The pr_v8p
+      (pr-xfr
+       (union pr-xfr
+	;; Extra FP registers
+	(pr-regs (array unsigned-long 32))
+	(pr-dregs (array double-float 16))
+	#+long-float
+	(pr-qregs (array long-float 8))
+	))
+      (pr-xfsr unsigned-long)		; Upper 32 bits, FP state reg
+      (pr-fprs unsigned-long)		; FP registers state
+      ;; The upper parts of the %G and %O registers.  Hmm, should we
+      ;; treat this as just one array of 16 values, or two separate
+      ;; arrays of length 8 each?  The header file has them as two
+      ;; arrays.  But it's more convenient for us if it's one array of 16.
+      (pr-xgo (array unsigned-long 16))	; Upper 32 bits, G and O registers
+      (pr-tstate (array unsigned-long 2)) ; TSTATE register (really a 64-bit integer)
+      (pr-filler (array unsigned-long 8))))
+
+;; This means the XRS entry is valid.
+(defconstant +xrs-id-valid+ #x78727300)
+
+; 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
+; must be aligned on 8 byte bounderies, consequently so must struct
+; mcontext and struct ucontext.
 (def-alien-type sigcontext
   (struct nil
     (uc-flags unsigned-long)
@@ -45,7 +74,10 @@
     (uc-mask sigset)
     (uc-stack sigaltstack)
     (uc-pad unsigned-long)  ;; align on 8.
-    ; struct mcontext 
+    ;; struct mcontext (See sys/regset.h) regset defines this as
+    ;; several structs, but we've smashed them all together here.
+
+    ;; gregset begins here
     (uc-psr unsigned-long)
     (uc-pc system-area-pointer)
     (uc-npc system-area-pointer)
@@ -56,9 +88,10 @@
        (struct mcontext-regs
         (uc-y unsigned-long)
         (uc-fill1 (array unsigned-long 13)) ; %g1 - %g7 , %o0 - %o5
-        (uc-sp (* unsigned-long)) ; pointer to %l0 - %l7, %i0 - %i7
+        (uc-sp (* unsigned-long))	; pointer to %l0 - %l7, %i0 - %i7
         (uc-o7 unsigned-long)))))
-    (uc-windows system-area-pointer)	 ; usually nil
+    ;; gregset ends here
+    (uc-windows system-area-pointer)	; usually nil (possible pointer to register windows)
     ;; struct fpu, already aligned at 8 bytes in mcontext
     (fpregs (array unsigned-long 32))
     (fpq    system-area-pointer)
@@ -68,7 +101,11 @@
     (fpu-en unsigned-char)
     (fpu-sparc-pad unsigned-long)	; align length to 8.
     ;; end of struct fpu
-    (filler (array long 22))		; 21 from definition + 1 padding
+    ;; The XRS (extra register) structure
+    (xrs-id unsigned-long)		; #x78727300 if xrs-ptr is valid
+    (xrs-ptr (* prxregset))		; Points to the XRS
+    ;; End struct xrs
+    (filler (array long 19))		; 21 from definition + 1 padding - 2 for XRS
     ; end of mcontext
     (filler2 (array long 24))))		; 23 from def + 1 padding
 
@@ -90,11 +127,13 @@
 
 (defun machine-type ()
   "Returns a string describing the type of the local machine."
-  "SPARCstation")
+  #-sparc-v9 "SPARCstation"
+  #+sparc-v9 "Ultrasparc")
 
 (defun machine-version ()
   "Returns a string describing the version of the local machine."
-  "SPARCstation")
+  #-sparc-v9 "SPARCstation"
+  #+sparc-v9 "Ultrasparc")
 
 
 
@@ -222,9 +261,13 @@
     (if (zerop index)
 	0
 	(if (< index 16)
-	    (deref (slot (slot scp 'uc-regs) 'regs) index)
-	    (deref (slot (slot (slot scp 'uc-regs) 'regs2) 'uc-sp) (- index 16))
-	    ))))
+	    (let ((reg-value (deref (slot (slot scp 'uc-regs) 'regs) index)))
+	      (when (= (slot scp 'xrs-id) +xrs-id-valid+)
+		(let* ((prx (deref (slot scp 'xrs-ptr) 0))
+		       (hi-part (deref (slot prx 'pr-xgo) index)))
+		  (incf reg-value (ash hi-part 32))))
+	      reg-value)
+	    (deref (slot (slot (slot scp 'uc-regs) 'regs2) 'uc-sp) (- index 16))))))
 
 (defun %set-sigcontext-register (scp index new)
   (declare (type (alien (* sigcontext)) scp))
@@ -232,7 +275,13 @@
     (if (zerop index)
 	0
 	(if (< index 16)
-	    (setf (deref (slot (slot scp 'uc-regs) 'regs) index) new)
+	    (let ((low-part (ldb (byte 32 0) new)))
+	      (setf (deref (slot (slot scp 'uc-regs) 'regs) index) low-part)
+	      (when (= (slot scp 'xrs-id) +xrs-id-valid+)
+		(let* ((prx (deref (slot scp 'xrs-ptr) 0))
+		       (hi-reg (slot prx 'pr-xgo))
+		       (high-part (ldb (byte 32 32) new)))
+		  (setf (deref hi-reg index) high-part))))
 	    (setf (deref (slot (slot (slot scp 'uc-regs) 'regs2) 'uc-sp)
 			 (- index 16)) new))
 	))
@@ -246,13 +295,32 @@
 ;;; Like sigcontext-REGISTER, but returns the value of a float register.
 ;;; Format is the type of float to return.
 ;;;
+
 (defun sigcontext-float-register (scp index format)
   (declare (type (alien (* sigcontext)) scp))
   (with-alien ((scp (* sigcontext) scp))
     (let ((sap (alien-sap (slot scp 'fpregs))))
       (ecase format
-	(single-float (system:sap-ref-single sap (* index vm:word-bytes)))
-	(double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
+	(single-float
+	 (system:sap-ref-single sap (* index vm:word-bytes)))
+	(double-float
+	 ;; The indexing for double-float registers is different.  See
+	 ;; fp-reg-tn-encoding in sparc/insts.lisp for an explanation.
+	 ;; Briefly for double-float registers are even numbers, but
+	 ;; for registers above 30, the MSB if the number is stored in
+	 ;; the LSB.
+	 (cond ((< index 32)
+		(system:sap-ref-double sap (* index vm:word-bytes)))
+	       (t
+		;; The extra double-float registers for Sparc V8plus
+		;; ABI are stored in the pxregset structure.  (The
+		;; constant is the C string "xrs", in big-endian
+		;; order, of course.)
+		(unless (= (slot scp 'xrs-id) +xrs-id-valid+)
+		  (error "XRS ID invalid but attempting to accessing double-float register ~d!" (ash index 1)))
+		(let* ((xrs-ptr (slot scp 'xrs-ptr))
+		       (fp-sap (alien-sap (slot (slot (deref xrs-ptr 0) 'pr-xfr) 'pr-regs))))
+		  (system:sap-ref-double fp-sap (* (- index 32) vm:word-bytes))))))))))
 ;;;
 (defun %set-sigcontext-float-register (scp index format new-value)
   (declare (type (alien (* sigcontext)) scp))
@@ -262,7 +330,14 @@
 	(single-float
 	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
 	(double-float
-	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
+	 (cond ((< index 32)
+		(setf (sap-ref-double sap (* index vm:word-bytes)) new-value))
+	       (t
+		(unless (= (slot scp 'xrs-id) +xrs-id-valid+)
+		  (error "XRS ID invalid but attempting to accessing double-float register ~d!" (ash index 1)))
+		(let* ((xrs-ptr (slot scp 'xrs-ptr))
+		       (fp-sap (alien-sap (slot (slot (deref xrs-ptr 0) 'pr-xfr) 'pr-regs))))
+		  (setf (system:sap-ref-double fp-sap (* (- index 32) vm:word-bytes)) new-value)))))))))
 ;;;
 (defsetf sigcontext-float-register %set-sigcontext-float-register)
 
-- 
GitLab