From 8b075c31b33a8f72d9e2a93d1cb8fc2346c6fe56 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 12 Jun 1992 03:24:13 +0000 Subject: [PATCH] Initial revision --- code/hppa-vm.lisp | 208 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 208 insertions(+) create mode 100644 code/hppa-vm.lisp diff --git a/code/hppa-vm.lisp b/code/hppa-vm.lisp new file mode 100644 index 000000000..49c711c57 --- /dev/null +++ b/code/hppa-vm.lisp @@ -0,0 +1,208 @@ +;;; -*- Package: HPPA -*- +;;; +;;; ********************************************************************** +;;; 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/hppa-vm.lisp,v 1.1 1992/06/12 03:24:13 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the HPPA specific runtime stuff. +;;; +(in-package "HPPA") +(use-package "SYSTEM") +(use-package "ALIEN") +(use-package "C-CALL") +(use-package "UNIX") + +(export '(fixup-code-object internal-error-arguments + sigcontext-register sigcontext-float-register + sigcontext-floating-point-modes extern-alien-name)) + + +;;;; The sigcontext structure. + +(def-alien-type save-state + (struct nil + (regs (array unsigned-long 32)) + (filler (array unsigned-long 32)) + (fpregs (array unsigned-long 32)))) + +(def-alien-type sigcontext + (struct nil + (sc-onstack unsigned-long) + (sc-mask unsigned-long) + (sc-sp system-area-pointer) + (sc-fp system-area-pointer) + (sc-ap (* save-state)) + (sc-pcsqh unsigned-long) + (sc-pc system-area-pointer) ; HP calls it the sc-pcoqh. + (sc-pcsqt unsigned-long) + (sc-pcoqt system-area-pointer) + (sc-ps unsigned-long))) + + +;;;; Add machine specific features to *features* + +(pushnew :hppa *features*) + + + +;;;; MACHINE-TYPE and MACHINE-VERSION + +(defun machine-type () + "Returns a string describing the type of the local machine." + "HPPA") + +(defun machine-version () + "Returns a string describing the version of the local machine." + "HPPA") + + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; +(defun fixup-code-object (code offset value 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))) + (inst (sap-ref-32 sap offset))) + (setf (sap-ref-32 sap offset) + (ecase kind + (:load + (logior (ash (ldb (byte 11 0) value) 1) + (logand inst #xffffc000))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (assert (<= 0 low-bits (1- (ash 1 4)))) + (logior (ash low-bits 17) + (logand inst #xffe0ffff)))) + (:hi + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand inst #xffe00000))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (assert (zerop (ldb (byte 2 0) value))) + (dpb (ash bits 1) + (byte 11 2) + (logand inst #xffe0e0002))))))))) + + + +;;;; 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)) + (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 (* byte-bits 5) + vector (* word-bits + vector-data-offset) + (* length 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-REGISTER -- Internal. +;;; +;;; 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 (slot scp 'sc-ap) 'regs) index))) + +(defun %set-sigcontext-register (scp index new) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new) + new)) + +(defsetf sigcontext-register %set-sigcontext-register) + + +;;; SIGCONTEXT-FLOAT-REGISTER -- Internal +;;; +;;; 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)) + (error "sigcontext-float-register not implimented." scp index format) + #+nil + (with-alien ((scp (* sigcontext) scp)) + (let ((sap (alien-sap (slot scp 'sc-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))))))) +;;; +(defun %set-sigcontext-float-register (scp index format new-value) + (declare (type (alien (* sigcontext)) scp)) + (error "%set-sigcontext-float-register not implimented." + scp index format new-value) + #+nil + (with-alien ((scp (* sigcontext) scp)) + (let ((sap (alien-sap (slot scp 'sc-fpregs)))) + (ecase format + (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)))))) +;;; +(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)) + (error "sigcontext-floating-point-modes not implimented." scp) + #+nil + (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). Which is just +;;; what we need to do. +;;; +(defun extern-alien-name (name) + (declare (type simple-base-string name)) + (concatenate 'string "_" name)) + + -- GitLab