1 ;;; This file contains the PPC specific runtime stuff.
6 "Returns a string describing the type of the local machine."
10 (defun return-machine-address (scp)
11 (sap-int (context-lr scp
)))
15 ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
16 ;;;; hacked for types.
18 (define-alien-routine ("os_context_lr_addr" context-lr-addr
) (* unsigned-long
)
19 (context (* os-context-t
)))
21 (defun context-lr (context)
22 (declare (type (alien (* os-context-t
)) context
))
23 (int-sap (deref (context-lr-addr context
))))
24 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
25 ;;; register. FORMAT is the type of float to return.
27 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
28 ;;; long is another question. This stuff still needs testing.
30 (define-alien-routine ("os_context_fpregister_addr" context-float-register-addr
)
32 (context (* os-context-t
))
34 (defun context-float-register (context index format
)
35 (declare (type (alien (* os-context-t
)) context
))
36 (error "context-float-register not working yet? ~S" (list context index format
))
38 (coerce (deref (context-float-register-addr context index
)) format
))
39 (defun %set-context-float-register
(context index format new
)
40 (declare (type (alien (* os-context-t
)) context
))
41 (error "%set-context-float-register not working yet? ~S" (list context index format new
))
43 (setf (deref (context-float-register-addr context index
))
46 ;;; Given a signal context, return the floating point modes word in
47 ;;; the same format as returned by FLOATING-POINT-MODES.
49 ;;; FIXME: surely this must be accessible under some other operating systems?
51 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
53 (context (* os-context-t
)))
56 ;;;; INTERNAL-ERROR-ARGS.
58 ;;; GIVEN a (POSIX) signal context, extract the internal error
59 ;;; arguments from the instruction stream. This is e.g.
61 ;;; INTERNAL-ERROR-ARGS -- interface.
63 ;;; Given the sigcontext, extract the internal error arguments from the
64 ;;; instruction stream.
66 (defun internal-error-args (context)
67 (declare (type (alien (* os-context-t
)) context
))
68 (let* ((pc (context-pc context
))
69 (bad-inst (sap-ref-32 pc
0))
70 (op (ldb (byte 16 16) bad-inst
))
71 (regnum (ldb (byte 5 0) op
)))
72 (declare (type system-area-pointer pc
))
74 (logior (ash 2 10) (ash 1 5) null-offset
) ;; TDI LGT,$NULL
76 (logior (ash 3 10) (ash 6 5))) ;; twllei r0
77 (let ((trap-number (ldb (byte 8 0) bad-inst
)))
78 (sb-kernel::decode-internal-error-args
(sap+ pc
4) trap-number
)))
79 ((and (= (ldb (byte 6 10) op
) 3) ;; twi
80 (or (= regnum
#.
(sc+offset-offset arg-count-sc
))
81 (= (ldb (byte 5 5) op
) 24))) ;; :ne
82 ;; Type errors are encoded as
83 ;; twi 0 value-register error-code
84 ;; twi :ne temp-register x
85 (let ((prev (sap-ref-32 (int-sap (- (sap-int pc
) 4)) 0)))
86 (if (and (= (ldb (byte 5 5) op
) 24) ;; is the condition :ne?
87 (= (ldb (byte 6 26) prev
) 3) ;; is it twi?
88 (= (ldb (byte 5 21) prev
) 0)) ;; is it non-trapping?
89 (values (ldb (byte 16 0) prev
)
90 (list (make-sc+offset any-reg-sc-number
91 (ldb (byte 5 16) prev
))))
92 ;; arg-count errors are encoded as
93 ;; twi {:ne :llt :lgt} nargs arg-count
94 (values #.
(error-number-or-lose 'invalid-arg-count-error
)
97 (values #.
(error-number-or-lose 'unknown-error
) nil
)))))