diff --git a/code/debug-vm.lisp b/code/debug-vm.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b24d340ad1bc667408b86c02adc072bcc4d695f9 --- /dev/null +++ b/code/debug-vm.lisp @@ -0,0 +1,67 @@ +;;; -*- Package: VM -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-vm.lisp,v 1.1 1991/08/12 08:12:18 chiles Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This is some very low-level support for the debugger :function-end +;;; breakpoints. +;;; +;;; Written by William Lott. +;;; + +(in-package "VM") + +(export '(make-bogus-lra)) + +(defconstant bogus-lra-constants 2) +(defconstant real-lra-slot (+ code-constants-offset 0)) +(defconstant known-return-p-slot (+ code-constants-offset 1)) + +;;; MAKE-BOGUS-LRA -- Interface. +;;; +(defun make-bogus-lra (real-lra &optional known-return-p) + "Make a bogus LRA object that signals a breakpoint trap when returned to. If + the breakpoint trap handler returns to the fake component, the fake code + template returns to real-lra. This returns three values: the bogus LRA + object, the code component it points to, and the pc-offset for the trap + instruction." + (system:without-gcing + (let* ((src-start (truly-the system-area-pointer + (%primitive foreign-symbol-address + "function_end_breakpoint_guts"))) + (src-end (truly-the system-area-pointer + (%primitive foreign-symbol-address + "function_end_breakpoint_end"))) + (trap-loc (truly-the system-area-pointer + (%primitive foreign-symbol-address + "function_end_breakpoint_trap"))) + (length (sap- src-end src-start)) + (code-object (%primitive allocate-code-object + (1+ bogus-lra-constants) + length)) + (dst-start (code-instructions code-object))) + (declare (type system-area-pointer src-start src-end dst-start trap-loc) + (type index length)) + (setf (code-header-ref code-object code-debug-info-slot) nil) + (setf (code-header-ref code-object code-trace-table-offset-slot) length) + (setf (code-header-ref code-object real-lra-slot) real-lra) + (setf (code-header-ref code-object known-return-p-slot) known-return-p) + (system-area-copy src-start 0 dst-start 0 (* length byte-bits)) + (let ((new-lra + (make-lisp-obj (+ (sap-int dst-start) other-pointer-type)))) + (kernel:set-header-data new-lra + (logandc2 (+ code-constants-offset + bogus-lra-constants + 1) + 1)) + (values new-lra + code-object + (sap- trap-loc src-start))))))