diff --git a/code/sparc-svr4-vm.lisp b/code/sparc-svr4-vm.lisp new file mode 100644 index 0000000000000000000000000000000000000000..72536db72bd0bab055d91ed4877eb6e35e5a32b9 --- /dev/null +++ b/code/sparc-svr4-vm.lisp @@ -0,0 +1,307 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; 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/sparc-svr4-vm.lisp,v 1.1 1994/10/19 23:25:06 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the SPARC specific runtime stuff. +;;; +(in-package "SPARC") +(use-package "SYSTEM") +(use-package "UNIX") + +(export '(fixup-code-object internal-error-arguments + s-context-program-counter s-context-register + s-context-float-register s-context-floating-point-modes + extern-alien-name sanctify-for-execution)) + + +;;;; The s-context structure. + +(def-alien-type sigset + (struct sigset + (sigbits (array unsigned-long 4)))) + +(def-alien-type sigaltstack + (struct sigaltstack + (ss-sp system-area-pointer) + (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. +(def-alien-type s-context + (struct nil + (uc-flags unsigned-long) + (uc-link system-area-pointer) + (uc-mask sigset) + (uc-stack sigaltstack) + (uc-pad unsigned-long) ;; align on 8. + ; struct mcontext + (uc-psr unsigned-long) + (uc-pc system-area-pointer) + (uc-npc system-area-pointer) + (uc-regs + (union un-regs + (regs (array unsigned-long 16)) ; %y, %g1 - %g7, %o0 - %o7 + (regs2 + (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-o7 unsigned-long))))) + (uc-windows system-area-pointer) ; usually nil + ;; struct fpu, already aligned at 8 bytes in mcontext + (fpregs (array unsigned-long 32)) + (fpq system-area-pointer) + (fsr unsigned-long) + (fpu-qcnt unsigned-char) + (fpu-q-entrysize unsigned-char) + (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 + ; end of mcontext + (filler2 (array long 24)))) ; 23 from def + 1 padding + + +;;;; Add machine specific features to *features* + +(pushnew :SPARCstation *features*) +(pushnew :sparc *features*) +(pushnew :sun4 *features*) +(pushnew :svr4 *features*) +;; There's SVR4 by Sun called Solaris 2, there's the SVR4 reference port by +;; ICL that runs on ICL's own DRS 6000s. +#+sunos +(pushnew :solaris *features*) + + + +;;;; MACHINE-TYPE and MACHINE-VERSION + +(defun machine-type () + "Returns a string describing the type of the local machine." + "SPARCstation") + +(defun machine-version () + "Returns a string describing the version of the local machine." + "SPARCstation") + + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (unless (zerop (rem offset vm: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 + (:call + (error "Can't deal with CALL fixups, yet.")) + (:sethi + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) fixup))) + (:add + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) fixup))))))) + + + +;;;; Internal-error-arguments. + +;;; INTERNAL-ERROR-ARGUMENTS -- interface. +;;; +;;; Given the s-context, extract the internal error arguments from the +;;; instruction stream. +;;; +(defun internal-error-arguments (scp) + (declare (type (alien (* s-context)) scp)) + ;(write "SCP = ") (write scp) + ;(write "slot = ") (write (slot scp 'uc-pc)) + (let* ((pc (with-alien ((scp (* s-context) scp)) + (slot scp 'uc-pc))) + (bad-inst (sap-ref-32 pc 0)) + (op (ldb (byte 2 30) bad-inst)) + (op2 (ldb (byte 3 22) bad-inst)) + (op3 (ldb (byte 6 19) bad-inst))) + (declare (type system-area-pointer pc)) + ;(write "PC = ") (write pc) + (cond ((and (= op #b00) (= op2 #b000)) + (args-for-unimp-inst scp)) + ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) + (args-for-tagged-add-inst scp bad-inst)) + ((and (= op #b10) (= op3 #b111010)) + (args-for-tcc-inst bad-inst)) + (t + (values #.(error-number-or-lose 'unknown-error) nil))))) + +(defun args-for-unimp-inst (scp) + (declare (type (alien (* s-context)) scp)) + (let* ((pc (with-alien ((scp (* s-context) scp)) + (slot scp 'uc-pc))) + (length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system-area-pointer pc) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-from-system-area pc (* sparc:byte-bits 5) + vector (* sparc:word-bits + sparc:vector-data-offset) + (* length sparc: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)))))) + +(defun args-for-tagged-add-inst (scp bad-inst) + (declare (type (alien (* s-context)) scp)) + (let* ((rs1 (ldb (byte 5 14) bad-inst)) + (op1 (di::make-lisp-obj (s-context-register scp rs1)))) + (if (fixnump op1) + (if (zerop (ldb (byte 1 13) bad-inst)) + (let* ((rs2 (ldb (byte 5 0) bad-inst)) + (op2 (di::make-lisp-obj (s-context-register scp rs2)))) + (if (fixnump op2) + (values #.(error-number-or-lose 'unknown-error) nil) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (c::make-sc-offset + sparc:descriptor-reg-sc-number + rs2))))) + (values #.(error-number-or-lose 'unknown-error) nil)) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (c::make-sc-offset sparc:descriptor-reg-sc-number + rs1)))))) + +(defun args-for-tcc-inst (bad-inst) + (let* ((trap-number (ldb (byte 8 0) bad-inst)) + (reg (ldb (byte 5 8) bad-inst))) + (values (case trap-number + (#.sparc:object-not-list-trap + #.(error-number-or-lose 'object-not-list-error)) + (#.sparc:object-not-instance-trap + #.(error-number-or-lose 'object-not-instance-error)) + (t + #.(error-number-or-lose 'unknown-error))) + (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg))))) + + +;;;; s-context access functions. + +;;; s-context-PROGRAM-COUNTER -- Interface. +;;; +(defun s-context-program-counter (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (slot scp 'uc-pc) + )) + +;;; s-context-REGISTER -- Interface. +;;; +;;; An escape register saves the value of a register for a frame that someone +;;; interrupts. +;;; +(defun s-context-register (scp index) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (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)) + )))) + +(defun %set-s-context-register (scp index new) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (if (zerop index) + 0 + (if (< index 16) + (setf (deref (slot (slot scp 'uc-regs) 'regs) index) new) + (setf (deref (slot (slot (slot scp 'uc-regs) 'regs2) 'uc-sp) + (- index 16)) new)) + )) + new) + +(defsetf s-context-register %set-s-context-register) + + +;;; s-context-FLOAT-REGISTER -- Interface +;;; +;;; Like s-context-REGISTER, but returns the value of a float register. +;;; Format is the type of float to return. +;;; +(defun s-context-float-register (scp index format) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) 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))))))) +;;; +(defun %set-s-context-float-register (scp index format new-value) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (let ((sap (alien-sap (slot scp '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 s-context-float-register %set-s-context-float-register) + + +;;; s-context-FLOATING-POINT-MODES -- Interface +;;; +;;; Given a s-context pointer, return the floating point modes word in the +;;; same format as returned by FLOATING-POINT-MODES. +;;; +(defun s-context-floating-point-modes (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (slot scp 'fsr))) + + + +;;; 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 SVR4 SPARC, we just return the name. +;;; +(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. +;;; On the sparc, we don't need to do anything, because the i and d caches +;;; are unified. +;;; +;;; XXX: newer machines, such as the SuperSPARC and MicroSPARC based ones, +;;; have a split I&D cache and do require cahce flusing. +;;; +(defun sanctify-for-execution (component) + (declare (ignore component)) + nil)