-;;; We cache a stream to the last valid file debug source so that we
-;;; won't have to repeatedly open the file.
-;;;
-;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
-;;; in the 1990s, so the benefit is negligible, less important than the
-;;; potential of extra confusion if someone changes the source during
-;;; a debug session and the change doesn't show up. And removing this
-;;; would simplify the system, which I like. -- WHN 19990903
-(defvar *cached-debug-source* nil)
-(declaim (type (or sb!di:debug-source null) *cached-debug-source*))
-(defvar *cached-source-stream* nil)
-(declaim (type (or stream null) *cached-source-stream*))
-
-;;; To suppress the read-time evaluation #. macro during source read,
-;;; *READTABLE* is modified. *READTABLE* is cached to avoid
-;;; copying it each time, and invalidated when the
-;;; *CACHED-DEBUG-SOURCE* has changed.
-(defvar *cached-readtable* nil)
-(declaim (type (or readtable null) *cached-readtable*))
-
-(pushnew (lambda ()
- (setq *cached-debug-source* nil *cached-source-stream* nil
- *cached-readtable* nil))
- *before-save-initializations*)
-
-;;; We also cache the last toplevel form that we printed a source for
-;;; so that we don't have to do repeated reads and calls to
-;;; FORM-NUMBER-TRANSLATIONS.
-(defvar *cached-toplevel-form-offset* nil)
-(declaim (type (or index null) *cached-toplevel-form-offset*))
-(defvar *cached-toplevel-form*)
-(defvar *cached-form-number-translations*)
-
-;;; Given a code location, return the associated form-number
-;;; translations and the actual top level form. We check our cache ---
-;;; if there is a miss, we dispatch on the kind of the debug source.
-(defun get-toplevel-form (location)
- (let ((d-source (sb!di:code-location-debug-source location)))
- (if (and (eq d-source *cached-debug-source*)
- (eql (sb!di:code-location-toplevel-form-offset location)
- *cached-toplevel-form-offset*))
- (values *cached-form-number-translations* *cached-toplevel-form*)
- (let* ((offset (sb!di:code-location-toplevel-form-offset location))
- (res
- (ecase (sb!di:debug-source-from d-source)
- (:file (get-file-toplevel-form location))
- (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
- (setq *cached-toplevel-form-offset* offset)
- (values (setq *cached-form-number-translations*
- (sb!di:form-number-translations res offset))
- (setq *cached-toplevel-form* res))))))
-
-;;; Locate the source file (if it still exists) and grab the top level
-;;; form. If the file is modified, we use the top level form offset
-;;; instead of the recorded character offset.
-(defun get-file-toplevel-form (location)
- (let* ((d-source (sb!di:code-location-debug-source location))
- (tlf-offset (sb!di:code-location-toplevel-form-offset location))
- (local-tlf-offset (- tlf-offset
- (sb!di:debug-source-root-number d-source)))
- (char-offset
- (aref (or (sb!di:debug-source-start-positions d-source)
- (error "no start positions map"))
- local-tlf-offset))
- (name (sb!di:debug-source-name d-source)))
- (unless (eq d-source *cached-debug-source*)
- (unless (and *cached-source-stream*
- (equal (pathname *cached-source-stream*)
- (pathname name)))
- (setq *cached-readtable* nil)
- (when *cached-source-stream* (close *cached-source-stream*))
- (setq *cached-source-stream* (open name :if-does-not-exist nil))
- (unless *cached-source-stream*
- (error "The source file no longer exists:~% ~A" (namestring name)))
- (format t "~%; file: ~A~%" (namestring name)))
-
- (setq *cached-debug-source*
- (if (= (sb!di:debug-source-created d-source)
- (file-write-date name))
- d-source nil)))
-
- (cond
- ((eq *cached-debug-source* d-source)
- (file-position *cached-source-stream* char-offset))
- (t
- (format t "~%; File has been modified since compilation:~%; ~A~@
- ; Using form offset instead of character position.~%"
- (namestring name))
- (file-position *cached-source-stream* 0)
- (let ((*read-suppress* t))
- (dotimes (i local-tlf-offset)
- (read *cached-source-stream*)))))
- (unless *cached-readtable*
- (setq *cached-readtable* (copy-readtable))
- (set-dispatch-macro-character
- #\# #\.
- (lambda (stream sub-char &rest rest)
- (declare (ignore rest sub-char))
- (let ((token (read stream t nil t)))
- (format nil "#.~S" token)))
- *cached-readtable*))
- (let ((*readtable* *cached-readtable*))
- (read *cached-source-stream*))))
-
-(defun print-code-location-source-form (location context)
- (let* ((location (maybe-block-start-location location))
- (form-num (sb!di:code-location-form-number location)))
- (multiple-value-bind (translations form) (get-toplevel-form location)
- (unless (< form-num (length translations))
- (error "The source path no longer exists."))
- (prin1 (sb!di:source-path-context form
- (svref translations form-num)
- context)))))
-\f
-;;; breakpoint and step commands
-
-;;; Step to the next code-location.
-(!def-debug-command "STEP" ()
- (setf *number-of-steps* (read-if-available 1))
- (set-step-breakpoint *current-frame*)
- (continue *debug-condition*)
- (error "couldn't continue"))
-
-;;; List possible breakpoint locations, which ones are active, and
-;;; where the CONTINUE restart will transfer control. Set
-;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
-;;; used by sbreakpoint.
-(!def-debug-command "LIST-LOCATIONS" ()
- (let ((df (read-if-available *default-breakpoint-debug-fun*)))
- (cond ((consp df)
- (setf df (sb!di:fun-debug-fun (eval df)))
- (setf *default-breakpoint-debug-fun* df))
- ((or (eq ':c df)
- (not *default-breakpoint-debug-fun*))
- (setf df (sb!di:frame-debug-fun *current-frame*))
- (setf *default-breakpoint-debug-fun* df)))
- (setf *possible-breakpoints* (possible-breakpoints df)))
- (let ((continue-at (sb!di:frame-code-location *current-frame*)))
- (let ((active (location-in-list *default-breakpoint-debug-fun*
- *breakpoints* :fun-start))
- (here (sb!di:code-location=
- (sb!di:debug-fun-start-location
- *default-breakpoint-debug-fun*) continue-at)))
- (when (or active here)
- (format t "::FUN-START ")
- (when active (format t " *Active*"))
- (when here (format t " *Continue here*"))))
-
- (let ((prev-location nil)
- (prev-num 0)
- (this-num 0))
- (flet ((flush ()
- (when prev-location
- (let ((this-num (1- this-num)))
- (if (= prev-num this-num)
- (format t "~&~W: " prev-num)
- (format t "~&~W-~W: " prev-num this-num)))
- (print-code-location-source-form prev-location 0)
- (when *print-location-kind*
- (format t "~S " (sb!di:code-location-kind prev-location)))
- (when (location-in-list prev-location *breakpoints*)
- (format t " *Active*"))
- (when (sb!di:code-location= prev-location continue-at)
- (format t " *Continue here*")))))
-
- (dolist (code-location *possible-breakpoints*)
- (when (or *print-location-kind*
- (location-in-list code-location *breakpoints*)
- (sb!di:code-location= code-location continue-at)
- (not prev-location)
- (not (eq (sb!di:code-location-debug-source code-location)
- (sb!di:code-location-debug-source prev-location)))
- (not (eq (sb!di:code-location-toplevel-form-offset
- code-location)
- (sb!di:code-location-toplevel-form-offset
- prev-location)))
- (not (eq (sb!di:code-location-form-number code-location)
- (sb!di:code-location-form-number prev-location))))
- (flush)
- (setq prev-location code-location prev-num this-num))
-
- (incf this-num))))
-
- (when (location-in-list *default-breakpoint-debug-fun*
- *breakpoints*
- :fun-end)
- (format t "~&::FUN-END *Active* "))))
-
-(!def-debug-command-alias "LL" "LIST-LOCATIONS")
-
-;;; Set breakpoint at the given number.
-(!def-debug-command "BREAKPOINT" ()
- (let ((index (read-prompting-maybe "location number, :START, or :END: "))
- (break t)
- (condition t)
- (print nil)
- (print-functions nil)
- (function nil)
- (bp)
- (place *default-breakpoint-debug-fun*))
- (flet ((get-command-line ()
- (let ((command-line nil)
- (unique '(nil)))
- (loop
- (let ((next-input (read-if-available unique)))
- (when (eq next-input unique) (return))
- (push next-input command-line)))
- (nreverse command-line)))
- (set-vars-from-command-line (command-line)
- (do ((arg (pop command-line) (pop command-line)))
- ((not arg))
- (ecase arg
- (:condition (setf condition (pop command-line)))
- (:print (push (pop command-line) print))
- (:break (setf break (pop command-line)))
- (:function
- (setf function (eval (pop command-line)))
- (setf *default-breakpoint-debug-fun*
- (sb!di:fun-debug-fun function))
- (setf place *default-breakpoint-debug-fun*)
- (setf *possible-breakpoints*
- (possible-breakpoints
- *default-breakpoint-debug-fun*))))))
- (setup-fun-start ()
- (let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-start))
- (setf break (sb!di:preprocess-for-eval break code-loc))
- (setf condition (sb!di:preprocess-for-eval condition code-loc))
- (dolist (form print)
- (push (cons (sb!di:preprocess-for-eval form code-loc) form)
- print-functions))))
- (setup-fun-end ()
- (setf bp
- (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-end))
- (setf break
- ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
- ;; forms should be converted to shiny new (LAMBDA ..) forms.
- ;; (Search the sources for "coerce.*\(lambda".)
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,break)
- 'function))
- (setf condition (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,condition)
- 'function))
- (dolist (form print)
- (push (cons
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,form) 'function)
- form)
- print-functions)))
- (setup-code-location ()
- (setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-fun place
- :kind :code-location))
- (dolist (form print)
- (push (cons
- (sb!di:preprocess-for-eval form place)
- form)
- print-functions))
- (setf break (sb!di:preprocess-for-eval break place))
- (setf condition (sb!di:preprocess-for-eval condition place))))
- (set-vars-from-command-line (get-command-line))
- (cond
- ((or (eq index :start) (eq index :s))
- (setup-fun-start))
- ((or (eq index :end) (eq index :e))
- (setup-fun-end))
- (t
- (setup-code-location)))
- (sb!di:activate-breakpoint bp)
- (let* ((new-bp-info (create-breakpoint-info place bp index
- :break break
- :print print-functions
- :condition condition))
- (old-bp-info (location-in-list new-bp-info *breakpoints*)))
- (when old-bp-info
- (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
- old-bp-info))
- (setf *breakpoints* (remove old-bp-info *breakpoints*))
- (format t "previous breakpoint removed~%"))
- (push new-bp-info *breakpoints*))
- (print-breakpoint-info (first *breakpoints*))
- (format t "~&added"))))
-
-(!def-debug-command-alias "BP" "BREAKPOINT")
-
-;;; List all breakpoints which are set.
-(!def-debug-command "LIST-BREAKPOINTS" ()
- (setf *breakpoints*
- (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
- (dolist (info *breakpoints*)
- (print-breakpoint-info info)))
-
-(!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
-
-;;; Remove breakpoint N, or remove all breakpoints if no N given.
-(!def-debug-command "DELETE-BREAKPOINT" ()
- (let* ((index (read-if-available nil))
- (bp-info
- (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
- (cond (bp-info
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
- (setf *breakpoints* (remove bp-info *breakpoints*))
- (format t "breakpoint ~S removed~%" index))
- (index (format t "The breakpoint doesn't exist."))
- (t
- (dolist (ele *breakpoints*)
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele)))
- (setf *breakpoints* nil)
- (format t "all breakpoints deleted~%")))))
-
-(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")