X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fppc-vm.lisp;h=c3fdc16849ab0a4daa0226a5ed520230154e47a5;hb=22c592cbf7e81e78ceaef80d1c15ad7a7fc3b40a;hp=627599e1b7ed143c16c0bf8888c9ccf1e1f35021;hpb=506253505641855dc8bb87033f7af894904f848b;p=sbcl.git diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 627599e..c3fdc16 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -5,35 +5,11 @@ (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (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 @@ -42,29 +18,28 @@ (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)))) + (let ((sap (%primitive sb!kernel::code-instructions code))) (ecase kind (:b - (error "Can't deal with CALL fixups, yet.")) + (error "Can't deal with CALL fixups, yet.")) (:ba - (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) - (ash fixup -2))) + (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)))) + (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))))))) + (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 @@ -86,6 +61,13 @@ (declare (type (alien (* os-context-t)) context)) (deref (context-register-addr context index))) +(define-alien-routine ("os_context_lr_addr" context-lr-addr) (* unsigned-long) + (context (* os-context-t))) + +(defun context-lr (context) + (declare (type (alien (* os-context-t)) context)) + (int-sap (deref (context-lr-addr context)))) + (defun %set-context-register (context index new) (declare (type (alien (* os-context-t)) context)) (setf (deref (context-register-addr context index)) @@ -113,8 +95,9 @@ ;;; 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 +;;; FIXME: surely this must be accessible somewhere under Darwin? Or +;;; under NetBSD? +#!+linux (define-alien-routine ("os_context_fp_control" context-floating-point-modes) (sb!alien:unsigned 32) (context (* os-context-t))) @@ -129,51 +112,46 @@ ;;; ;;; 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))) + (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 + (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) + (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))))) + + (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)))) + (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)) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) + (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)))))) - - + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets))))))