0.7.13.7:
[sbcl.git] / src / code / hppa-vm.lisp
1 (in-package "SB!VM")
2 \f
3 (define-alien-type os-context-t (struct os-context-t-struct))
4 \f
5 ;;;; MACHINE-TYPE and MACHINE-VERSION
6
7 (defun machine-type ()
8   "Returns a string describing the type of the local machine."
9   "HPPA")
10
11 (defun machine-version ()
12   "Returns a string describing the version of the local machine."
13   "HPPA")
14
15 \f
16 ;;;; FIXUP-CODE-OBJECT
17
18 (defun fixup-code-object (code offset value kind)
19   (unless (zerop (rem offset n-word-bytes))
20     (error "Unaligned instruction?  offset=#x~X." offset))
21   (sb!sys:without-gcing
22    (let* ((sap (truly-the system-area-pointer
23                           (%primitive sb!kernel::code-instructions code)))
24           (inst (sap-ref-32 sap offset)))
25      (setf (sap-ref-32 sap offset)
26            (ecase kind
27              (:load
28               (logior (ash (ldb (byte 11 0) value) 1)
29                       (logand inst #xffffc000)))
30              (:load-short
31               (let ((low-bits (ldb (byte 11 0) value)))
32                 (assert (<= 0 low-bits (1- (ash 1 4))))
33                 (logior (ash low-bits 17)
34                         (logand inst #xffe0ffff))))
35              (:hi
36               (logior (ash (ldb (byte 5 13) value) 16)
37                       (ash (ldb (byte 2 18) value) 14)
38                       (ash (ldb (byte 2 11) value) 12)
39                       (ash (ldb (byte 11 20) value) 1)
40                       (ldb (byte 1 31) value)
41                       (logand inst #xffe00000)))
42              (:branch
43               (let ((bits (ldb (byte 9 2) value)))
44                 (assert (zerop (ldb (byte 2 0) value)))
45                 (logior (ash bits 3)
46                         (logand inst #xffe0e002)))))))))
47 \f
48 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
49   (context (* os-context-t)))
50
51 (defun context-pc (context)
52   (declare (type (alien (* os-context-t)) context))
53   (int-sap (logandc2 (deref (context-pc-addr context)) 3)))
54
55 (define-alien-routine ("os_context_register_addr" context-register-addr)
56   (* unsigned-int)
57   (context (* os-context-t))
58   (index int))
59
60 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
61 ;;; (Are they used in anything time-critical, or just the debugger?)
62 (defun context-register (context index)
63   (declare (type (alien (* os-context-t)) context))
64   (deref (context-register-addr context index)))
65
66 (defun %set-context-register (context index new)
67 (declare (type (alien (* os-context-t)) context))
68 (setf (deref (context-register-addr context index))
69       new))
70
71 #!+linux
72 ;;; For now.
73 (defun context-floating-point-modes (context)
74   (warn "stub CONTEXT-FLOATING-POINT-MODES")
75   0)
76
77 ;;;; Internal-error-arguments.
78
79 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
80 ;;;
81 ;;; Given the sigcontext, extract the internal error arguments from the
82 ;;; instruction stream.
83 ;;; 
84 (defun internal-error-args (context)
85   (declare (type (alien (* os-context-t)) context))
86   (let ((pc (context-pc context)))
87     (declare (type system-area-pointer pc))
88     (let* ((length (sap-ref-8 pc 4))
89            (vector (make-array length :element-type '(unsigned-byte 8))))
90       (declare (type (unsigned-byte 8) length)
91                (type (simple-array (unsigned-byte 8) (*)) vector))
92       (copy-from-system-area pc (* n-byte-bits 5)
93                              vector (* n-word-bits
94                                        vector-data-offset)
95                              (* length n-byte-bits))
96       (let* ((index 0)
97              (error-number (sb!c:read-var-integer vector index)))
98         (collect ((sc-offsets))
99          (loop
100           (when (>= index length)
101             (return))
102           (sc-offsets (sb!c:read-var-integer vector index)))
103          (values error-number (sc-offsets)))))))