/[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.125 by heller, Tue Oct 26 00:32:08 2004 UTC revision 1.126 by heller, Thu Oct 28 21:34:36 2004 UTC
# Line 1573  A utility for debugging DEBUG-FUNCTION-A Line 1573  A utility for debugging DEBUG-FUNCTION-A
1573                  (t (format nil "Cannot return from frame: ~S" frame))))                  (t (format nil "Cannot return from frame: ~S" frame))))
1574          "return-from-frame is not implemented in this version of CMUCL.")))          "return-from-frame is not implemented in this version of CMUCL.")))
1575    
1576  (defimplementation sldb-step (frame)  (defimplementation activate-stepping (frame)
1577    (cond ((find-restart 'continue)    (set-step-breakpoints (nth-frame frame)))
          (set-step-breakpoints (nth-frame frame))  
          (continue))  
         (t  
          (error "No continue restart."))))  
1578    
1579  (defimplementation sldb-break-on-return (frame)  (defimplementation sldb-break-on-return (frame)
1580    (break-on-return (nth-frame frame)))    (break-on-return (nth-frame frame)))
# Line 1605  A utility for debugging DEBUG-FUNCTION-A Line 1601  A utility for debugging DEBUG-FUNCTION-A
1601    "Return true if the frame pointers of FRAME1 and FRAME2 are the same."    "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
1602    (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))    (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
1603    
1604    ;;; The PC in escaped frames at a single-return-value point is
1605    ;;; actually vm:single-value-return-byte-offset bytes after the
1606    ;;; position given in the debug info.  Here we try to recognize such
1607    ;;; cases.
1608    ;;;
1609    (defun next-code-locations (frame code-location)
1610      "Like `debug::next-code-locations' but be careful in escaped frames."
1611      (let ((next (debug::next-code-locations code-location)))
1612        (flet ((adjust-pc ()
1613                 (let ((cl (di::copy-compiled-code-location code-location)))
1614                   (incf (di::compiled-code-location-pc cl)
1615                         vm:single-value-return-byte-offset)
1616                   cl)))
1617          (cond ((and (di::compiled-frame-escaped frame)
1618                      (eq (di:code-location-kind code-location)
1619                          :single-value-return)
1620                      (= (length next) 1)
1621                      (di:code-location= (car next) (adjust-pc)))
1622                 (debug::next-code-locations (car next)))
1623                (t
1624                 next)))))
1625    
1626  (defun set-step-breakpoints (frame)  (defun set-step-breakpoints (frame)
1627    (let ((cl (di:frame-code-location frame)))    (let ((cl (di:frame-code-location frame)))
1628      (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))      (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
1629        (error "Cannot step in elsewhere code"))        (error "Cannot step in elsewhere code"))
1630      (let* ((debug::*bad-code-location-types*      (let* ((debug::*bad-code-location-types*
1631              (remove :call-site debug::*bad-code-location-types*))              (remove :call-site debug::*bad-code-location-types*))
1632             (next (debug::next-code-locations cl)))             (next (next-code-locations frame cl)))
1633        (cond (next        (cond (next
1634               (let ((steppoints '()))               (let ((steppoints '()))
1635                 (flet ((hook (bp-frame bp)                 (flet ((hook (bp-frame bp)
1636                          (mapc #'di:delete-breakpoint steppoints)                          (signal-breakpoint bp bp-frame)
1637                          (signal-breakpoint bp bp-frame)))                          (mapc #'di:delete-breakpoint steppoints)))
1638                   (dolist (code-location next)                   (dolist (code-location next)
1639                     (let ((bp (di:make-breakpoint #'hook code-location                     (let ((bp (di:make-breakpoint #'hook code-location
1640                                                   :kind :code-location)))                                                   :kind :code-location)))
# Line 1874  The `symbol-value' of each element is a Line 1892  The `symbol-value' of each element is a
1892    
1893  (defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector))  (defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector))
1894    (declare (ignore inspector))    (declare (ignore inspector))
1895    (multiple-value-bind (title contents)    (let ((header (kernel:get-type o)))
1896        (call-next-method)      (cond ((= header vm:function-header-type)
1897      (let ((header (kernel:get-type o)))             (values (format nil "~A is a function." o)
1898        (cond ((= header vm:function-header-type)                     (append (label-value-line*
1899               (values (format nil "~A is a function." o)                              ("Self" (kernel:%function-self o))
1900                       (append contents                              ("Next" (kernel:%function-next o))
1901                               (label-value-line*                              ("Name" (kernel:%function-name o))
1902                                ("Self" (kernel:%function-self o))                              ("Arglist" (kernel:%function-arglist o))
1903                                ("Next" (kernel:%function-next o))                              ("Type" (kernel:%function-type o))
1904                                ("Type" (kernel:%function-type o))                              ("Code" (kernel:function-code-header o)))
1905                                ("Code" (kernel:function-code-header o)))                             (list
1906                               (list                              (with-output-to-string (s)
1907                                (with-output-to-string (s)                                (disassem:disassemble-function o :stream s))))))
1908                                  (disassem:disassemble-function o :stream s))))))            ((= header vm:closure-header-type)
1909              ((= header vm:closure-header-type)             (values (format nil "~A is a closure" o)
1910               (values (format nil "~A is a closure" o)                     (append
1911                       (append                      (label-value-line "Function" (kernel:%closure-function o))
1912                        (label-value-line "Function Object" (kernel:%closure-function o))                      `("Environment:" (:newline))
1913                        `("Environment:" (:newline))                      (loop for i from 0 below (1- (kernel:get-closure-length o))
1914                        (loop                            append (label-value-line
1915                           for i from 0 below (1- (kernel:get-closure-length o))                                    i (kernel:%closure-index-ref o i))))))
1916                           append (label-value-line i (kernel:%closure-index-ref o i))))))            (t
1917            (t (values title contents))))))             (call-next-method)))))
1918    
1919    
1920  (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector))  (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector))
1921    (declare (ignore _))    (declare (ignore _))
# Line 1945  The `symbol-value' of each element is a Line 1964  The `symbol-value' of each element is a
1964    (eval `(profile:unprofile ,fname)))    (eval `(profile:unprofile ,fname)))
1965    
1966  (defimplementation unprofile-all ()  (defimplementation unprofile-all ()
1967    (profile:unprofile)    (eval `(profile:unprofile))
1968    "All functions unprofiled.")    "All functions unprofiled.")
1969    
1970  (defimplementation profile-report ()  (defimplementation profile-report ()
1971    (profile:report-time))    (eval `(profile:report-time)))
1972    
1973  (defimplementation profile-reset ()  (defimplementation profile-reset ()
1974    (profile:reset-time)    (eval `(profile:reset-time))
1975    "Reset profiling counters.")    "Reset profiling counters.")
1976    
1977  (defimplementation profiled-functions ()  (defimplementation profiled-functions ()

Legend:
Removed from v.1.125  
changed lines
  Added in v.1.126

  ViewVC Help
Powered by ViewVC 1.1.5