src/code/x86-vm.lisp

   1 ;;;; X86-specific runtime stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 (defun machine-type ()
  15   "Return a string describing the type of the local machine."
  16   "X86")
  17 \f
  18 ;;;; :CODE-OBJECT fixups
  19
  20 ;;; This gets called by LOAD to resolve newly positioned objects
  21 ;;; with things (like code instructions) that have to refer to them.
  22 ;;;
  23 ;;; Add a fixup offset to the vector of fixup offsets for the given
  24 ;;; code object.
  25 (defun fixup-code-object (code offset fixup kind)
  26   (declare (type index offset))
  27   (without-gcing
  28    (when
  29      (let* ((obj-start-addr (logandc2 (get-lisp-obj-address code) sb!vm:lowtag-mask))
  30             (sap (code-instructions code))
  31             (code-end-addr (+ (sap-int sap) (%code-code-size code))))
  32         (ecase kind
  33           (:absolute
  34            ;; Word at sap + offset contains a value to be replaced by
  35            ;; adding that value to fixup.
  36            (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
  37            ;; Record absolute fixups that point within the code object.
  38            (< obj-start-addr (sap-ref-32 sap offset) code-end-addr))
  39           (:relative
  40            ;; Fixup is the actual address wanted.
  41            ;; Replace word with value to add to that loc to get there.
  42            (let* ((loc-sap (+ (sap-int sap) offset))
  43                   ;; Use modular arithmetic so that if the offset
  44                   ;; doesn't fit into signed-byte-32 it'll wrap around
  45                   ;; when added to EIP
  46                   (rel-val (ldb (byte 32 0)
  47                                 (- fixup loc-sap n-word-bytes))))
  48              (declare (type (unsigned-byte 32) loc-sap rel-val))
  49              (setf (sap-ref-32 sap offset) rel-val))
  50            ;; Record relative fixups that point outside the code object.
  51            (or (< fixup obj-start-addr) (> fixup code-end-addr)))))
  52     ;; The preceding logic returns T if and only if the fixup
  53     ;; should be preserved for re-fix-up when code is transported.
  54     (setf (sb!vm::%code-fixups code)
  55           (let ((fixups (sb!vm::%code-fixups code)))
  56             (let* ((len (length (the (simple-array sb!vm:word 1) fixups)))
  57                    (new (replace (make-array (1+ len) :element-type 'sb!vm:word)
  58                                  fixups)))
  59               (setf (aref new len) offset)
  60               new)))))
  61   nil)
  62 \f
  63 ;;;; low-level signal context access functions
  64 ;;;;
  65 ;;;; Note: In CMU CL, similar functions were hardwired to access
  66 ;;;; BSD-style sigcontext structures defined as alien objects. Our
  67 ;;;; approach is different in two ways:
  68 ;;;;   1. We use POSIX SA_SIGACTION-style signals, so our context is
  69 ;;;;      whatever the void pointer in the sigaction handler dereferences
  70 ;;;;      to, not necessarily a sigcontext.
  71 ;;;;   2. We don't try to maintain alien definitions of the context
  72 ;;;;      structure at Lisp level, but instead call alien C functions
  73 ;;;;      which take care of access for us. (Since the C functions can
  74 ;;;;      be defined in terms of system standard header files, they
  75 ;;;;      should be easier to maintain; and since Lisp code uses signal
  76 ;;;;      contexts only in interactive or exception code (like the debugger
  77 ;;;;      and internal error handling) the extra runtime cost should be
  78 ;;;;      negligible.
  79
  80 #!+(or linux win32)
  81 (define-alien-routine ("os_context_float_register_addr" context-float-register-addr)
  82   (* unsigned) (context (* os-context-t)) (index int))
  83
  84 (defun context-float-register (context index format)
  85   (declare (ignorable context index))
  86   #!-(or linux win32)
  87   (progn
  88     (warn "stub CONTEXT-FLOAT-REGISTER")
  89     (coerce 0 format))
  90   #!+(or linux win32)
  91   (let ((sap (alien-sap (context-float-register-addr context index))))
  92     (ecase format
  93       (single-float
  94        (coerce (sap-ref-long sap 0) 'single-float))
  95       (double-float
  96        (sap-ref-long sap 0))
  97       (complex-single-float
  98        (complex (coerce (sap-ref-long sap 0) 'single-float)
  99                 (coerce (sap-ref-long sap 10) 'single-float)))
 100       (complex-double-float
 101        (complex (sap-ref-long sap 0)
 102                 (sap-ref-long sap 10))))))
 103
 104 (defun %set-context-float-register (context index format new-value)
 105   (declare (ignore context index))
 106   (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
 107   (coerce new-value format))
 108
 109 ;;; Given a signal context, return the floating point modes word in
 110 ;;; the same format as returned by FLOATING-POINT-MODES.
 111 #!-(or linux sunos)
 112 (defun context-floating-point-modes (context)
 113   ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
 114   ;; POSIXness and (at the Lisp level) opaque signal contexts,
 115   ;; this is stubified. It needs to be rewritten as an
 116   ;; alien function.
 117   (declare (ignore context)) ; stub!
 118   (warn "stub CONTEXT-FLOATING-POINT-MODES")
 119   0)
 120
 121 #!+(or linux sunos)
 122 (define-alien-routine ("os_context_fp_control" context-floating-point-modes)
 123     (sb!alien:unsigned 32)
 124   (context (* os-context-t)))
 125 \f
 126 ;;;; INTERNAL-ERROR-ARGS
 127
 128 ;;; Given a (POSIX) signal context, extract the internal error
 129 ;;; arguments from the instruction stream.
 130 (defun internal-error-args (context)
 131   (declare (type (alien (* os-context-t)) context))
 132   (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
 133   (/hexstr context)
 134   (let* ((pc (context-pc context))
 135          (error-number (sap-ref-8 pc 1)))
 136     (declare (type system-area-pointer pc))
 137     (/show0 "got PC")
 138     (values error-number
 139             (sb!kernel::decode-internal-error-args (sap+ pc 2) error-number))))
 140 \f
 141 ;;; This is used in error.lisp to insure that floating-point exceptions
 142 ;;; are properly trapped. The compiler translates this to a VOP.
 143 (defun float-wait ()
 144   (float-wait))
 145
 146 ;;; float constants
 147 ;;;
 148 ;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
 149 ;;; than the i387 load constant instructions to avoid consing in some
 150 ;;; cases. Note these are initialized by GENESIS as they are needed
 151 ;;; early.
 152 (defvar *fp-constant-0f0*)
 153 (defvar *fp-constant-1f0*)
 154 (defvar *fp-constant-0d0*)
 155 (defvar *fp-constant-1d0*)
 156 ;;; the long-float constants
 157 (defvar *fp-constant-0l0*)
 158 (defvar *fp-constant-1l0*)
 159 (defvar *fp-constant-pi*)
 160 (defvar *fp-constant-l2t*)
 161 (defvar *fp-constant-l2e*)
 162 (defvar *fp-constant-lg2*)
 163 (defvar *fp-constant-ln2*)
 164
 165 ;;; the current alien stack pointer; saved/restored for non-local exits
 166 (defvar *alien-stack-pointer*)
 167
 168 ;;; Support for the MT19937 random number generator. The update
 169 ;;; function is implemented as an assembly routine. This definition is
 170 ;;; transformed to a call to the assembly routine allowing its use in
 171 ;;; interpreted code.
 172 (defun random-mt19937 (state)
 173   (declare (type (simple-array (unsigned-byte 32) (627)) state))
 174   (random-mt19937 state))