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