Skip to content
Snippets Groups Projects
Commit 565544de authored by chiles's avatar chiles
Browse files

Initial revision

parent faf12bbc
No related branches found
No related tags found
No related merge requests found
;;; -*- 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))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment