/[slime]/slime/swank-cmucl.lisp
ViewVC logotype

Diff of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.214 by heller, Mon Nov 2 09:20:33 2009 UTC revision 1.215 by heller, Tue Nov 3 18:22:58 2009 UTC
# Line 1535  A utility for debugging DEBUG-FUNCTION-A Line 1535  A utility for debugging DEBUG-FUNCTION-A
1535          (ignore-errors (princ e stream))))))          (ignore-errors (princ e stream))))))
1536    
1537  (defimplementation frame-source-location (index)  (defimplementation frame-source-location (index)
1538    (code-location-source-location (di:frame-code-location (nth-frame index))))    (let ((frame (nth-frame index)))
1539        (cond ((foreign-frame-p frame) (foreign-frame-source-location frame))
1540              ((code-location-source-location (di:frame-code-location frame))))))
1541    
1542  (defimplementation eval-in-frame (form index)  (defimplementation eval-in-frame (form index)
1543    (di:eval-in-frame (nth-frame index) form))    (di:eval-in-frame (nth-frame index) form))
# Line 1807  Try to create a informative message." Line 1809  Try to create a informative message."
1809                         (sys:sap-int                         (sys:sap-int
1810                          (sys:sap+ (kernel:code-instructions component) pc)))))                          (sys:sap+ (kernel:code-instructions component) pc)))))
1811               (values ip pc)))               (values ip pc)))
1812            ((or di::bogus-debug-function di::interpreted-debug-function)            (di::interpreted-debug-function -1)
1813             -1)))))            (di::bogus-debug-function
1814               #-x86 -1
1815               #+x86
1816               (let ((fp (di::frame-pointer (di:frame-up frame))))
1817                 (multiple-value-bind (ra ofp) (di::x86-call-context fp)
1818                   (declare (ignore ofp))
1819                   (values ra 0))))))))
1820    
1821  (defun frame-registers (frame)  (defun frame-registers (frame)
1822    "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."    "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
# Line 1825  Try to create a informative message." Line 1833  Try to create a informative message."
1833                           (integer p)                           (integer p)
1834                           (sys:system-area-pointer (sys:sap-int p)))))                           (sys:system-area-pointer (sys:sap-int p)))))
1835        (apply #'format t "~        (apply #'format t "~
1836  CSP  =  ~X  ~8X  Stack Pointer
1837  CFP  =  ~X  ~8X  Frame Pointer
1838  IP   =  ~X  ~8X  Instruction Pointer
1839  OCFP =  ~X  ~8X  Saved Frame Pointer
1840  LRA  =  ~X~%" (mapcar #'fixnum  ~8X  Saved Instruction Pointer~%" (mapcar #'fixnum
1841                        (multiple-value-list (frame-registers frame)))))))                        (multiple-value-list (frame-registers frame)))))))
1842    
1843    (defvar *gdb-program-name* "/usr/bin/gdb")
1844    
1845  (defimplementation disassemble-frame (frame-number)  (defimplementation disassemble-frame (frame-number)
   "Return a string with the disassembly of frames code."  
1846    (print-frame-registers frame-number)    (print-frame-registers frame-number)
1847    (terpri)    (terpri)
1848    (let* ((frame (di::frame-real-frame (nth-frame frame-number)))    (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
# Line 1847  LRA  =  ~X~%" (mapcar #'fixnum Line 1855  LRA  =  ~X~%" (mapcar #'fixnum
1855               (disassemble fun)               (disassemble fun)
1856               (disassem:disassemble-code-component component))))               (disassem:disassemble-code-component component))))
1857        (di::bogus-debug-function        (di::bogus-debug-function
1858         (format t "~%[Disassembling bogus frames not implemented]")))))         (cond ((probe-file *gdb-program-name*)
1859                  (let ((ip (sys:sap-int (frame-ip frame))))
1860                    (princ (gdb-command "disas 0x~x" ip))))
1861                 (t
1862                  (format t "~%[Disassembling bogus frames not implemented]")))))))
1863    
1864    (defmacro with-temporary-file ((stream filename) &body body)
1865      `(call/temporary-file (lambda (,stream ,filename) . ,body)))
1866    
1867    (defun call/temporary-file (fun)
1868      (let ((name (system::pick-temporary-file-name)))
1869        (unwind-protect
1870             (with-open-file (stream name :direction :output :if-exists :supersede)
1871               (funcall fun stream name))
1872          (delete-file name))))
1873    
1874    (defun gdb-command (format-string &rest args)
1875      (let ((str (gdb-exec (format nil "attach ~d~%~a~%detach"
1876                                   (getpid)
1877                                   (apply #'format nil format-string args)))))
1878        (subseq str (1+ (position #\newline str)))))
1879    
1880    (defun gdb-exec (cmd)
1881      (with-temporary-file (file filename)
1882        (write-string cmd file)
1883        (force-output file)
1884        (let* ((output (make-string-output-stream))
1885               (proc (ext:run-program "gdb" `("-batch" "-x" ,filename)
1886                                      :wait t
1887                                      :output output)))
1888          (assert (eq (ext:process-status proc) :exited))
1889          (assert (eq (ext:process-exit-code proc) 0))
1890          (get-output-stream-string output))))
1891    
1892    (defun foreign-frame-p (frame)
1893      #-x86 nil
1894      #+x86 (let ((ip (frame-ip frame)))
1895              (and (sys:system-area-pointer-p ip)
1896                   (multiple-value-bind (pc code)
1897                       (di::compute-lra-data-from-pc ip)
1898                     (declare (ignore pc))
1899                     (not code)))))
1900    
1901    (defun foreign-frame-source-location (frame)
1902      (let ((ip (sys:sap-int (frame-ip frame))))
1903        (cond ((probe-file *gdb-program-name*)
1904               (parse-gdb-line-info (gdb-command "info line *0x~x" ip)))
1905              (t `(:error "no srcloc available for ~a" frame)))))
1906    
1907    ;; The output of gdb looks like:
1908    ;; Line 215 of "../../src/lisp/x86-assem.S"
1909    ;;    starts at address 0x805318c <Ldone+11>
1910    ;;    and ends at 0x805318e <Ldone+13>.
1911    ;; The ../../ are fixed up with the "target:" search list which might
1912    ;; be wrong sometimes.
1913    (defun parse-gdb-line-info (string)
1914      (with-input-from-string (*standard-input* string)
1915        (let ((w1 (read-word)))
1916          (cond ((equal w1 "Line")
1917                 (let ((line (read-word)))
1918                   (assert (equal (read-word) "of"))
1919                   (let ((file (read-word)))
1920                     (make-location (list :file
1921                                          (unix-truename
1922                                           (merge-pathnames
1923                                            (read-from-string file)
1924                                            (format nil "~a/lisp/"
1925                                                    (unix-truename "target:")))))
1926                                    (list :line (parse-integer line))))))
1927                (t `(:error ,string))))))
1928    
1929    (defun read-word (&optional (stream *standard-input*))
1930      (peek-char t stream)
1931      (concatenate 'string (loop until (whitespacep (peek-char nil stream))
1932                                 collect (read-char stream))))
1933    
1934    (defun whitespacep (char)
1935      (member char '(#\space #\newline)))
1936    
1937    
1938  ;;;; Inspecting  ;;;; Inspecting

Legend:
Removed from v.1.214  
changed lines
  Added in v.1.215

  ViewVC Help
Powered by ViewVC 1.1.5