home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / pmax-vm.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  5.7 KB  |  192 lines
  1. ;;; -*- Package: MIPS -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: pmax-vm.lisp,v 1.10 92/02/22 00:04:21 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: pmax-vm.lisp,v 1.10 92/02/22 00:04:21 wlott Exp $
  15. ;;;
  16. ;;; This file contains the PMAX specific runtime stuff.
  17. ;;;
  18. (in-package "MIPS")
  19. (use-package "SYSTEM")
  20. (use-package "ALIEN")
  21. (use-package "C-CALL")
  22. (use-package "UNIX")
  23.  
  24. (export '(fixup-code-object internal-error-arguments
  25.       sigcontext-register sigcontext-float-register
  26.       sigcontext-floating-point-modes extern-alien-name))
  27.  
  28.  
  29. ;;;; The sigcontext structure.
  30.  
  31. (def-alien-type sigcontext
  32.   (struct nil
  33.     (sc-onstack unsigned-long)
  34.     (sc-mask unsigned-long)
  35.     (sc-pc system-area-pointer)
  36.     (sc-regs (array unsigned-long 32))
  37.     (sc-mdlo unsigned-long)
  38.     (sc-mdhi unsigned-long)
  39.     (sc-ownedfp unsigned-long)
  40.     (sc-fpregs (array unsigned-long 32))
  41.     (sc-fpc-csr unsigned-long)
  42.     (sc-fpc-eir unsigned-long)
  43.     (sc-cause unsigned-long)
  44.     (sc-badvaddr system-area-pointer)
  45.     (sc-badpaddr system-area-pointer)))
  46.  
  47.  
  48.  
  49. ;;;; Add machine specific features to *features*
  50.  
  51. (pushnew :decstation-3100 *features*)
  52. (pushnew :pmax *features*)
  53.  
  54.  
  55.  
  56. ;;;; MACHINE-TYPE and MACHINE-VERSION
  57.  
  58. (defun machine-type ()
  59.   "Returns a string describing the type of the local machine."
  60.   "DECstation")
  61.  
  62. (defun machine-version ()
  63.   "Returns a string describing the version of the local machine."
  64.   "DECstation")
  65.  
  66.  
  67.  
  68. ;;; FIXUP-CODE-OBJECT -- Interface
  69. ;;;
  70. (defun fixup-code-object (code offset fixup kind)
  71.   (unless (zerop (rem offset word-bytes))
  72.     (error "Unaligned instruction?  offset=#x~X." offset))
  73.   (system:without-gcing
  74.    (let ((sap (truly-the system-area-pointer
  75.              (%primitive c::code-instructions code))))
  76.      (ecase kind
  77.        (:jump
  78.     (assert (zerop (ash fixup -26)))
  79.     (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
  80.           (ash fixup -2)))
  81.        (:lui
  82.     (setf (sap-ref-16 sap offset)
  83.           (+ (ash fixup -16)
  84.          (if (logbitp 15 fixup) 1 0))))
  85.        (:addi
  86.     (setf (sap-ref-16 sap offset)
  87.           (ldb (byte 16 0) fixup)))))))
  88.  
  89.  
  90. ;;;; Internal-error-arguments.
  91.  
  92. ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
  93. ;;;
  94. ;;; Given the sigcontext, extract the internal error arguments from the
  95. ;;; instruction stream.
  96. ;;; 
  97. (defun internal-error-arguments (scp)
  98.   (declare (type (alien (* sigcontext)) scp))
  99.   (with-alien ((scp (* sigcontext) scp))
  100.     (let ((pc (slot scp 'sc-pc)))
  101.       (declare (type system-area-pointer pc))
  102.       (when (logbitp 31 (slot scp 'sc-cause))
  103.     (setf pc (sap+ pc 4)))
  104.       (when (= (sap-ref-8 pc 4) 255)
  105.     (setf pc (sap+ pc 1)))
  106.       (let* ((length (sap-ref-8 pc 4))
  107.          (vector (make-array length :element-type '(unsigned-byte 8))))
  108.     (declare (type (unsigned-byte 8) length)
  109.          (type (simple-array (unsigned-byte 8) (*)) vector))
  110.     (copy-from-system-area pc (* vm:byte-bits 5)
  111.                    vector (* vm:word-bits
  112.                      vm:vector-data-offset)
  113.                    (* length vm:byte-bits))
  114.     (let* ((index 0)
  115.            (error-number (c::read-var-integer vector index)))
  116.       (collect ((sc-offsets))
  117.         (loop
  118.           (when (>= index length)
  119.         (return))
  120.           (sc-offsets (c::read-var-integer vector index)))
  121.         (values error-number (sc-offsets))))))))
  122.  
  123.  
  124. ;;;; Sigcontext access functions.
  125.  
  126. ;;; SIGCONTEXT-REGISTER -- Internal.
  127. ;;;
  128. ;;; An escape register saves the value of a register for a frame that someone
  129. ;;; interrupts.  
  130. ;;;
  131. (defun sigcontext-register (scp index)
  132.   (declare (type (alien (* sigcontext)) scp))
  133.   (with-alien ((scp (* sigcontext) scp))
  134.     (deref (slot scp 'sc-regs) index)))
  135.  
  136. (defun %set-sigcontext-register (scp index new)
  137.   (declare (type (alien (* sigcontext)) scp))
  138.   (with-alien ((scp (* sigcontext) scp))
  139.     (setf (deref (slot scp 'sc-regs) index) new)
  140.     new))
  141.  
  142. (defsetf sigcontext-register %set-sigcontext-register)
  143.  
  144.  
  145. ;;; SIGCONTEXT-FLOAT-REGISTER  --  Internal
  146. ;;;
  147. ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
  148. ;;; Format is the type of float to return.
  149. ;;;
  150. (defun sigcontext-float-register (scp index format)
  151.   (declare (type (alien (* sigcontext)) scp))
  152.   (with-alien ((scp (* sigcontext) scp))
  153.     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
  154.       (ecase format
  155.     (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
  156.     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
  157. ;;;
  158. (defun %set-sigcontext-float-register (scp index format new-value)
  159.   (declare (type (alien (* sigcontext)) scp))
  160.   (with-alien ((scp (* sigcontext) scp))
  161.     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
  162.       (ecase format
  163.     (single-float
  164.      (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
  165.     (double-float
  166.      (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
  167. ;;;
  168. (defsetf sigcontext-float-register %set-sigcontext-float-register)
  169.  
  170.  
  171. ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
  172. ;;;
  173. ;;;    Given a sigcontext pointer, return the floating point modes word in the
  174. ;;; same format as returned by FLOATING-POINT-MODES.
  175. ;;;
  176. (defun sigcontext-floating-point-modes (scp)
  177.   (declare (type (alien (* sigcontext)) scp))
  178.    (with-alien ((scp (* sigcontext) scp))
  179.     (slot scp 'sc-fpc-csr)))
  180.  
  181.  
  182.  
  183. ;;; EXTERN-ALIEN-NAME -- interface.
  184. ;;;
  185. ;;; The loader uses this to convert alien names to the form they occure in
  186. ;;; the symbol table (for example, prepending an underscore).  On the MIPS,
  187. ;;; we don't do anything.
  188. ;;; 
  189. (defun extern-alien-name (name)
  190.   (declare (type simple-base-string name))
  191.   name)
  192.