;;; 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")
-
-;;; 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
(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 32) (*)))
- (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 32)
- :initial-element offset)))))))
- (let* ((sap (truly-the system-area-pointer
- (sb!kernel:code-instructions code)))
- (obj-start-addr
- ;; FIXME: looks like (LOGANDC2 foo typebits)
- (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8))
- (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))))
- (ecase kind
- (:absolute
- ;; Record absolute fixups that point within the code object.
- (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
- (frob code offset)))
- (:relative
- ;; Record relative fixups that point outside the code object.
- (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
- (frob code offset)))))))
\f
;;;; low-level signal context access functions
;;;;
;;;; and internal error handling) the extra runtime cost should be
;;;; negligible.
+(declaim (inline context-pc-addr))
(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
;; (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 *'.)
(context (* os-context-t)))
+(declaim (inline context-pc))
(defun context-pc (context)
(declare (type (alien (* os-context-t)) context))
(let ((addr (context-pc-addr context)))
(declare (type (alien (* unsigned-int)) addr))
(int-sap (deref addr))))
+(declaim (inline context-register-addr))
(define-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-int)
;; (Note the mismatch here between the 'int *' value that the C code
(context (* os-context-t))
(index int))
+(declaim (inline context-register))
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
(let ((addr (context-register-addr context index)))
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
-#!-linux
+#!-(or linux sunos)
(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,
;; alien function.
(declare (ignore context)) ; stub!
(warn "stub CONTEXT-FLOATING-POINT-MODES")
-
- ;; old code for Linux:
- #+nil
- (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
- (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
- ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
- ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
- (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
- ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
- ;; Simulate floating-point-modes VOP.
- (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
-
0)
-#!+linux
+#!+(or linux sunos)
(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
(sb!alien:unsigned 32)
(context (* os-context-t)))