procfs-image.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      procfs-image.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Fri Aug 24 11:39:37 2001
  12 ;;;;
  13 ;;;; $Id: procfs-image.lisp,v 1.26 2006/05/15 19:49:23 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (in-package movitz)
  18
  19 (defclass procfs-image (stream-image)
  20   ((pid
  21     :initarg :pid
  22     :reader image-pid)
  23    (procfs-connection
  24     :initarg :procfs
  25     :reader procfs-image-connection)))
  26
  27 (defmacro with-procfs-image ((pid
  28                               &key (procfs-var (gensym))
  29                                    (image-var '*image*)
  30                                    (offset #x811b000))
  31                              &body body)
  32   `(let ((pid ,pid))
  33      (procfs:with-procfs-attached (,procfs-var pid :direction :io)
  34        (let ((,image-var (make-instance 'procfs-image
  35                            :pid pid
  36                            :procfs ,procfs-var
  37                            :stream (procfs:procfs-connection-mem-stream ,procfs-var)
  38                            :offset ,offset)))
  39          ,@body))))
  40
  41 (defclass bochs-image (procfs-image)
  42   ((register-set-address
  43     :initarg :register-set-address
  44     :reader bochs-image-register-set-address)
  45    (gdtr-address
  46     :initarg :gdtr-address
  47     :reader bochs-image-gdtr-address)
  48    (sregs-address
  49     :initarg :sregs-address
  50     :reader bochs-image-sregs-address)
  51    (start-address
  52     :initarg :start-address
  53     :initform #x100000
  54     :accessor image-start-address)
  55    ))
  56
  57 (defun read-alist-file (path)
  58   (with-open-file (stream path :direction :input)
  59     (loop for c = (read stream nil '#0=:eof)
  60         until (eq #0# c)
  61         when (consp c)
  62         collect c)))
  63
  64 (defun bochs-parameter (p path)
  65   (cdr (assoc p (read-alist-file path))))
  66
  67 (defmacro with-bochs-image ((&key (path #p"bochs-parameters")
  68                                   (procfs-var (gensym))
  69                                   (image-var '*image*))
  70                             &body body)
  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*)
  77                                               0)
  78                            :cs-segment-base (if (boundp '*previous-image*)
  79                                                 (image-cs-segment-base *previous-image*)
  80                                               0)
  81                            :pid pid
  82                            :procfs ,procfs-var
  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))))
  88          ,@body))))
  89
  90
  91 (define-unsigned r32 4 :little-endian)
  92
  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)))
 103
 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))))
 109
 110 (defun register32 (register-name)
 111   (image-register32 *image* register-name))
 112
 113 (defmethod image-movitz-to-lisp-object ((image procfs-image) expr)
 114   (etypecase expr
 115     (cons (mapcar #'movitz-print expr))
 116     ((not movitz-object)
 117      expr)
 118     ((or movitz-null movitz-run-time-context) nil)
 119     (movitz-std-instance expr)
 120     (movitz-symbol
 121      (intern (movitz-print (movitz-symbol-name expr))))
 122     (movitz-string
 123      (map 'string #'identity
 124           (movitz-vector-symbolic-data expr)))
 125     (movitz-fixnum
 126      (movitz-fixnum-value expr))
 127     (movitz-bignum
 128      (movitz-bignum-value expr))
 129     (movitz-basic-vector
 130      (map 'vector #'movitz-print (movitz-vector-symbolic-data expr)))
 131     (movitz-cons
 132      (cons (movitz-print (movitz-car expr))
 133            (movitz-print (movitz-cdr expr))))
 134     (movitz-funobj
 135      expr)))
 136
 137
 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))))
 152     (values)))
 153
 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)))
 160         finally (terpri)))
 161   (values))
 162
 163 (defun current-stack-frame ()
 164   (image-register32 *image* :ebp))
 165
 166 (defun previous-stack-frame (stack-frame)
 167   (get-word stack-frame))
 168
 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))))
 174
 175 (defun stack-frame-return-address (stack-frame)
 176   (when (zerop (ldb (byte 2 0) stack-frame))
 177     (get-word (- stack-frame -4))))
 178
 179 (defun interrupt-frame-index (name)
 180   (- 5 (position name
 181                  (symbol-value 'muerte::+dit-frame-map+))))
 182
 183 (defun debug-get-object (word spartan)
 184   (if spartan
 185       word
 186     (handler-case
 187         (let ((object (movitz-word word)))
 188           (typecase object
 189             ((or movitz-funobj movitz-struct movitz-std-instance)
 190              object)
 191             (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   (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)
 205            (loop-finish)
 206         do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame))))
 207              (typecase movitz-name
 208                (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                        (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))
 218                                                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                (movitz-symbol
 223                 (let ((name (movitz-print movitz-name)))
 224                   (when print-frames
 225                     (format t "~S " (truncate stack-frame 4)))
 226                   (when (string= name 'toplevel-function)
 227                     (loop-finish))
 228                   (when reqs
 229                     (format t "(~A ~S ~S)"
 230                             (symbol-name name)
 231                             (debug-get-object (get-word (+ stack-frame -8)) spartan)
 232                             (debug-get-object (get-word (+ stack-frame -12)) spartan)))
 233                   (when print-returns
 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 "~& => ")))
 239   (values))
 240
 241 (defun stack-frame (image)
 242   (do-stack-frame (image-register32 image :ebp) 0))
 243
 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*))))
 249
 250 (defun do-stack-frame (frame-address count)
 251   (warn "Frame ~D: #x~8,'0X" count frame-address)
 252   (when (< count 10)
 253     (do-stack-frame (get-word frame-address) (1+ count))))
 254
 255
 256 (defun current-dynamic-context ()
 257   (slot-value (image-run-time-context *image*) 'dynamic-env))
 258
 259 (defun stack-ref-p (pointer)
 260   (let ((top #xa0000)
 261         (bottom (image-register32 *image* :esp)))
 262     (<= bottom pointer top)))
 263
 264 (defun stack-ref (pointer offset index type)
 265   (assert (stack-ref-p pointer) (pointer)
 266     "Stack pointer not in range: #x~X" pointer)
 267   (ecase type
 268     (:lisp
 269      (movitz-word (get-word (+ pointer offset (* 4 index)))))
 270     (:unsigned-byte32
 271      (values (get-word (+ pointer offset (* 4 index)))))))
 272
 273 (defun dynamic-context-uplink (dynamic-context)
 274   (stack-ref dynamic-context 12 0 :unsigned-byte32))
 275
 276 (defun dynamic-context-tag (dynamic-context)
 277   (stack-ref dynamic-context 4 0 :lisp))
 278
 279 (defun load-global-constant (slot-name)
 280   (slot-value (image-run-time-context *image*) slot-name))
 281
 282 (defun image-eq (x y)
 283   (eql (movitz-intern x) (movitz-intern y)))
 284
 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)))
 290            (cond
 291             ((image-eq tag (load-global-constant 'unbound-value))
 292              (format t "~&#x~X: name: ~A => value: ~A"
 293                      dynamic-context
 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]"
 297                        dynamic-context
 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)
 302               (values)))
 303
 304
 305 (defvar *previous-image*)
 306
 307 #+allegro
 308 (top-level:alias ("bochs" 0) (&optional form)
 309   (let ((*previous-image* *image*))
 310     (with-bochs-image ()
 311       (let ((image *image*))
 312         (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image))
 313           (if form
 314               (let ((x (eval form)))
 315                 (format t "~&~W" x)
 316                 x)
 317             (invoke-debugger
 318              (format nil "Established Bochs session [pid=~D]. ~S is ~S"
 319                      (image-pid image)
 320                      '*previous-image*
 321                      *previous-image*))))))))
 322
 323 #+allegro
 324 (top-level:alias ("unbochs" 3) (&optional form)
 325   (let ((*image* *previous-image*)
 326         (image *image*))
 327     (with-simple-restart (continue "Exit this unbochs session")
 328       (if form
 329           (let ((x (eval form)))
 330             (format t "~&~W" x)
 331             x)
 332         (invoke-debugger "Established connection to unBochs ~S" image)))))