X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fppc-vm.lisp;h=c3fdc16849ab0a4daa0226a5ed520230154e47a5;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=c9441df86a9f03e3184c6f30d8ff18c33b8e4bdf;hpb=bc46c8bcdd6ac8918df8ea9e9db49808e4924fcf;p=sbcl.git diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index c9441df..c3fdc16 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -2,54 +2,44 @@ ;;; (in-package "SB!VM") -(defvar *number-of-signals* 64) -(defvar *bits-per-word* 32) - (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") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "who-knows?") - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; +;;;; 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)))) + (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 @@ -71,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)) @@ -97,13 +94,13 @@ ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. -(defun context-floating-point-modes (context) - ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling - ;; for POSIXness and (at the Lisp level) opaque signal contexts, - ;; this is needs to be rewritten as an alien function. - (warn "stub CONTEXT-FLOATING-POINT-MODES") - 0) - +;;; +;;; 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))) ;;;; INTERNAL-ERROR-ARGS. @@ -115,58 +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)))))) - - - -;;; The loader uses this to convert alien names to the form they -;;; occur in the symbol table. This is ELF, so do nothing - -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - name) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets))))))