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