home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / sparc-vm.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  7.4 KB  |  234 lines
  1. ;;; -*- Package: SPARC -*-
  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: sparc-vm.lisp,v 1.12 92/03/26 03:08:37 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: sparc-vm.lisp,v 1.12 92/03/26 03:08:37 wlott Exp $
  15. ;;;
  16. ;;; This file contains the SPARC specific runtime stuff.
  17. ;;;
  18. (in-package "SPARC")
  19. (use-package "SYSTEM")
  20. (use-package "UNIX")
  21.  
  22. (export '(fixup-code-object internal-error-arguments
  23.       sigcontext-register sigcontext-float-register
  24.       sigcontext-floating-point-modes extern-alien-name))
  25.  
  26.  
  27. ;;;; The sigcontext structure.
  28.  
  29. (def-alien-type sigcontext
  30.   (struct nil
  31.     (sc-onstack unsigned-long)
  32.     (sc-mask unsigned-long)
  33.     (sc-sp system-area-pointer)
  34.     (sc-pc system-area-pointer)
  35.     (sc-npc system-area-pointer)
  36.     (sc-psr unsigned-long)
  37.     (sc-g1 unsigned-long)
  38.     (sc-o0 unsigned-long)
  39.     (sc-regs (array unsigned-long 32))
  40.     (sc-fpregs (array unsigned-long 32))
  41.     (sc-y unsigned-long)
  42.     (sc-fsr unsigned-long)))
  43.  
  44.  
  45.  
  46. ;;;; Add machine specific features to *features*
  47.  
  48. (pushnew :SPARCstation *features*)
  49. (pushnew :sparc *features*)
  50. (pushnew :sun4 *features*)
  51.  
  52.  
  53.  
  54. ;;;; MACHINE-TYPE and MACHINE-VERSION
  55.  
  56. (defun machine-type ()
  57.   "Returns a string describing the type of the local machine."
  58.   "SPARCstation")
  59.  
  60. (defun machine-version ()
  61.   "Returns a string describing the version of the local machine."
  62.   "SPARCstation")
  63.  
  64.  
  65.  
  66. ;;; FIXUP-CODE-OBJECT -- Interface
  67. ;;;
  68. (defun fixup-code-object (code offset fixup kind)
  69.   (declare (type index offset))
  70.   (unless (zerop (rem offset vm:word-bytes))
  71.     (error "Unaligned instruction?  offset=#x~X." offset))
  72.   (system:without-gcing
  73.    (let ((sap (truly-the system-area-pointer
  74.              (%primitive c::code-instructions code))))
  75.      (ecase kind
  76.        (:call
  77.     (error "Can't deal with CALL fixups, yet."))
  78.        (:sethi
  79.     (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
  80.           (ldb (byte 22 10) fixup)))
  81.        (:add
  82.     (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
  83.           (ldb (byte 10 0) fixup)))))))
  84.  
  85.  
  86.  
  87. ;;;; Internal-error-arguments.
  88.  
  89. ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
  90. ;;;
  91. ;;; Given the sigcontext, extract the internal error arguments from the
  92. ;;; instruction stream.
  93. ;;; 
  94. (defun internal-error-arguments (scp)
  95.   (declare (type (alien (* sigcontext)) scp))
  96.   (let* ((pc (with-alien ((scp (* sigcontext) scp))
  97.            (slot scp 'sc-pc)))
  98.      (bad-inst (sap-ref-32 pc 0))
  99.      (op (ldb (byte 2 30) bad-inst))
  100.      (op2 (ldb (byte 3 22) bad-inst))
  101.      (op3 (ldb (byte 6 19) bad-inst)))
  102.     (declare (type system-area-pointer pc))
  103.     (cond ((and (= op #b00) (= op2 #b000))
  104.        (args-for-unimp-inst scp))
  105.       ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
  106.        (args-for-tagged-add-inst scp bad-inst))
  107.       ((and (= op #b10) (= op3 #b111010))
  108.        (args-for-tcc-inst bad-inst))
  109.       (t
  110.        (values #.(error-number-or-lose 'unknown-error) nil)))))
  111.  
  112. (defun args-for-unimp-inst (scp)
  113.   (declare (type (alien (* sigcontext)) scp))
  114.   (let* ((pc (with-alien ((scp (* sigcontext) scp))
  115.            (slot scp 'sc-pc)))
  116.      (length (sap-ref-8 pc 4))
  117.      (vector (make-array length :element-type '(unsigned-byte 8))))
  118.     (declare (type system-area-pointer pc)
  119.          (type (unsigned-byte 8) length)
  120.          (type (simple-array (unsigned-byte 8) (*)) vector))
  121.     (copy-from-system-area pc (* sparc:byte-bits 5)
  122.                vector (* sparc:word-bits
  123.                      sparc:vector-data-offset)
  124.                (* length sparc:byte-bits))
  125.     (let* ((index 0)
  126.        (error-number (c::read-var-integer vector index)))
  127.       (collect ((sc-offsets))
  128.            (loop
  129.          (when (>= index length)
  130.            (return))
  131.          (sc-offsets (c::read-var-integer vector index)))
  132.            (values error-number (sc-offsets))))))
  133.  
  134. (defun args-for-tagged-add-inst (scp bad-inst)
  135.   (declare (type (alien (* sigcontext)) scp))
  136.   (let* ((rs1 (ldb (byte 5 14) bad-inst))
  137.      (op1 (di::make-lisp-obj (sigcontext-register scp rs1))))
  138.     (if (fixnump op1)
  139.     (if (zerop (ldb (byte 1 13) bad-inst))
  140.         (let* ((rs2 (ldb (byte 5 0) bad-inst))
  141.            (op2 (di::make-lisp-obj (sigcontext-register scp rs2))))
  142.           (if (fixnump op2)
  143.           (values #.(error-number-or-lose 'unknown-error) nil)
  144.           (values #.(error-number-or-lose 'object-not-fixnum-error)
  145.               (list (c::make-sc-offset
  146.                  sparc:descriptor-reg-sc-number
  147.                  rs2)))))
  148.         (values #.(error-number-or-lose 'unknown-error) nil))
  149.     (values #.(error-number-or-lose 'object-not-fixnum-error)
  150.         (list (c::make-sc-offset sparc:descriptor-reg-sc-number
  151.                      rs1))))))
  152.  
  153. (defun args-for-tcc-inst (bad-inst)
  154.   (let* ((trap-number (ldb (byte 8 0) bad-inst))
  155.      (reg (ldb (byte 5 8) bad-inst)))
  156.     (values (case trap-number
  157.           (#.sparc:object-not-list-trap
  158.            #.(error-number-or-lose 'object-not-list-error))
  159.           (#.sparc:object-not-structure-trap
  160.            #.(error-number-or-lose 'object-not-structure-error))
  161.           (t
  162.            #.(error-number-or-lose 'unknown-error)))
  163.         (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
  164.  
  165.  
  166. ;;;; Sigcontext access functions.
  167.  
  168. ;;; SIGCONTEXT-REGISTER -- Internal.
  169. ;;;
  170. ;;; An escape register saves the value of a register for a frame that someone
  171. ;;; interrupts.  
  172. ;;;
  173. (defun sigcontext-register (scp index)
  174.   (declare (type (alien (* sigcontext)) scp))
  175.   (with-alien ((scp (* sigcontext) scp))
  176.     (deref (slot scp 'sc-regs) index)))
  177.  
  178. (defun %set-sigcontext-register (scp index new)
  179.   (declare (type (alien (* sigcontext)) scp))
  180.   (with-alien ((scp (* sigcontext) scp))
  181.     (setf (deref (slot scp 'sc-regs) index) new)
  182.     new))
  183.  
  184. (defsetf sigcontext-register %set-sigcontext-register)
  185.  
  186.  
  187. ;;; SIGCONTEXT-FLOAT-REGISTER  --  Internal
  188. ;;;
  189. ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
  190. ;;; Format is the type of float to return.
  191. ;;;
  192. (defun sigcontext-float-register (scp index format)
  193.   (declare (type (alien (* sigcontext)) scp))
  194.   (with-alien ((scp (* sigcontext) scp))
  195.     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
  196.       (ecase format
  197.     (single-float (system:sap-ref-single sap (* index vm:word-bytes)))
  198.     (double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
  199. ;;;
  200. (defun %set-sigcontext-float-register (scp index format new-value)
  201.   (declare (type (alien (* sigcontext)) scp))
  202.   (with-alien ((scp (* sigcontext) scp))
  203.     (let ((sap (alien-sap (slot scp 'sc-fpregs))))
  204.       (ecase format
  205.     (single-float
  206.      (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
  207.     (double-float
  208.      (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
  209. ;;;
  210. (defsetf sigcontext-float-register %set-sigcontext-float-register)
  211.  
  212.  
  213. ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
  214. ;;;
  215. ;;;    Given a sigcontext pointer, return the floating point modes word in the
  216. ;;; same format as returned by FLOATING-POINT-MODES.
  217. ;;;
  218. (defun sigcontext-floating-point-modes (scp)
  219.   (declare (type (alien (* sigcontext)) scp))
  220.   (with-alien ((scp (* sigcontext) scp))
  221.     (slot scp 'sc-fsr)))
  222.  
  223.  
  224.  
  225. ;;; EXTERN-ALIEN-NAME -- interface.
  226. ;;;
  227. ;;; The loader uses this to convert alien names to the form they occure in
  228. ;;; the symbol table (for example, prepending an underscore).  On the SPARC,
  229. ;;; we prepend an underscore.
  230. ;;; 
  231. (defun extern-alien-name (name)
  232.   (declare (type simple-base-string name))
  233.   (concatenate 'string "_" name))
  234.