procfs-image.lisp 11.2 KB
Newer Older
1 2
;;;;------------------------------------------------------------------
;;;; 
3
;;;;    Copyright (C) 2001-2005, 
4
;;;;    Department of Computer Science, University of Tromso, Norway.
5 6 7 8 9 10 11 12
;;;; 
;;;;    For distribution policy, see the accompanying file COPYING.
;;;; 
;;;; Filename:      procfs-image.lisp
;;;; Description:   
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Fri Aug 24 11:39:37 2001
;;;;                
13
;;;; $Id: procfs-image.lisp,v 1.25 2006/04/10 11:46:25 ffjeld Exp $
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
;;;;                
;;;;------------------------------------------------------------------

(in-package movitz)

(defclass procfs-image (stream-image)
  ((pid
    :initarg :pid
    :reader image-pid)
   (procfs-connection
    :initarg :procfs
    :reader procfs-image-connection)))

(defmacro with-procfs-image ((pid
			      &key (procfs-var (gensym))
				   (image-var '*image*)
				   (offset #x811b000))
			     &body body)
  `(let ((pid ,pid))
     (procfs:with-procfs-attached (,procfs-var pid :direction :io)
       (let ((,image-var (make-instance 'procfs-image
			   :pid pid
			   :procfs ,procfs-var
			   :stream (procfs:procfs-connection-mem-stream ,procfs-var)
			   :offset ,offset)))
	 ,@body))))

(defclass bochs-image (procfs-image)
  ((register-set-address
    :initarg :register-set-address
    :reader bochs-image-register-set-address)
   (gdtr-address
    :initarg :gdtr-address
    :reader bochs-image-gdtr-address)
   (sregs-address
    :initarg :sregs-address
    :reader bochs-image-sregs-address)
   (start-address
    :initarg :start-address
    :initform #x100000
    :accessor image-start-address)
   ))

(defun read-alist-file (path)
  (with-open-file (stream path :direction :input)
    (loop for c = (read stream nil '#0=:eof)
	until (eq #0# c)
	when (consp c)
	collect c)))

(defun bochs-parameter (p path)
  (cdr (assoc p (read-alist-file path))))

(defmacro with-bochs-image ((&key (path #p"bochs-parameters")
				  (procfs-var (gensym))
				  (image-var '*image*))
			    &body body)
  `(let ((bt:*endian* :little-endian)
	 (pid (bochs-parameter :pid ,path)))
     (procfs:with-procfs-attached (,procfs-var pid :direction :io)
       (let ((,image-var (make-instance 'bochs-image
75 76 77 78 79 80
			   :ds-segment-base (if (boundp '*previous-image*)
						(image-ds-segment-base *previous-image*)
					      0)
			   :cs-segment-base (if (boundp '*previous-image*)
						(image-cs-segment-base *previous-image*)
					      0)
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
			   :pid pid
			   :procfs ,procfs-var
			   :stream (procfs:procfs-connection-mem-stream ,procfs-var)
			   :register-set-address (+ 0 (bochs-parameter :cpu ,path))
			   :offset (bochs-parameter :memory ,path)
			   :sregs-address (bochs-parameter :sregs ,path)
			   :gdtr-address (bochs-parameter :gdtr ,path))))
	 ,@body))))
  

(define-unsigned r32 4 :little-endian)

(define-binary-class bochs-registers ()
  ((eax :binary-type r32)
   (ecx :binary-type r32)
   (edx :binary-type r32)
   (ebx :binary-type r32)
   (esp :binary-type r32)
   (ebp :binary-type r32)
   (esi :binary-type r32)
   (edi :binary-type r32)
   (eip :binary-type r32)))

(defmethod image-register32 ((image bochs-image) register-name)
  (assert (file-position (image-stream image)
			 (bochs-image-register-set-address image)))
  (let ((register-set (read-binary 'bochs-registers (image-stream image))))
    (slot-value register-set (intern register-name :movitz))))

(defun register32 (register-name)
  (image-register32 *image* register-name))

113 114 115 116 117
(defmethod image-movitz-to-lisp-object ((image procfs-image) expr)
  (etypecase expr
    (cons (mapcar #'movitz-print expr))
    ((not movitz-object)
     expr)
118
    ((or movitz-null movitz-run-time-context) nil)
119
    (movitz-std-instance expr)
120 121 122 123 124 125 126
    (movitz-symbol
     (intern (movitz-print (movitz-symbol-name expr))))
    (movitz-string
     (map 'string #'identity
	  (movitz-vector-symbolic-data expr)))
    (movitz-fixnum
     (movitz-fixnum-value expr))
127 128
    (movitz-bignum
     (movitz-bignum-value expr))
129
    (movitz-basic-vector
130 131 132
     (map 'vector #'movitz-print (movitz-vector-symbolic-data expr)))
    (movitz-cons
     (cons (movitz-print (movitz-car expr))
133 134 135
	   (movitz-print (movitz-cdr expr))))
    (movitz-funobj
     expr)))
136 137


138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
(defmethod report-gdtr ((image bochs-image))
  (assert (file-position (image-stream image)
			 (bochs-image-gdtr-address image)))
  (let* ((*endian* :little-endian)
	 (base (read-binary 'u32 (image-stream image)))
	 (limit (read-binary 'u16 (image-stream image))))
    (format t "~&GDTR: base #x~X, limit #x~X~%" base limit)
    (assert (zerop (mod base 4)) ()
      "Base is not aligned to 16 bytes.")
    (assert (zerop (mod (1+ limit) 8)) ()
      "Limit is not aligned to 8 bytes.")
    (setf (image-stream-position *image*) base)
    (dotimes (i (truncate (1+ limit) 8))
      (format t "Descriptor ~D: ~<~W~>~%" i (read-binary 'code-segment-descriptor (image-stream image))))
    (values)))
    
(defmethod report-segment-registers ((image bochs-image))
  (let* ((*endian* :little-endian))
    (format t "~&Segment registers: ")
    (loop for (reg . address) in (bochs-image-sregs-address image)
	do (assert (file-position (image-stream image) address))
	do (format t "~A: #x~X " reg (read-binary 'u16 (image-stream image)))
	finally (terpri)))
  (values))

(defun current-stack-frame ()
  (image-register32 *image* :ebp))

(defun previous-stack-frame (stack-frame)
  (get-word stack-frame))

(defun stack-frame-funobj (stack-frame)
170 171
  (when (and (plusp stack-frame)
	     (zerop (ldb (byte 2 0) stack-frame)))
172 173 174 175 176 177 178
    (let ((x (movitz-word (get-word (- stack-frame 4)))))
      (and (typep x 'movitz-funobj) x))))

(defun stack-frame-return-address (stack-frame)
  (when (zerop (ldb (byte 2 0) stack-frame))
    (get-word (- stack-frame -4))))

179 180
(defun interrupt-frame-index (name)
  (- 5 (position name
181
		 (symbol-value 'muerte::+dit-frame-map+))))
182

183 184 185 186 187 188 189 190 191
(defun debug-get-object (word spartan)
  (if spartan
      word
    (handler-case
	(let ((object (movitz-word word)))
	  (typecase object
	    ((or movitz-funobj movitz-struct movitz-std-instance)
	     object)
	    (t (movitz-print object))))
192
      (serious-condition (c) (list :word-error word c)))))
193 194

(defun backtrace (&key (reqs t) print-frames print-returns spartan)
195 196 197 198 199
  (format t "~&Backtracing from EIP = #x~X: "
	  (image-register32 *image* :eip))
  ;; (search-image-funobj (image-register32 *image* :eip))
  (format t "~&Current ESI: #x~X.~%"
	  (image-register32 *image* :esi))
200 201
  (let ((*print-length* 20))
    (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame)
202
	while (plusp stack-frame)
203 204 205 206 207 208
	unless (zerop (mod stack-frame 4))
	do (format t "[frame #x~8,'0x]" stack-frame)
	   (loop-finish)
	do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame))))
	     (typecase movitz-name
	       (null
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 213 214 215 216
		       (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame)))
		       (edx (get-word (+ (* 4 (interrupt-frame-index :edx)) stack-frame)))
		       (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame)))
		       (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame)))
		       (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame)))
217 218
		       (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector))
					       stack-frame))))
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)))
222 223 224
	       (movitz-symbol
		(let ((name (movitz-print movitz-name)))
		  (when print-frames
225
		    (format t "~S " (truncate stack-frame 4)))
226 227 228 229 230 231 232 233 234
		  (when (string= name 'toplevel-function)
		    (loop-finish))
		  (when reqs
		    (format t "(~A ~S ~S)"
			    (symbol-name name)
			    (debug-get-object (get-word (+ stack-frame -8)) spartan)
			    (debug-get-object (get-word (+ stack-frame -12)) spartan)))
		  (when print-returns
		    (format t " (#x~X)" (stack-frame-return-address stack-frame)))))
235 236 237
	       (t (when print-frames
		    (format t "~S " (truncate stack-frame 4)))
		  (write (movitz-print movitz-name)))))
238
	do (format t "~& => ")))
239 240 241 242 243 244 245 246 247
  (values))

(defun stack-frame (image)
  (do-stack-frame (image-register32 image :ebp) 0))
    
(defun get-word (address &optional physicalp)
  (unless (zerop (ldb (byte 2 0) address))
    (warn "Non-aligned address to GET-WORD: #x~8,'0X." address))
  (setf (image-stream-position *image* physicalp) address)
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
248
  (values (read-binary 'word (image-stream *image*))))
249 250 251 252 253 254 255 256

(defun do-stack-frame (frame-address count)
  (warn "Frame ~D: #x~8,'0X" count frame-address)
  (when (< count 10)
    (do-stack-frame (get-word frame-address) (1+ count))))


(defun current-dynamic-context ()
257
  (slot-value (image-run-time-context *image*) 'dynamic-env))
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279

(defun stack-ref-p (pointer)
  (let ((top #xa0000)
	(bottom (image-register32 *image* :esp)))
    (<= bottom pointer top)))

(defun stack-ref (pointer offset index type)
  (assert (stack-ref-p pointer) (pointer)
    "Stack pointer not in range: #x~X" pointer)
  (ecase type
    (:lisp
     (movitz-word (get-word (+ pointer offset (* 4 index)))))
    (:unsigned-byte32
     (values (get-word (+ pointer offset (* 4 index)))))))

(defun dynamic-context-uplink (dynamic-context)
  (stack-ref dynamic-context 12 0 :unsigned-byte32))

(defun dynamic-context-tag (dynamic-context)
  (stack-ref dynamic-context 4 0 :lisp))

(defun load-global-constant (slot-name)
280
  (slot-value (image-run-time-context *image*) slot-name))
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304

(defun image-eq (x y)
  (eql (movitz-intern x) (movitz-intern y)))

(defun print-dynamic-context (&optional (initial-dynamic-context (current-dynamic-context)))
  (loop for dynamic-context = initial-dynamic-context
      then (dynamic-context-uplink dynamic-context)
      while (stack-ref-p dynamic-context)
      do (let ((tag (dynamic-context-tag dynamic-context)))
	   (cond
	    ((image-eq tag (load-global-constant 'unbound-value))
	     (format t "~&#x~X: name: ~A => value: ~A"
		     dynamic-context
		     (stack-ref dynamic-context 0 0 :lisp)
		     (stack-ref dynamic-context 8 0 :lisp)))
	    (t (format t "~&#x~X:  tag: #x~X [name #x~X, val #x~X]"
		       dynamic-context
		       (stack-ref dynamic-context 4 0 :unsigned-byte32)
		       (stack-ref dynamic-context 0 0 :unsigned-byte32)
		       (stack-ref dynamic-context 8 0 :unsigned-byte32)))))
      finally (format t "~&Last uplink: #x~X~%" dynamic-context)
	      (values)))


305 306
(defvar *previous-image*)

307
#+allegro
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
308
(top-level:alias ("bochs" 0) (&optional form)
309 310 311 312 313 314 315 316
  (let ((*previous-image* *image*))
    (with-bochs-image ()
      (let ((image *image*))
	(with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image))
	  (if form
	      (let ((x (eval form)))
		(format t "~&~W" x)
		x)
317 318 319 320 321
	    (invoke-debugger
	     (format nil "Established Bochs session [pid=~D]. ~S is ~S"
		     (image-pid image)
		     '*previous-image*
		     *previous-image*))))))))
322 323 324 325 326 327

#+allegro
(top-level:alias ("unbochs" 3) (&optional form)
  (let ((*image* *previous-image*)
	(image *image*))
    (with-simple-restart (continue "Exit this unbochs session")
Frode Vatvedt Fjeld's avatar
Frode Vatvedt Fjeld committed
328 329 330 331
      (if form
	  (let ((x (eval form)))
	    (format t "~&~W" x)
	    x)
332
	(invoke-debugger "Established connection to unBochs ~S" image)))))