From 4283cbdaf205cae8b6d08f6ad5c163901cbdbbf4 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren>
Date: Wed, 29 Jun 1994 21:42:02 +0000
Subject: [PATCH] Initial revision

---
 code/irix-os.lisp |  75 +++++++++++++++
 code/sgi-vm.lisp  | 227 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 302 insertions(+)
 create mode 100644 code/irix-os.lisp
 create mode 100644 code/sgi-vm.lisp

diff --git a/code/irix-os.lisp b/code/irix-os.lisp
new file mode 100644
index 000000000..eddaee3d1
--- /dev/null
+++ b/code/irix-os.lisp
@@ -0,0 +1,75 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irix-os.lisp,v 1.1 1994/06/29 21:41:11 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; OS interface functions for CMU CL under IRIX.
+;;;
+;;;
+(in-package "SYSTEM")
+(use-package "EXTENSIONS")
+(export '(get-system-info get-page-size os-init))
+
+(pushnew :irix *features*)
+(setq *software-type* "IRIX")
+
+(defvar *software-version* nil "Version string for supporting software")
+
+(defun software-version ()
+  "Returns a string describing version of the supporting software."
+  (unless *software-version*
+    (setf *software-version*
+          (let ((version-line
+                 (with-output-to-string (stream)
+                   (run-program "/usr/bin/uname"
+                                '("-r" )
+                                :output stream
+                                :pty nil
+                                :error nil))))
+            (subseq version-line 0 (1- (length version-line))))))
+  *software-version*)
+
+
+;;; OS-INIT -- interface.
+;;;
+;;; Other OS dependent initializations.
+;;; 
+(defun os-init ()
+  ;; Decache version on save, because it might not be the same when we restart.
+  (setf *software-version* nil))
+
+;;; GET-SYSTEM-INFO  --  Interface
+;;;
+;;;    Return system time, user time and number of page faults.
+;;;
+(defun get-system-info ()
+  (multiple-value-bind
+      (err? utime stime maxrss ixrss idrss isrss minflt majflt)
+      (unix:unix-getrusage unix:rusage_self)
+    (declare (ignore maxrss ixrss idrss isrss minflt))
+    (cond ((null err?)
+	   (error "Unix system call getrusage failed: ~A."
+		  (unix:get-unix-error-msg utime)))
+	  (T
+	   (values utime stime majflt)))))
+
+
+;;; GET-PAGE-SIZE  --  Interface
+;;;
+;;;    Return the system page size.
+;;;
+(defun get-page-size ()
+  (multiple-value-bind (val err)
+		       (unix:unix-getpagesize)
+    (unless val
+      (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err)))
+    val))
+
diff --git a/code/sgi-vm.lisp b/code/sgi-vm.lisp
new file mode 100644
index 000000000..405bee188
--- /dev/null
+++ b/code/sgi-vm.lisp
@@ -0,0 +1,227 @@
+;;; -*- Package: MIPS -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sgi-vm.lisp,v 1.1 1994/06/29 21:42:02 hallgren Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sgi-vm.lisp,v 1.1 1994/06/29 21:42:02 hallgren Exp $
+;;;
+;;; This file contains the SGI specific runtime stuff.
+;;;
+(in-package "MIPS")
+(use-package "SYSTEM")
+(use-package "ALIEN")
+(use-package "C-CALL")
+(use-package "UNIX")
+
+(export '(fixup-code-object internal-error-arguments
+	  sigcontext-program-counter sigcontext-register
+	  sigcontext-float-register sigcontext-floating-point-modes
+	  extern-alien-name sanctify-for-execution))
+
+
+;;;; The sigcontext structure.
+
+(def-alien-type sigcontext
+  (struct nil
+    (sc-regmask unsigned-int)
+    (sc-status unsigned-int)
+    (sc-pc-high unsigned-int)
+    (sc-pc system-area-pointer)
+    (sc-regs (array unsigned-int 64)) ; 64 bit slots, so deref (* 2)+1
+    (sc-fpregs (array unsigned-int 64))
+    (sc-ownedfp unsigned-int)
+    (sc-fpc-csr unsigned-int)
+    (sc-fpc-eir unsigned-int)
+    (sc-ssflags unsigned-int)
+    (sc-mdhi-high unsigned-int)
+    (sc-mdhi unsigned-int)
+    (sc-mdlo-high unsigned-int)
+    (sc-mdlo unsigned-int)
+    (sc-cause-high unsigned-int)
+    (sc-cause unsigned-int)
+    (sc-badvaddr-high unsigned-int)
+    (sc-badvaddr system-area-pointer)
+    (sc-triggersave-high unsigned-int)
+    (sc-triggersave unsigned-int)
+    (sc-sigset (array unsigned-int 4))
+    (sc-pad (array unsigned-int 64))))
+
+
+;;;; Add machine specific features to *features*
+
+(pushnew :sgi *features*)
+
+
+
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+  "Returns a string describing the type of the local machine."
+  "SGI")
+
+(defun machine-version ()
+  "Returns a string describing the version of the local machine."
+  "SGI")
+
+
+
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset fixup kind)
+  (unless (zerop (rem offset word-bytes))
+    (error "Unaligned instruction?  offset=#x~X." offset))
+  (system:without-gcing
+   (let ((sap (truly-the system-area-pointer
+			 (%primitive c::code-instructions code))))
+     (ecase kind
+       (:jump
+	(assert (zerop (ash fixup -28)))
+	(setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
+	      (ash fixup -2)))
+       (:lui
+	(setf (sap-ref-16 sap (+ offset 2))
+	      (+ (ash fixup -16)
+		 (if (logbitp 15 fixup) 1 0))))
+       (:addi
+	(setf (sap-ref-16 sap (+ offset 2))
+	      (ldb (byte 16 0) fixup)))))))
+
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- interface.
+;;;
+;;; Given the sigcontext, extract the internal error arguments from the
+;;; instruction stream.
+;;; 
+(defun internal-error-arguments (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((pc (slot scp 'sc-pc)))
+      (declare (type system-area-pointer pc))
+      (when (logbitp 31 (slot scp 'sc-cause))
+	(setf pc (sap+ pc 4)))
+      (when (= (sap-ref-8 pc 4) 255)
+	(setf pc (sap+ pc 1)))
+      (let* ((length (sap-ref-8 pc 4))
+	     (vector (make-array length :element-type '(unsigned-byte 8))))
+	(declare (type (unsigned-byte 8) length)
+		 (type (simple-array (unsigned-byte 8) (*)) vector))
+	(copy-from-system-area pc (* vm:byte-bits 5)
+			       vector (* vm:word-bits
+					 vm:vector-data-offset)
+			       (* length vm:byte-bits))
+	(let* ((index 0)
+	       (error-number (c::read-var-integer vector index)))
+	  (collect ((sc-offsets))
+	    (loop
+	      (when (>= index length)
+		(return))
+	      (sc-offsets (c::read-var-integer vector index)))
+	    (values error-number (sc-offsets))))))))
+
+
+;;;; Sigcontext access functions.
+
+;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
+;;;
+(defun sigcontext-program-counter (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (slot scp 'sc-pc)))
+
+;;; SIGCONTEXT-REGISTER -- Interface.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  
+;;;
+(defun sigcontext-register (scp index)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (deref (slot scp 'sc-regs) (1+ (* index 2)))))
+
+(defun %set-sigcontext-register (scp index new)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (setf (deref (slot scp 'sc-regs) (1+ (* index 2))) new)
+    new))
+
+(defsetf sigcontext-register %set-sigcontext-register)
+
+
+;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface.
+;;;
+;;; 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 'sc-fpregs))))
+      (ecase format
+	(single-float (system:sap-ref-single sap (+ 4 (* index vm:word-bytes
+							 2))))
+	(double-float (system:sap-ref-double sap (+ 4 (* index vm:word-bytes
+							 2))))))))
+;;;
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-single sap (+ 4 (* index vm:word-bytes 2))) new-value))
+	(double-float
+	 (setf (sap-ref-double sap (+ 4 (* index vm:word-bytes 2)))
+			       new-value))))))
+;;;
+(defsetf sigcontext-float-register %set-sigcontext-float-register)
+
+
+;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
+;;;
+;;;    Given a sigcontext pointer, return the floating point modes word in the
+;;; same format as returned by FLOATING-POINT-MODES.
+;;;
+(defun sigcontext-floating-point-modes (scp)
+  (declare (type (alien (* sigcontext)) scp))
+   (with-alien ((scp (* sigcontext) scp))
+    (slot scp 'sc-fpc-csr)))
+
+
+
+;;; EXTERN-ALIEN-NAME -- interface.
+;;;
+;;; The loader uses this to convert alien names to the form they occure in
+;;; the symbol table (for example, prepending an underscore).  On the MIPS,
+;;; we don't do anything.
+;;; 
+(defun extern-alien-name (name)
+  (declare (type simple-base-string name))
+  name)
+
+
+
+;;; SANCTIFY-FOR-EXECUTION -- Interface.
+;;;
+;;; Do whatever is necessary to make the given code component executable.
+;;; 
+(defun sanctify-for-execution (component)
+  (without-gcing
+    (alien-funcall (extern-alien "sanctify_for_execution"
+				 (function void
+					   system-area-pointer
+					   unsigned-long))
+		   (code-instructions component)
+		   (* (code-header-ref component code-code-size-slot)
+		      word-bytes)))
+  nil)
+
-- 
GitLab