1 ;;;;------------------------------------------------------------------
3 ;;;; Copyright (C) 2001-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway.
6 ;;;; For distribution policy, see the accompanying file COPYING.
8 ;;;; Filename: procfs-image.lisp
10 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
11 ;;;; Created at: Fri Aug 24 11:39:37 2001
13 ;;;; $Id: procfs-image.lisp,v 1.26 2006/05/15 19:49:23 ffjeld Exp $
15 ;;;;------------------------------------------------------------------
19 (defclass procfs-image
(stream-image)
25 :reader procfs-image-connection
)))
27 (defmacro with-procfs-image
((pid
28 &key
(procfs-var (gensym))
33 (procfs:with-procfs-attached
(,procfs-var pid
:direction
:io
)
34 (let ((,image-var
(make-instance 'procfs-image
37 :stream
(procfs:procfs-connection-mem-stream
,procfs-var
)
41 (defclass bochs-image
(procfs-image)
42 ((register-set-address
43 :initarg
:register-set-address
44 :reader bochs-image-register-set-address
)
46 :initarg
:gdtr-address
47 :reader bochs-image-gdtr-address
)
49 :initarg
:sregs-address
50 :reader bochs-image-sregs-address
)
52 :initarg
:start-address
54 :accessor image-start-address
)
57 (defun read-alist-file (path)
58 (with-open-file (stream path
:direction
:input
)
59 (loop for c
= (read stream nil
'#0=:eof
)
64 (defun bochs-parameter (p path
)
65 (cdr (assoc p
(read-alist-file path
))))
67 (defmacro with-bochs-image
((&key
(path #p
"bochs-parameters")
71 `(let ((bt:*endian
* :little-endian
)
72 (pid (bochs-parameter :pid
,path
)))
73 (procfs:with-procfs-attached
(,procfs-var pid
:direction
:io
)
74 (let ((,image-var
(make-instance 'bochs-image
75 :ds-segment-base
(if (boundp '*previous-image
*)
76 (image-ds-segment-base *previous-image
*)
78 :cs-segment-base
(if (boundp '*previous-image
*)
79 (image-cs-segment-base *previous-image
*)
83 :stream
(procfs:procfs-connection-mem-stream
,procfs-var
)
84 :register-set-address
(+ 0 (bochs-parameter :cpu
,path
))
85 :offset
(bochs-parameter :memory
,path
)
86 :sregs-address
(bochs-parameter :sregs
,path
)
87 :gdtr-address
(bochs-parameter :gdtr
,path
))))
91 (define-unsigned r32
4 :little-endian
)
93 (define-binary-class bochs-registers
()
94 ((eax :binary-type r32
)
95 (ecx :binary-type r32
)
96 (edx :binary-type r32
)
97 (ebx :binary-type r32
)
98 (esp :binary-type r32
)
99 (ebp :binary-type r32
)
100 (esi :binary-type r32
)
101 (edi :binary-type r32
)
102 (eip :binary-type r32
)))
104 (defmethod image-register32 ((image bochs-image
) register-name
)
105 (assert (file-position (image-stream image
)
106 (bochs-image-register-set-address image
)))
107 (let ((register-set (read-binary 'bochs-registers
(image-stream image
))))
108 (slot-value register-set
(intern register-name
:movitz
))))
110 (defun register32 (register-name)
111 (image-register32 *image
* register-name
))
113 (defmethod image-movitz-to-lisp-object ((image procfs-image
) expr
)
115 (cons (mapcar #'movitz-print expr
))
118 ((or movitz-null movitz-run-time-context
) nil
)
119 (movitz-std-instance expr
)
121 (intern (movitz-print (movitz-symbol-name expr
))))
123 (map 'string
#'identity
124 (movitz-vector-symbolic-data expr
)))
126 (movitz-fixnum-value expr
))
128 (movitz-bignum-value expr
))
130 (map 'vector
#'movitz-print
(movitz-vector-symbolic-data expr
)))
132 (cons (movitz-print (movitz-car expr
))
133 (movitz-print (movitz-cdr expr
))))
138 (defmethod report-gdtr ((image bochs-image
))
139 (assert (file-position (image-stream image
)
140 (bochs-image-gdtr-address image
)))
141 (let* ((*endian
* :little-endian
)
142 (base (read-binary 'u32
(image-stream image
)))
143 (limit (read-binary 'u16
(image-stream image
))))
144 (format t
"~&GDTR: base #x~X, limit #x~X~%" base limit
)
145 (assert (zerop (mod base
4)) ()
146 "Base is not aligned to 16 bytes.")
147 (assert (zerop (mod (1+ limit
) 8)) ()
148 "Limit is not aligned to 8 bytes.")
149 (setf (image-stream-position *image
*) base
)
150 (dotimes (i (truncate (1+ limit
) 8))
151 (format t
"Descriptor ~D: ~<~W~>~%" i
(read-binary 'code-segment-descriptor
(image-stream image
))))
154 (defmethod report-segment-registers ((image bochs-image
))
155 (let* ((*endian
* :little-endian
))
156 (format t
"~&Segment registers: ")
157 (loop for
(reg . address
) in
(bochs-image-sregs-address image
)
158 do
(assert (file-position (image-stream image
) address
))
159 do
(format t
"~A: #x~X " reg
(read-binary 'u16
(image-stream image
)))
163 (defun current-stack-frame ()
164 (image-register32 *image
* :ebp
))
166 (defun previous-stack-frame (stack-frame)
167 (get-word stack-frame
))
169 (defun stack-frame-funobj (stack-frame)
170 (when (and (plusp stack-frame
)
171 (zerop (ldb (byte 2 0) stack-frame
)))
172 (let ((x (movitz-word (get-word (- stack-frame
4)))))
173 (and (typep x
'movitz-funobj
) x
))))
175 (defun stack-frame-return-address (stack-frame)
176 (when (zerop (ldb (byte 2 0) stack-frame
))
177 (get-word (- stack-frame -
4))))
179 (defun interrupt-frame-index (name)
181 (symbol-value 'muerte
::+dit-frame-map
+))))
183 (defun debug-get-object (word spartan
)
187 (let ((object (movitz-word word
)))
189 ((or movitz-funobj movitz-struct movitz-std-instance
)
191 (t (movitz-print object
))))
192 (serious-condition (c) (list :word-error word c
)))))
194 (defun backtrace (&key
(reqs t
) print-frames print-returns spartan
)
195 (format t
"~&Backtracing from EIP = #x~X: "
196 (image-register32 *image
* :eip
))
197 ;; (search-image-funobj (image-register32 *image* :eip))
198 (format t
"~&Current ESI: #x~X.~%"
199 (image-register32 *image
* :esi
))
200 (let ((*print-length
* 20))
201 (loop for stack-frame
= (current-stack-frame) then
(previous-stack-frame stack-frame
)
202 while
(plusp stack-frame
)
203 unless
(zerop (mod stack-frame
4))
204 do
(format t
"[frame #x~8,'0x]" stack-frame
)
206 do
(let ((movitz-name (funobj-name (stack-frame-funobj stack-frame
))))
207 (typecase movitz-name
209 ;; (write-string "?")
210 (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax
)) stack-frame
)))
211 (ebx (get-word (+ (* 4 (interrupt-frame-index :ebx
)) stack-frame
)))
212 (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx
)) stack-frame
)))
213 (edx (get-word (+ (* 4 (interrupt-frame-index :edx
)) stack-frame
)))
214 (edi (get-word (+ (* 4 (interrupt-frame-index :edi
)) stack-frame
)))
215 (eip (get-word (+ (* 4 (interrupt-frame-index :eip
)) stack-frame
)))
216 (esi (get-word (+ (* 4 (interrupt-frame-index :esi
)) stack-frame
)))
217 (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector
))
219 (format t
"#x~X {EAX: #x~X, EBX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}"
220 (truncate stack-frame
4)
221 eax ebx ecx edx edi esi eip exception
)))
223 (let ((name (movitz-print movitz-name
)))
225 (format t
"~S " (truncate stack-frame
4)))
226 (when (string= name
'toplevel-function
)
229 (format t
"(~A ~S ~S)"
231 (debug-get-object (get-word (+ stack-frame -
8)) spartan
)
232 (debug-get-object (get-word (+ stack-frame -
12)) spartan
)))
234 (format t
" (#x~X)" (stack-frame-return-address stack-frame
)))))
235 (t (when print-frames
236 (format t
"~S " (truncate stack-frame
4)))
237 (write (movitz-print movitz-name
)))))
238 do
(format t
"~& => ")))
241 (defun stack-frame (image)
242 (do-stack-frame (image-register32 image
:ebp
) 0))
244 (defun get-word (address &optional physicalp
)
245 (unless (zerop (ldb (byte 2 0) address
))
246 (warn "Non-aligned address to GET-WORD: #x~8,'0X." address
))
247 (setf (image-stream-position *image
* physicalp
) address
)
248 (values (read-binary 'word
(image-stream *image
*))))
250 (defun do-stack-frame (frame-address count
)
251 (warn "Frame ~D: #x~8,'0X" count frame-address
)
253 (do-stack-frame (get-word frame-address
) (1+ count
))))
256 (defun current-dynamic-context ()
257 (slot-value (image-run-time-context *image
*) 'dynamic-env
))
259 (defun stack-ref-p (pointer)
261 (bottom (image-register32 *image
* :esp
)))
262 (<= bottom pointer top
)))
264 (defun stack-ref (pointer offset index type
)
265 (assert (stack-ref-p pointer
) (pointer)
266 "Stack pointer not in range: #x~X" pointer
)
269 (movitz-word (get-word (+ pointer offset
(* 4 index
)))))
271 (values (get-word (+ pointer offset
(* 4 index
)))))))
273 (defun dynamic-context-uplink (dynamic-context)
274 (stack-ref dynamic-context
12 0 :unsigned-byte32
))
276 (defun dynamic-context-tag (dynamic-context)
277 (stack-ref dynamic-context
4 0 :lisp
))
279 (defun load-global-constant (slot-name)
280 (slot-value (image-run-time-context *image
*) slot-name
))
282 (defun image-eq (x y
)
283 (eql (movitz-intern x
) (movitz-intern y
)))
285 (defun print-dynamic-context (&optional
(initial-dynamic-context (current-dynamic-context)))
286 (loop for dynamic-context
= initial-dynamic-context
287 then
(dynamic-context-uplink dynamic-context
)
288 while
(stack-ref-p dynamic-context
)
289 do
(let ((tag (dynamic-context-tag dynamic-context
)))
291 ((image-eq tag
(load-global-constant 'unbound-value
))
292 (format t
"~&#x~X: name: ~A => value: ~A"
294 (stack-ref dynamic-context
0 0 :lisp
)
295 (stack-ref dynamic-context
8 0 :lisp
)))
296 (t (format t
"~&#x~X: tag: #x~X [name #x~X, val #x~X]"
298 (stack-ref dynamic-context
4 0 :unsigned-byte32
)
299 (stack-ref dynamic-context
0 0 :unsigned-byte32
)
300 (stack-ref dynamic-context
8 0 :unsigned-byte32
)))))
301 finally
(format t
"~&Last uplink: #x~X~%" dynamic-context
)
305 (defvar *previous-image
*)
308 (top-level:alias
("bochs" 0) (&optional form
)
309 (let ((*previous-image
* *image
*))
311 (let ((image *image
*))
312 (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image
))
314 (let ((x (eval form
)))
318 (format nil
"Established Bochs session [pid=~D]. ~S is ~S"
321 *previous-image
*))))))))
324 (top-level:alias
("unbochs" 3) (&optional form
)
325 (let ((*image
* *previous-image
*)
327 (with-simple-restart (continue "Exit this unbochs session")
329 (let ((x (eval form
)))
332 (invoke-debugger "Established connection to unBochs ~S" image
)))))