;;; some other package, perhaps SB-KERNEL.
(define-alien-type os-context-t (struct os-context-t-struct))
\f
-;;;; 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)
\f
;;;; :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)
\f
;;;; low-level signal context access functions
;;;;
;;;; 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 *'.)
(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
(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
projects / sbcl.git / blobdiff