[506253]: src / code / ppc-vm.lisp Maximize Restore History

Download this file

ppc-vm.lisp    180 lines (154 with data), 6.3 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
;;; This file contains the PPC specific runtime stuff.
;;;
(in-package "SB!VM")
(define-alien-type os-context-t (struct os-context-t-struct))
;;;; MACHINE-TYPE and MACHINE-VERSION
(defun machine-type ()
"Returns a string describing the type of the local machine."
"PowerPC")
;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
(defun get-machine-version ()
#!+linux
(with-open-file (stream "/proc/cpuinfo"
;; /proc is optional even in Linux, so
;; fail gracefully.
:if-does-not-exist nil)
(loop with line while (setf line (read-line stream nil))
;; hoping "cpu" exists and gives something useful in
;; all relevant Linuxen...
;;
;; from Lars Brinkhoff sbcl-devel 26 Jun 2003:
;; I examined different versions of Linux/PPC at
;; http://lxr.linux.no/ (the file that outputs
;; /proc/cpuinfo is arch/ppc/kernel/setup.c, if
;; you want to check), and all except 2.0.x
;; seemed to do the same thing as far as the
;; "cpu" field is concerned, i.e. it always
;; starts with the (C-syntax) string "cpu\t\t: ".
when (eql (search "cpu" line) 0)
return (string-trim " " (subseq line (1+ (position #\: line))))))
#!-linux
nil)
;;;; FIXUP-CODE-OBJECT
(defun fixup-code-object (code offset fixup kind)
(declare (type index offset))
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
(let ((sap (truly-the system-area-pointer
(%primitive sb!kernel::code-instructions code))))
(ecase kind
(:b
(error "Can't deal with CALL fixups, yet."))
(:ba
(setf (ldb (byte 24 2) (sap-ref-32 sap offset))
(ash fixup -2)))
(:ha
(let* ((h (ldb (byte 16 16) fixup))
(l (ldb (byte 16 0) fixup)))
; Compensate for possible sign-extension when the low half
; is added to the high. We could avoid this by ORI-ing
; the low half in 32-bit absolute loads, but it'd be
; nice to be able to do:
; lis rX,foo@ha
; lwz rY,foo@l(rX)
; and lwz/stw and friends all use a signed 16-bit offset.
(setf (ldb (byte 16 0) (sap-ref-32 sap offset))
(if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
(:l
(setf (ldb (byte 16 0) (sap-ref-32 sap offset))
(ldb (byte 16 0) fixup)))))))
;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
;;;; hacked for types.
(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
(context (* os-context-t)))
(defun context-pc (context)
(declare (type (alien (* os-context-t)) context))
(int-sap (deref (context-pc-addr context))))
(define-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-long)
(context (* os-context-t))
(index int))
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
(deref (context-register-addr context index)))
(defun %set-context-register (context index new)
(declare (type (alien (* os-context-t)) context))
(setf (deref (context-register-addr context index))
new))
;;; This is like CONTEXT-REGISTER, but returns the value of a float
;;; register. FORMAT is the type of float to return.
;;; FIXME: Whether COERCE actually knows how to make a float out of a
;;; long is another question. This stuff still needs testing.
#+nil
(define-alien-routine ("os_context_fpregister_addr" context-float-register-addr)
(* long)
(context (* os-context-t))
(index int))
#+nil
(defun context-float-register (context index format)
(declare (type (alien (* os-context-t)) context))
(coerce (deref (context-float-register-addr context index)) format))
#+nil
(defun %set-context-float-register (context index format new)
(declare (type (alien (* os-context-t)) context))
(setf (deref (context-float-register-addr context index))
(coerce new format)))
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
;;;
;;; FIXME: surely this must be accessible somewhere under Darwin?
#!-darwin
(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
(sb!alien:unsigned 32)
(context (* os-context-t)))
;;;; INTERNAL-ERROR-ARGS.
;;; GIVEN a (POSIX) signal context, extract the internal error
;;; arguments from the instruction stream. This is e.g.
;;; INTERNAL-ERROR-ARGS -- interface.
;;;
;;; Given the sigcontext, extract the internal error arguments from the
;;; instruction stream.
;;;
(defun internal-error-args (context)
(declare (type (alien (* os-context-t)) context))
(let* ((pc (context-pc context))
(bad-inst (sap-ref-32 pc 0))
(op (ldb (byte 16 16) bad-inst)))
(declare (type system-area-pointer pc))
(cond ((= op (logior (ash 3 10) (ash 6 5)))
(args-for-unimp-inst context))
((and (= (ldb (byte 6 10) op) 3)
(= (ldb (byte 5 5) op) 24))
(let* ((regnum (ldb (byte 5 0) op))
(prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0)))
(if (and (= (ldb (byte 6 26) prev) 3)
(= (ldb (byte 5 21) prev) 0))
(values (ldb (byte 16 0) prev)
(list (sb!c::make-sc-offset sb!vm:any-reg-sc-number
(ldb (byte 5 16) prev))))
(values #.(sb!kernel:error-number-or-lose
'sb!kernel:invalid-arg-count-error)
(list (sb!c::make-sc-offset sb!vm:any-reg-sc-number regnum))))))
(t
(values #.(error-number-or-lose 'unknown-error) nil)))))
(defun args-for-unimp-inst (context)
(declare (type (alien (* os-context-t)) context))
(let* ((pc (context-pc context))
(length (sap-ref-8 pc 4))
(vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type system-area-pointer pc)
(type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
(copy-from-system-area pc (* sb!vm:n-byte-bits 5)
vector (* sb!vm:n-word-bits
sb!vm:vector-data-offset)
(* length sb!vm:n-byte-bits))
(let* ((index 0)
(error-number (sb!c:read-var-integer vector index)))
(collect ((sc-offsets))
(loop
(when (>= index length)
(return))
(sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets))))))