src/code/share-vm.lisp

   1 ;;;; arch-independent runtime stuff
   2 ;;;; This software is part of the SBCL system. See the README file for
   3 ;;;; more information.
   4 ;;;;
   5 ;;;; This software is derived from the CMU CL system, which was
   6 ;;;; written at Carnegie Mellon University and released into the
   7 ;;;; public domain. The software is in the public domain and is
   8 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   9 ;;;; files for more information.
  10
  11 (in-package "SB!VM")
  12
  13 (defvar *current-internal-error-context*)
  14
  15 ;;;; OS-CONTEXT-T
  16
  17 ;;; a POSIX signal context, i.e. the type passed as the third
  18 ;;; argument to an SA_SIGACTION-style signal handler
  19 ;;;
  20 ;;; The real type does have slots, but at Lisp level, we never
  21 ;;; access them, or care about the size of the object. Instead, we
  22 ;;; always refer to these objects by pointers handed to us by the C
  23 ;;; runtime library, and ask the runtime library any time we need
  24 ;;; information about the contents of one of these objects. Thus, it
  25 ;;; works to represent this as an object with no slots.
  26 ;;;
  27 ;;; KLUDGE: It would be nice to have a type definition analogous to
  28 ;;; C's "struct os_context_t;", for an incompletely specified object
  29 ;;; which can only be referred to by reference, but I don't know how
  30 ;;; to do that in the FFI, so instead we just this bogus no-slots
  31 ;;; representation. -- WHN 20000730
  32 ;;;
  33 ;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
  34 ;;; it's no longer architecture-dependent, and probably belongs in
  35 ;;; some other package, perhaps SB-KERNEL.
  36 (define-alien-type os-context-t (struct os-context-t-struct))
  37
  38 (declaim (inline context-pc-addr))
  39 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned)
  40   (context (* os-context-t)))
  41
  42 (declaim (inline context-pc))
  43 (defun context-pc (context)
  44   (declare (type (alien (* os-context-t)) context))
  45   (let ((addr (context-pc-addr context)))
  46     (declare (type (alien (* unsigned)) addr))
  47     (int-sap (deref addr))))
  48
  49 (declaim (inline set-context-pc))
  50 (defun incf-context-pc (context offset)
  51   (declare (type (alien (* os-context-t)) context))
  52   (let ((addr (context-pc-addr context)))
  53     (declare (type (alien (* unsigned)) addr))
  54         (setf (deref addr) (+ (deref addr) offset))))
  55
  56 (declaim (inline context-register-addr))
  57 (define-alien-routine ("os_context_register_addr" context-register-addr)
  58     (* unsigned)
  59   (context (* os-context-t))
  60     (index int))
  61
  62 (declaim (inline context-register))
  63 (defun context-register (context index)
  64   (declare (type (alien (* os-context-t)) context))
  65   (let ((addr (context-register-addr context index)))
  66     (declare (type (alien (* unsigned)) addr))
  67     (deref addr)))
  68
  69 (defun %set-context-register (context index new)
  70   (declare (type (alien (* os-context-t)) context))
  71   (let ((addr (context-register-addr context index)))
  72     (declare (type (alien (* unsigned)) addr))
  73         (setf (deref addr) new)))