Skip to content
Snippets Groups Projects
Commit 08b750d4 authored by ram's avatar ram
Browse files

Initial revision

parent 9e16e9fb
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment