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