X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fx86-64-vm.lisp;h=2706a42fe000459590f6fbc5bb5db558c2c2209d;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=a5a025b816df4a5eb471cbff9eacde019cbb5266;hpb=8c7a54e01f3a3047a8d258cb7539b0c4a7a30a46;p=sbcl.git diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index a5a025b..2706a42 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -34,162 +34,42 @@ ;;; some other package, perhaps SB-KERNEL. (define-alien-type os-context-t (struct os-context-t-struct)) -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () #!+sb-doc "Return a string describing the type of the local machine." "X86-64") - -;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere -(defun get-machine-version () - #!+linux - (with-open-file (stream "/proc/cpuinfo" - ;; Even on Linux it's an option to build - ;; kernels without /proc filesystems, so - ;; degrade gracefully. - :if-does-not-exist nil) - (loop with line while (setf line (read-line stream nil)) - ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 - ;; anyway, with values e.g. - ;; "AMD Athlon(TM) XP 2000+" - ;; "Intel(R) Pentium(R) M processor 1300MHz" - ;; which seem comparable to the information in the example - ;; in the MACHINE-VERSION page of the ANSI spec. - when (eql (search "model name" line) 0) - return (string-trim " " (subseq line (1+ (position #\: line)))))) - #!-linux - nil) ;;;; :CODE-OBJECT fixups -;;; a counter to measure the storage overhead of these fixups -(defvar *num-fixups* 0) -;;; FIXME: When the system runs, it'd be interesting to see what this is. - -(declaim (inline adjust-fixup-array)) -(defun adjust-fixup-array (array size) - (let ((new (make-array size :element-type '(unsigned-byte 64)))) - (replace new array) - new)) - ;;; This gets called by LOAD to resolve newly positioned objects ;;; with things (like code instructions) that have to refer to them. -;;; -;;; Add a fixup offset to the vector of fixup offsets for the given -;;; code object. (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) - (flet ((add-fixup (code offset) - ;; (We check for and ignore fixups for code objects in the - ;; read-only and static spaces. (In the old CMU CL code - ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, - ;; but in SBCL relocatable dynamic space code is always in - ;; use, so we always do the check.) - (incf *num-fixups*) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (format t "** Init. code FU = ~S~%" fixups)) ; FIXME - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) - (sb!sys:without-gcing - (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr (logandc2 (sb!kernel:get-lisp-obj-address code) - sb!vm:lowtag-mask)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) - (unless (member kind '(:absolute :absolute64 :relative)) - (error "Unknown code-object-fixup kind ~S." kind)) - (ecase kind - (:absolute64 - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr) - (add-fixup code offset))) - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (add-fixup code offset))) - (:relative - ;; Fixup is the actual address wanted. - ;; - ;; Record relative fixups that point outside the code - ;; object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (add-fixup code offset)) - ;; Replace word with value to add to that loc to get there. - (let* ((loc-sap (+ (sap-int sap) offset)) - (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) - (declare (type (unsigned-byte 64) loc-sap) - (type (signed-byte 32) rel-val)) - (setf (signed-sap-ref-32 sap offset) rel-val)))))) - nil)) - -;;; Add a code fixup to a code object generated by GENESIS. The fixup -;;; has already been applied, it's just a matter of placing the fixup -;;; in the code's fixup vector if necessary. -;;; -;;; KLUDGE: I'd like a good explanation of why this has to be done at -;;; load time instead of in GENESIS. It's probably simple, I just haven't -;;; figured it out, or found it written down anywhere. -- WHN 19990908 -#!+gencgc -(defun !envector-load-time-code-fixup (code offset fixup kind) - (flet ((frob (code offset) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (sb!impl::!cold-lose "Argh! can't process fixup")) - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) - (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr - (logandc2 (sb!kernel:get-lisp-obj-address code) sb!vm:lowtag-mask)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!sys:without-gcing + (let ((sap (truly-the system-area-pointer + (sb!kernel:code-instructions code)))) + (unless (member kind '(:absolute :absolute64 :relative)) + (error "Unknown code-object-fixup kind ~S." kind)) (ecase kind + (:absolute64 + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset)))) (:absolute - ;; Record absolute fixups that point within the code object. - ;; The fixup data is 32 bits, don't use SAP-REF-64 here. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (frob code offset))) + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))) (:relative - ;; Record relative fixups that point outside the code object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (frob code offset))))))) + ;; Fixup is the actual address wanted. + ;; Replace word with value to add to that loc to get there. + (let* ((loc-sap (+ (sap-int sap) offset)) + (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) + (declare (type (unsigned-byte 64) loc-sap) + (type (signed-byte 32) rel-val)) + (setf (signed-sap-ref-32 sap offset) rel-val)))))) + nil) ;;;; low-level signal context access functions ;;;; @@ -209,7 +89,7 @@ ;;;; negligible. (declaim (inline context-pc-addr)) -(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long) +(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned) ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an ;; 'unsigned *' interpretation for the 32-bit word passed to us by ;; the C code, even though the C code may think it's an 'int *'.) @@ -219,12 +99,12 @@ (defun context-pc (context) (declare (type (alien (* os-context-t)) context)) (let ((addr (context-pc-addr context))) - (declare (type (alien (* unsigned-long)) addr)) + (declare (type (alien (* unsigned)) addr)) (int-sap (deref addr)))) (declaim (inline context-register-addr)) (define-alien-routine ("os_context_register_addr" context-register-addr) - (* unsigned-long) + (* unsigned) ;; (Note the mismatch here between the 'int *' value that the C code ;; may think it's giving us and the 'unsigned *' value that we ;; receive. It's intentional: the C header files may think of @@ -238,13 +118,13 @@ (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) (let ((addr (context-register-addr context index))) - (declare (type (alien (* unsigned-long)) addr)) + (declare (type (alien (* unsigned)) addr)) (deref addr))) (defun %set-context-register (context index new) (declare (type (alien (* os-context-t)) context)) (let ((addr (context-register-addr context index))) - (declare (type (alien (* unsigned-long)) addr)) + (declare (type (alien (* unsigned)) addr)) (setf (deref addr) new))) ;;; This is like CONTEXT-REGISTER, but returns the value of a float