Changeset 645


Ignore:
Timestamp:
Mar 8, 2004, 2:00:49 PM (15 years ago)
Author:
gb
Message:

Add stack-inspector stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/describe.lisp

    r169 r645  
    15231523
    15241524
     1525
     1526;;;;;;;
     1527;;
     1528;; an ERROR-FRAME stores the stack addresses that the backtrace window displays
     1529;;
     1530
     1531;; set to list of function you don't want to see
     1532;; Functions can be symbols, nil for kernel, or #'functions
     1533(defparameter *backtrace-internal-functions* 
     1534  (list :kernel))
     1535
     1536(defvar *backtrace-hide-internal-functions-p* t)
     1537
     1538(defclass error-frame ()
     1539  ((addresses :accessor addresses)
     1540   (restart-info :accessor restart-info)
     1541   (sampling-period :initarg :sampling-period :initform 32 :reader sampling-period)
     1542   (stack-start :initarg :stack-start :initform (ccl::%get-frame-ptr) :reader stack-start)
     1543   (stack-end :initarg :stack-end :initform (ccl::last-frame-ptr) :reader stack-end)
     1544   (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr)
     1545   (frame-count :accessor frame-count)
     1546   (ignored-functions :accessor ignored-functions
     1547                      :initform (and *backtrace-hide-internal-functions-p*
     1548                                     *backtrace-internal-functions*))
     1549   (break-condition :accessor break-condition
     1550                    :initform ccl::*break-condition*)))
     1551
     1552; This is set up to access the result of
     1553; (multiple-value-call #'vector (ccl::parent-frame-saved-vars ...))
     1554(ccl::def-accessors svref
     1555  %sv.frame
     1556  %sv.last-catch
     1557  %sv.srv)
     1558
     1559
     1560
     1561(defun ignore-function-in-backtrace? (error-frame function)
     1562  (loop for ignored-fn in (ignored-functions error-frame)
     1563        when (and (null function) (eq ignored-fn :kernel)) return t
     1564        when (and (symbolp ignored-fn) (eq (function-name function) ignored-fn)) return t
     1565        when (eq ignored-fn function) return t
     1566        finally (return nil)))
     1567
     1568; use parent-frame-saved-vars to cons a vector for each element of ADDRESSES
     1569(defmethod initialize-instance ((f error-frame) &key)
     1570  (call-next-method)
     1571  (initialize-addresses f))
     1572
     1573(defmethod initialize-addresses ((f error-frame))
     1574  (let ((end (stack-end f)))
     1575    (flet ((skip-to-important-frame (frame tcr)
     1576             (loop for this? = (or (eq frame end)
     1577                                   (not (ignore-function-in-backtrace?
     1578                                         f
     1579                                         (ccl::cfp-lfun frame))))
     1580                   until this?
     1581                   do (setf frame (ccl::parent-frame frame tcr))
     1582                   finally (return frame))))
     1583      (setf (slot-value f 'stack-start)
     1584            (skip-to-important-frame (stack-start f) (tcr f)))))
     1585 
     1586      (let* ((count 0)
     1587             (tcr (tcr f))
     1588             (p (stack-start f))
     1589             (p-child (ccl::child-frame p tcr))
     1590             (q (stack-end f))
     1591             (period (sampling-period f))
     1592             (addresses nil)
     1593             (last-frame nil))
     1594        (multiple-value-bind (frame catch srv)
     1595                             (ccl::last-catch-since-saved-vars p-child tcr)
     1596          (loop
     1597            (if (null frame) (error "Can't find saved vars info"))
     1598            (if (eq frame p-child) (return))
     1599            (multiple-value-setq (frame catch srv)
     1600              (ccl::parent-frame-saved-vars tcr frame catch srv srv)))
     1601          (push (vector p-child catch (ccl::copy-srv srv))
     1602                addresses)
     1603          (setq last-frame frame)
     1604          (multiple-value-setq (frame catch srv)
     1605            (ccl::parent-frame-saved-vars tcr frame catch srv srv))
     1606          (unless (eq frame p) (error "(~s (~s ~d)) <> ~d"
     1607                                      'ccl::parent-frame 'ccl::child-frame p p))
     1608          (push (vector frame catch (ccl::copy-srv srv))
     1609                addresses)
     1610          (flet ((done-p ()
     1611                     (or (null frame) (eql last-frame q))))
     1612             (block loop
     1613                (do* ((cnt (1+ period)))
     1614                     ((done-p))
     1615                  (loop while (ignore-function-in-backtrace?
     1616                             f (ccl::cfp-lfun frame))
     1617                      do
     1618                      (setq last-frame frame)
     1619                      (multiple-value-setq (frame catch srv)
     1620                        (ccl::parent-frame-saved-vars tcr frame catch srv srv))
     1621                      (when (done-p) (return-from loop)))
     1622                  (when (eql 0 (decf cnt))
     1623                    (setq cnt period)
     1624                    (push (vector frame catch (ccl::copy-srv srv))
     1625                          addresses))
     1626                  (setq last-frame frame)
     1627                  (multiple-value-setq (frame catch srv)
     1628                    (ccl::parent-frame-saved-vars tcr frame catch srv srv))
     1629                  (incf count))))
     1630          (setf (frame-count f) count
     1631                (addresses f) (list-to-vector (nreverse addresses))))))
     1632
     1633(defun error-frame-n (error-frame n)
     1634  (let* ((addresses (addresses error-frame))
     1635         (period (sampling-period error-frame))
     1636         (tcr (tcr error-frame))
     1637         p child)
     1638    (flet ((skipping-uninteresting-parent-frames (child)
     1639            (loop while (ignore-function-in-backtrace?
     1640                         error-frame (ccl::cfp-lfun (ccl::parent-frame child tcr)))
     1641                  do (setq child (ccl::parent-frame child tcr))
     1642                  finally (return child))))
     1643      (unless (< -1 n (frame-count error-frame))
     1644        (setq n (require-type n `(integer 0 ,(1- (frame-count error-frame))))))
     1645      (if (eql 0 n)
     1646        (setq child (%sv.frame (svref addresses 0))
     1647              p (%sv.frame (svref addresses 1)))
     1648        (multiple-value-bind (idx offset) (floor (1- n) period)
     1649          (setq child (skipping-uninteresting-parent-frames
     1650                       (%sv.frame (svref addresses (1+ idx)))))
     1651          (dotimes (i offset)
     1652            (declare (fixnum i))
     1653            (setq child (skipping-uninteresting-parent-frames
     1654                         (ccl::parent-frame child tcr))))
     1655          (setq p (ccl::parent-frame child tcr))))
     1656      (values p child))))
     1657
     1658(defmethod error-frame-address-n ((f error-frame) n)
     1659  (multiple-value-bind (p child) (error-frame-n f n)
     1660    (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
     1661      (values p lfun pc child))))
     1662
     1663; Returns 6 values:
     1664; p lfun pc child last-catch srv
     1665; Where the last-catch & register values are those for the CHILD's frame
     1666; (the ones we need to look at to display values for frame P).
     1667(defmethod error-frame-regs-n ((f error-frame) n)
     1668  (let* ((addresses (addresses f))
     1669         (period (sampling-period f))
     1670         (tcr (tcr f))
     1671         p child last-catch srv)
     1672    (unless (< -1 n (frame-count f))
     1673      (setq n (require-type n `(integer 0 ,(1- (frame-count f))))))
     1674    (if (eql 0 n)
     1675      (let ((child-sv (svref addresses 0)))
     1676        (setq child (%sv.frame child-sv)
     1677              last-catch (%sv.last-catch child-sv)
     1678              srv (ccl::copy-srv (%sv.srv child-sv))))
     1679      (multiple-value-bind (idx offset) (floor (1- n) period)
     1680        (let ((child-sv (svref addresses (1+ idx))))
     1681          (setq child (%sv.frame child-sv)
     1682                last-catch (%sv.last-catch child-sv)
     1683                srv (ccl::copy-srv (%sv.srv child-sv))))
     1684        (flet ((maybe-ignore ()
     1685                 (loop while (ignore-function-in-backtrace?
     1686                            f
     1687                            (ccl::cfp-lfun (ccl::parent-frame child tcr)))
     1688                     do (multiple-value-setq (child last-catch srv)
     1689                          (ccl::parent-frame-saved-vars tcr child last-catch srv srv)))))
     1690         (maybe-ignore)
     1691           (dotimes (i offset)
     1692             (declare (fixnum i))
     1693             (multiple-value-setq (child last-catch srv)
     1694               (ccl::parent-frame-saved-vars tcr child last-catch srv srv))
     1695            (maybe-ignore)
     1696            ))))
     1697    (unless child (error "shouldn't happen"))
     1698    (setq p (ccl::parent-frame child tcr))
     1699    (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
     1700      (values p lfun pc child last-catch srv))))
     1701     
     1702
     1703(defun print-error-frame-limits (f stream)
     1704  (format stream "#x~x - #x~x" (stack-start f) (stack-end f)))
     1705
     1706(defmethod print-object ((f error-frame) stream)
     1707  (print-unreadable-object (f stream :type 'frame-ptr)
     1708    (print-error-frame-limits f stream)))
     1709
     1710
     1711
     1712;;;;;;;
     1713;;
     1714;; The inspector for error-frame objects
     1715;;
     1716
     1717; True to show more info about backtrace frames
     1718(defvar *show-backtrace-frame-addresses* nil)
     1719
     1720(defclass stack-inspector (inspector)
     1721  ((show-frame-addresses :initform *show-backtrace-frame-addresses*
     1722                         :accessor show-frame-addresses)))
     1723
     1724(defmethod initialize-instance ((i stack-inspector) &rest initargs &key info)
     1725  (declare (dynamic-extent initargs))
     1726  (let* ((tcr (ccl::bt.tcr info))
     1727         (start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest info) tcr) tcr))
     1728         (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest info) tcr) tcr)))
     1729    (apply #'call-next-method i
     1730           :object
     1731           (make-instance 'error-frame
     1732             :stack-start start
     1733             :stack-end end
     1734             :tcr tcr)
     1735           initargs)))
     1736
     1737(defmethod print-object ((i stack-inspector) stream)
     1738  (print-unreadable-object (i stream :type 'stack-inspector)
     1739    (print-error-frame-limits (inspector-object i) stream)))
     1740
     1741(defmethod addresses ((f stack-inspector))
     1742  (addresses (inspector-object f)))
     1743
     1744(defmethod error-frame-address-n ((f stack-inspector) n)
     1745  (error-frame-address-n (inspector-object f) n))
     1746
     1747(defmethod error-frame-regs-n ((f stack-inspector) n)
     1748  (error-frame-regs-n (inspector-object f) n))
     1749
     1750(defmethod compute-line-count ((f stack-inspector))
     1751  (setf (show-frame-addresses f) *show-backtrace-frame-addresses*)
     1752  (frame-count (inspector-object f)))
     1753
     1754(defmethod line-n ((f stack-inspector) n)
     1755  (multiple-value-bind (p lfun) (error-frame-address-n (inspector-object f) n)
     1756    (values lfun
     1757            (if (show-frame-addresses f) p n)
     1758            (if lfun :static '(:comment (:bold) (:plain :italic))) 'prin1-colon-line)))
     1759
     1760(defmethod prin1-label ((i stack-inspector) stream value &optional label type)
     1761  (declare (ignore value type))
     1762  (if (show-frame-addresses i)
     1763    (format stream "#x~x/#x~x"
     1764            (ccl::index->address label) (ccl::index->address (ccl::%frame-savevsp label)))
     1765    (call-next-method)))
     1766
     1767(defmethod prin1-value ((i stack-inspector) stream value &optional label type)
     1768  (declare (ignore label type))
     1769  (if value
     1770    (ccl::%lfun-name-string value stream)
     1771    (write-string "kernel" stream)))
     1772
     1773(defmethod line-n-inspector ((f stack-inspector) n value label type)
     1774  (declare (ignore value label type))
     1775  (multiple-value-bind (p lfun pc) (error-frame-address-n (inspector-object f) n)
     1776    (declare (ignore p))
     1777    (make-instance (inspector-class lfun) :object lfun :pc pc)))
     1778
     1779;; inspecting a single stack frame
     1780;; The inspector-object is expected to be an error-frame
     1781(defclass stack-frame-inspector (inspector)
     1782  ((frame-number :initarg :frame-number :initform nil :reader frame-number)
     1783   (frame-info :accessor frame-info)
     1784   (label-columns :accessor label-columns)
     1785   (saved-register-count :accessor saved-register-count)))
     1786
     1787
     1788(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key
     1789                                object frame-number)
     1790  (declare (dynamic-extent initargs))
     1791  (setq object (require-type object 'error-frame))
     1792  (apply #'call-next-method i
     1793         :object object
     1794         initargs)
     1795  (setf (frame-number i) frame-number))
     1796
     1797(defun integer-digits (integer &optional (base 10))
     1798  (setq integer (require-type integer 'fixnum))
     1799  (do ((digits (if (< integer 0) 2 1) (1+ digits))
     1800       (n (abs integer) (floor n base)))
     1801      ((if (< n base) (return digits)))))   
     1802
     1803(defmethod compute-line-count ((i stack-frame-inspector))
     1804  (let ((frame-number (frame-number i)))
     1805    (if (null frame-number)
     1806      0
     1807      (let* ((error-frame (inspector-object i))
     1808             (frame-info (multiple-value-list
     1809                          (error-frame-regs-n error-frame frame-number))))
     1810        (setf (frame-info i) frame-info)
     1811        (let ((count (ccl::count-values-in-frame
     1812                      (car frame-info)          ; this frame
     1813                      (tcr error-frame)
     1814                      (cadddr frame-info))))    ; child frame
     1815          (setf (label-columns i) (integer-digits count))
     1816          (let ((lfun (cadr frame-info))
     1817                (pc (caddr frame-info)))
     1818            (declare (ignore p))
     1819            (+ count (setf (saved-register-count i)
     1820                           (logcount (or (ccl::registers-used-by lfun pc) 0))))))))))
     1821
     1822(defmethod line-n ((i stack-frame-inspector) n)
     1823  (unless (< -1 n (inspector-line-count i))
     1824    (line-n-out-of-range i n))
     1825  (let ((frame-info (frame-info i))
     1826        (saved-register-count (saved-register-count i)))
     1827    (if (< n saved-register-count)
     1828      (multiple-value-bind (mask regs) (apply #'ccl::saved-register-values (cdr frame-info))
     1829        (let* ((srv (nth 5 frame-info))
     1830               (unresolved (ccl::srv.unresolved srv))
     1831               (j ccl::*saved-register-count*)
     1832               (i n))
     1833          (loop
     1834            (loop (if (logbitp (decf j) mask) (return)))
     1835            (if (< (decf i) 0) (return)))
     1836          (let ((name (saved-register-name
     1837                       (elt ccl::*saved-register-numbers* (- ccl::*saved-register-count* 1 j)) (cadr frame-info) (caddr frame-info))))
     1838            (values (if (setq unresolved (logbitp j unresolved))
     1839                      *unbound-marker*
     1840                      (ccl::srv.register-n regs (- ccl::*saved-register-count* 1 j)))
     1841                    (cons n
     1842                          (cons (elt ccl::*saved-register-names* j) name))
     1843                    (if unresolved :static :normal)))))
     1844      (destructuring-bind (p lfun pc child &rest rest) frame-info
     1845        (declare (ignore rest))
     1846        (let ((offset (- n saved-register-count)))
     1847          (multiple-value-bind (var type name)
     1848                               (ccl::nth-value-in-frame p offset (tcr (inspector-object i)) lfun pc child)
     1849            (values var (cons n (cons type name)) :normal)))))))
     1850
     1851(defmethod (setf line-n) (value (i stack-frame-inspector) n)
     1852  (unless (< -1 n (inspector-line-count i))
     1853    (line-n-out-of-range i n))
     1854  (let ((frame-info (frame-info i))
     1855        (saved-register-count (saved-register-count i)))
     1856    (if (< n saved-register-count)
     1857      (let* ((mask (apply #'ccl::saved-register-values (cdr frame-info)))
     1858             (srv (nth 5 frame-info))
     1859             (unresolved (ccl::srv.unresolved srv))
     1860             (j ccl::*saved-register-count*)
     1861             (i n))
     1862        (loop
     1863          (loop (if (logbitp (decf j) mask) (return)))
     1864          (if (< (decf i) 0) (return)))
     1865        (if (logbitp j unresolved) (line-n-out-of-range i n))
     1866        (apply #'ccl::set-saved-register value (- ccl::*saved-register-count* 1 j) (cdr frame-info)))
     1867      (destructuring-bind (p lfun pc child &rest rest) frame-info
     1868        (declare (ignore lfun pc rest))
     1869        (let ((offset (- n saved-register-count))
     1870              (tcr (tcr (inspector-object i))))
     1871          (ccl::set-nth-value-in-frame p offset tcr value child))))))
     1872
     1873(defun saved-register-name (reg lfun pc)
     1874  (let* ((map (ccl::function-symbol-map lfun))
     1875         (names (car map))
     1876         (info (cdr map))
     1877         (j 0))
     1878    (dotimes (i (length names))
     1879      (when (and (eq reg (aref info j))
     1880                 (<= (aref info (1+ j)) pc (aref info (+ j 2))))
     1881        (return (aref names i)))
     1882      (incf j 3))))
     1883       
     1884
     1885(defmethod prin1-label ((i stack-frame-inspector) stream value &optional label type)
     1886  (declare (ignore value type))
     1887  (format stream "~vd: " (label-columns i) (car label)))
     1888
     1889(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type)
     1890  (declare (ignore type))
     1891  (destructuring-bind (n type . name) label
     1892    (declare (ignore n))
     1893    (if name (format stream "~s " name))
     1894    (if type (format stream "(~a) " type))
     1895    (if (eq value *unbound-marker*)
     1896      (format stream "??")
     1897      (prin1 value stream))))
     1898
     1899(defmethod (setf frame-number) (frame-number (i stack-frame-inspector))
     1900  (let ((max (1- (frame-count (inspector-object i)))))
     1901    (unless (or (null frame-number)
     1902                (and (<= 0 frame-number max)))
     1903      (setq frame-number (require-type frame-number `(or null (integer 0 ,max))))))
     1904  (unless (eql frame-number (frame-number i))
     1905    (setf (slot-value i 'frame-number) frame-number)
     1906    (setf (inspector-line-count i) nil)
     1907    frame-number))
     1908
     1909
     1910
     1911
    15251912;;; Inspector
    15261913
Note: See TracChangeset for help on using the changeset viewer.