/[cmucl]/src/code/debug-vm.lisp
ViewVC logotype

Contents of /src/code/debug-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Apr 19 02:18:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.3: +2 -2 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; -*- Package: VM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/debug-vm.lisp,v 1.4 2010/04/19 02:18:03 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This is some very low-level support for the debugger :function-end
13 ;;; breakpoints.
14 ;;;
15 ;;; Written by William Lott.
16 ;;;
17
18 (in-package "VM")
19
20 (intl:textdomain "cmucl")
21
22 (export '(make-bogus-lra))
23
24 (defconstant bogus-lra-constants 2)
25 (defconstant real-lra-slot (+ code-constants-offset 0))
26 (defconstant known-return-p-slot (+ code-constants-offset 1))
27
28 ;;; MAKE-BOGUS-LRA -- Interface.
29 ;;;
30 (defun make-bogus-lra (real-lra &optional known-return-p)
31 "Make a bogus LRA object that signals a breakpoint trap when returned to. If
32 the breakpoint trap handler returns to the fake component, the fake code
33 template returns to real-lra. This returns three values: the bogus LRA
34 object, the code component it points to, and the pc-offset for the trap
35 instruction."
36 (system:without-gcing
37 (let* ((src-start (truly-the system-area-pointer
38 (%primitive foreign-symbol-address
39 "function_end_breakpoint_guts")))
40 (src-end (truly-the system-area-pointer
41 (%primitive foreign-symbol-address
42 "function_end_breakpoint_end")))
43 (trap-loc (truly-the system-area-pointer
44 (%primitive foreign-symbol-address
45 "function_end_breakpoint_trap")))
46 (length (sap- src-end src-start))
47 (code-object (%primitive allocate-code-object
48 (1+ bogus-lra-constants)
49 length))
50 (dst-start (code-instructions code-object)))
51 (declare (type system-area-pointer src-start src-end dst-start trap-loc)
52 (type index length))
53 (setf (code-header-ref code-object code-debug-info-slot) nil)
54 (setf (code-header-ref code-object code-trace-table-offset-slot) length)
55 (setf (code-header-ref code-object real-lra-slot) real-lra)
56 (setf (code-header-ref code-object known-return-p-slot) known-return-p)
57 (system-area-copy src-start 0 dst-start 0 (* length byte-bits))
58 (let ((new-lra
59 (make-lisp-obj (+ (sap-int dst-start) other-pointer-type))))
60 (kernel:set-header-data new-lra
61 (logandc2 (+ code-constants-offset
62 bogus-lra-constants
63 1)
64 1))
65 (values new-lra
66 code-object
67 (sap- trap-loc src-start))))))

  ViewVC Help
Powered by ViewVC 1.1.5