src/code/debug-vm.lisp

   1 ;;;; This is some very low-level support for debugger :FUNCTION-END
   2 ;;;; breakpoints.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 (file-comment
  16   "$Header$")
  17
  18 (defconstant bogus-lra-constants 2)
  19 (defconstant real-lra-slot (+ code-constants-offset 0))
  20 (defconstant known-return-p-slot (+ code-constants-offset 1))
  21
  22 (defun make-bogus-lra (real-lra &optional known-return-p)
  23   #!+sb-doc
  24   "Make a bogus LRA object that signals a breakpoint trap when returned to. If
  25    the breakpoint trap handler returns to the fake component, the fake code
  26    template returns to real-lra. This returns three values: the bogus LRA
  27    object, the code component it points to, and the pc-offset for the trap
  28    instruction."
  29   (without-gcing
  30    (let* ((src-start (truly-the system-area-pointer
  31                                 (%primitive foreign-symbol-address
  32                                             "function_end_breakpoint_guts")))
  33           (src-end (truly-the system-area-pointer
  34                               (%primitive foreign-symbol-address
  35                                           "function_end_breakpoint_end")))
  36           (trap-loc (truly-the system-area-pointer
  37                                (%primitive foreign-symbol-address
  38                                            "function_end_breakpoint_trap")))
  39           (length (sap- src-end src-start))
  40           (code-object (%primitive allocate-code-object
  41                                    (1+ bogus-lra-constants)
  42                                    length))
  43           (dst-start (code-instructions code-object)))
  44      (declare (type system-area-pointer src-start src-end dst-start trap-loc)
  45               (type index length))
  46      (setf (code-header-ref code-object code-debug-info-slot) nil)
  47      (setf (code-header-ref code-object code-trace-table-offset-slot) length)
  48      (setf (code-header-ref code-object real-lra-slot) real-lra)
  49      (setf (code-header-ref code-object known-return-p-slot) known-return-p)
  50      (system-area-copy src-start 0 dst-start 0 (* length byte-bits))
  51      (let ((new-lra
  52             (make-lisp-obj (+ (sap-int dst-start) other-pointer-type))))
  53        (sb!kernel:set-header-data new-lra
  54                                   (logandc2 (+ code-constants-offset
  55                                                bogus-lra-constants
  56                                                1)
  57                                             1))
  58        (values new-lra
  59                code-object
  60                (sap- trap-loc src-start))))))