/[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.2.56.1 - (hide annotations)
Mon Feb 8 17:15:47 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
Changes since 1.2: +3 -1 lines
Add (intl:textdomain "cmucl") to the files to set the textdomain.
1 chiles 1.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 rtoy 1.2.56.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/debug-vm.lisp,v 1.2.56.1 2010/02/08 17:15:47 rtoy Exp $")
9 chiles 1.1 ;;;
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 rtoy 1.2.56.1 (intl:textdomain "cmucl")
21    
22 chiles 1.1 (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