X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Falpha-vm.lisp;h=6741975a1cdd8e872cd43a2009c3dcbff0c8e478;hb=50305b602c3953440af716137a56f50cd204375d;hp=02cdff44211a782ef6fed80b41cfb3d91ee89a6d;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 02cdff4..6741975 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -1,36 +1,33 @@ -;;; -*- Package: ALPHA -*- -;;; +;;;; Alpha-specific implementation stuff -(in-package "SB!VM") - -(export '(#||# fixup-code-object internal-error-arguments - context-program-counter context-register - context-float-register context-floating-point-modes - extern-alien-name sanctify-for-execution)) +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") (defvar *number-of-signals* 64) (defvar *bits-per-word* 64) -;;; see x86-vm.lisp +;;; See x86-vm.lisp for a description of this. (def-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." + "Return a string describing the type of the local machine." "Alpha") (defun machine-version () - "Returns a string describing the version of the local machine." + "Return a string describing the version of the local machine." "Alpha") - - -;;; FIXUP-CODE-OBJECT -- Interface -;;; (defun fixup-code-object (code offset value kind) - (unless (zerop (rem offset word-bytes)) + (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 @@ -59,22 +56,20 @@ (:lda (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) - - - -;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then -;;; hacked for types. The alpha has 64-bit registers, so these -;;; potentially return 64 bit numbers (which means bignums ... ew) -;;; We think that 99 times of 100 (i.e. unless something is badly wrong) -;;; we'll get answers that fit in 32 bits anyway. - -;;; Which probably won't help us stop passing bignums around as the -;;; compiler can't prove they fit in 32 bits. But maybe the stuff it -;;; does on x86 to unbox 32-bit constants happens magically for 64-bit -;;; constants here. Just maybe. - -;;; see also x86-vm for commentary on signed vs unsigned. +;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then +;;;; hacked for types. +;;;; +;;;; KLUDGE: The alpha has 64-bit registers, so these potentially +;;;; return 64 bit numbers (which means bignums ... ew) We think that +;;;; 99 times of 100 (i.e. unless something is badly wrong) we'll get +;;;; answers that fit in 32 bits anyway. Which probably won't help us +;;;; stop passing bignums around as the compiler can't prove they fit +;;;; in 32 bits. But maybe the stuff it does on x86 to unbox 32-bit +;;;; constants happens magically for 64-bit constants here. Just +;;;; maybe. -- Dan Barlow, ca. 2001-05-05 +;;;; +;;;; See also x86-vm for commentary on signed vs unsigned. (def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long) (context (* os-context-t))) @@ -92,18 +87,20 @@ ;;; (Are they used in anything time-critical, or just the debugger?) (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) - (deref (context-register-addr context index))) + (deref (the (alien (* unsigned-long)) + (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)) + (declare (type (alien (* os-context-t)) context)) + (setf (deref (the (alien (* unsigned-long)) + (context-register-addr context index))) + new)) -;;; Like CONTEXT-REGISTER, but returns the value of a float register. -;;; FORMAT is the type of float to return. +;;; This is like CONTEXT-REGISTER, but returns the value of a float +;;; register. FORMAT is the type of float to return. -;;; whether COERCE actually knows how to make a float out of a long -;;; is another question. This stuff still needs testing +;;; FIXME: Whether COERCE actually knows how to make a float out of a +;;; long is another question. This stuff still needs testing. (def-alien-routine ("os_context_fpregister_addr" context-float-register-addr) (* long) (context (* os-context-t)) @@ -116,7 +113,6 @@ (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. (defun context-floating-point-modes (context) @@ -149,10 +145,8 @@ ;;; (pc) ;;; (example from undefined_tramp: "(gdb) x/40ub 0x10148" for yourself ;;; to replicate) - (defun internal-error-arguments (context) (declare (type (alien (* os-context-t)) context)) - (sb!int::/show0 "entering INTERNAL-ERROR-ARGUMENTS") (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) ;; pc is a SAP pointing at - or actually, shortly after - @@ -161,10 +155,9 @@ (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* sb!vm:byte-bits 5) - vector (* sb!vm:word-bits - sb!vm:vector-data-offset) - (* length sb!vm:byte-bits)) + (copy-from-system-area pc (* n-byte-bits 5) + vector (* n-word-bits vector-data-offset) + (* length n-byte-bits)) (let* ((index 0) (error-number (sb!c::read-var-integer vector index))) (collect ((sc-offsets)) @@ -173,27 +166,20 @@ (return)) (sc-offsets (sb!c::read-var-integer vector index))) (values error-number (sc-offsets))))))) - -;;; EXTERN-ALIEN-NAME -- interface. -;;; -;;; The loader uses this to convert alien names to the form they occure in -;;; the symbol table (for example, prepending an underscore). On the Alpha -;;; we don't do anything. -;;; +;;; The loader uses this to convert alien names to the form they +;;; occure in the symbol table (for example, prepending an +;;; underscore). (defun extern-alien-name (name) (declare (type simple-base-string name)) + ;; On the Alpha we don't do anything. name) - - -;;; SANCTIFY-FOR-EXECUTION -- Interface. -;;; -;;; Do whatever is necessary to make the given code component executable. -;;; - -;;; XXX do we really not have to flush caches or something here? I need -;;; an architecture manual +;;;; Do whatever is necessary to make the given code component +;;;; executable. +;;;; +;;;; XXX do we really not have to flush caches or something here? I +;;;; need an architecture manual (defun sanctify-for-execution (component) (declare (ignore component)) nil)