diff options
Diffstat (limited to 'lisp/progmodes/gdb-mi.el')
| -rw-r--r-- | lisp/progmodes/gdb-mi.el | 303 |
1 files changed, 185 insertions, 118 deletions
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 8ba2822c3a3..0b52302a98d 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -91,7 +91,7 @@ (require 'gud) (require 'json) (require 'bindat) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) @@ -206,8 +206,8 @@ Only used for files that Emacs can't find.") (defvar gdb-last-command nil) (defvar gdb-prompt-name nil) (defvar gdb-token-number 0) -(defvar gdb-handler-alist '()) -(defvar gdb-handler-number nil) +(defvar gdb-handler-list '() + "List of gdb-handler keeping track of all pending GDB commands.") (defvar gdb-source-file-list nil "List of source files for the current executable.") (defvar gdb-first-done-or-error t) @@ -242,33 +242,114 @@ Possible values are these symbols: disposition of output generated by commands that gdb mode sends to gdb on its own behalf.") -;; Pending triggers prevent congestion: Emacs won't send two similar -;; consecutive requests. - -(defvar gdb-pending-triggers '() - "A list of trigger functions which have not yet been handled. - -Elements are either function names or pairs (buffer . function)") - -(defmacro gdb-add-pending (item) - `(push ,item gdb-pending-triggers)) -(defmacro gdb-pending-p (item) - `(member ,item gdb-pending-triggers)) -(defmacro gdb-delete-pending (item) - `(setq gdb-pending-triggers - (delete ,item gdb-pending-triggers))) +(defcustom gdb-discard-unordered-replies t + "Non-nil means discard any out-of-order GDB replies. +This protects against lost GDB replies, assuming that GDB always +replies in the same order as Emacs sends commands. When receiving a +reply with a given token-number, assume any pending messages with a +lower token-number are out-of-order." + :type 'boolean + :group 'gud + :version "24.4") + +(cl-defstruct gdb-handler + "Data required to handle the reply of a command sent to GDB." + ;; Prefix of the command sent to GDB. The GDB reply for this command + ;; will be prefixed with this same TOKEN-NUMBER + (token-number nil :read-only t) + ;; Callback to invoke when the reply is received from GDB + (function nil :read-only t) + ;; PENDING-TRIGGER is used to prevent congestion: Emacs won't send + ;; two requests with the same PENDING-TRIGGER until a reply is received + ;; for the first one." + (pending-trigger nil)) + +(defun gdb-add-handler (token-number handler-function &optional pending-trigger) + "Insert a new GDB command handler in `gdb-handler-list'. +Handlers are used to keep track of the commands sent to GDB +and to handle the replies received. +Upon reception of a reply prefixed with TOKEN-NUMBER, +invoke the callback HANDLER-FUNCTION. +If PENDING-TRIGGER is specified, no new GDB commands will be +sent with this same PENDING-TRIGGER until a reply is received +for this handler." + + (push (make-gdb-handler :token-number token-number + :function handler-function + :pending-trigger pending-trigger) + gdb-handler-list)) + +(defun gdb-delete-handler (token-number) + "Remove the handler TOKEN-NUMBER from `gdb-handler-list'. +Additionally, if `gdb-discard-unordered-replies' is non-nil, +discard all handlers having a token number less than TOKEN-NUMBER." + (if gdb-discard-unordered-replies + + (setq gdb-handler-list + (cl-delete-if + (lambda (handler) + "Discard any HANDLER with a token number `<=' than TOKEN-NUMBER." + (when (< (gdb-handler-token-number handler) token-number) + (message (format + "WARNING! Discarding GDB handler with token #%d\n" + (gdb-handler-token-number handler)))) + (<= (gdb-handler-token-number handler) token-number)) + gdb-handler-list)) + + (setq gdb-handler-list + (cl-delete-if + (lambda (handler) + "Discard any HANDLER with a token number `eq' to TOKEN-NUMBER." + (eq (gdb-handler-token-number handler) token-number)) + gdb-handler-list)))) + +(defun gdb-get-handler-function (token-number) + "Return the function callback registered with the handler TOKEN-NUMBER." + (gdb-handler-function + (cl-find-if (lambda (handler) (eq (gdb-handler-token-number handler) + token-number)) + gdb-handler-list))) + + +(defun gdb-pending-handler-p (pending-trigger) + "Return non-nil if a command handler is pending with trigger PENDING-TRIGGER." + (cl-find-if (lambda (handler) (eq (gdb-handler-pending-trigger handler) + pending-trigger)) + gdb-handler-list)) + + +(defun gdb-handle-reply (token-number) + "Handle the GDB reply TOKEN-NUMBER. +This invokes the handler registered with this token number +in `gdb-handler-list' and clears all pending handlers invalidated +by the reception of this reply." + (let ((handler-function (gdb-get-handler-function token-number))) + (when handler-function + (funcall handler-function) + (gdb-delete-handler token-number)))) + +(defun gdb-remove-all-pending-triggers () + "Remove all pending triggers from gdb-handler-list. +The handlers are left in gdb-handler-list so that replies received +from GDB could still be handled. However, removing the pending triggers +allows Emacs to send new commands even if replies of previous commands +were not yet received." + (dolist (handler gdb-handler-list) + (setf (gdb-handler-pending-trigger handler) nil))) (defmacro gdb-wait-for-pending (&rest body) - "Wait until `gdb-pending-triggers' is empty and evaluate FORM. - -This function checks `gdb-pending-triggers' value every -`gdb-wait-for-pending' seconds." - (run-with-timer - 0.5 nil - `(lambda () - (if (not gdb-pending-triggers) - (progn ,@body) - (gdb-wait-for-pending ,@body))))) + "Wait for all pending GDB commands to finish and evaluate BODY. + +This function checks every 0.5 seconds if there are any pending +triggers in `gdb-handler-list'." + `(run-with-timer + 0.5 nil + '(lambda () + (if (not (cl-find-if (lambda (handler) + (gdb-handler-pending-trigger handler)) + gdb-handler-list)) + (progn ,@body) + (gdb-wait-for-pending ,@body))))) ;; Publish-subscribe @@ -574,21 +655,20 @@ NOARG must be t when this macro is used outside `gud-def'" (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2) ,(when (not noarg) 'arg))) -(defun gdb--check-interpreter (proc string) +(defun gdb--check-interpreter (filter proc string) (unless (zerop (length string)) - (let ((filter (process-get proc 'gud-normal-filter))) - (set-process-filter proc filter) - (unless (memq (aref string 0) '(?^ ?~ ?@ ?& ?* ?=)) - ;; Apparently we're not running with -i=mi. - (let ((msg "Error: you did not specify -i=mi on GDB's command line!")) - (message msg) - (setq string (concat (propertize msg 'font-lock-face 'error) - "\n" string))) - ;; Use the old gud-gbd filter, not because it works, but because it - ;; will properly display GDB's answers rather than hanging waiting for - ;; answers that aren't coming. - (set (make-local-variable 'gud-marker-filter) #'gud-gdb-marker-filter)) - (funcall filter proc string)))) + (remove-function (process-filter proc) #'gdb--check-interpreter) + (unless (memq (aref string 0) '(?^ ?~ ?@ ?& ?* ?=)) + ;; Apparently we're not running with -i=mi. + (let ((msg "Error: you did not specify -i=mi on GDB's command line!")) + (message msg) + (setq string (concat (propertize msg 'font-lock-face 'error) + "\n" string))) + ;; Use the old gud-gbd filter, not because it works, but because it + ;; will properly display GDB's answers rather than hanging waiting for + ;; answers that aren't coming. + (set (make-local-variable 'gud-marker-filter) #'gud-gdb-marker-filter)) + (funcall filter proc string))) (defvar gdb-control-level 0) @@ -662,8 +742,7 @@ detailed description of this mode. ;; Setup a temporary process filter to warn when GDB was not started ;; with -i=mi. (let ((proc (get-buffer-process gud-comint-buffer))) - (process-put proc 'gud-normal-filter (process-filter proc)) - (set-process-filter proc #'gdb--check-interpreter)) + (add-function :around (process-filter proc) #'gdb--check-interpreter)) (set (make-local-variable 'gud-minor-mode) 'gdbmi) (set (make-local-variable 'gdb-control-level) 0) @@ -822,14 +901,12 @@ detailed description of this mode. gdb-frame-number nil gdb-thread-number nil gdb-var-list nil - gdb-pending-triggers nil gdb-output-sink 'user gdb-location-alist nil gdb-source-file-list nil gdb-last-command nil gdb-token-number 0 - gdb-handler-alist '() - gdb-handler-number nil + gdb-handler-list '() gdb-prompt-name nil gdb-first-done-or-error t gdb-buffer-fringe-width (car (window-fringes)) @@ -1109,17 +1186,15 @@ With arg, enter name of variable to be watched in the minibuffer." (message-box "No symbol \"%s\" in current context." expr)))) (defun gdb-speedbar-update () - (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) - (not (gdb-pending-p 'gdb-speedbar-timer))) + (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) ;; Dummy command to update speedbar even when idle. - (gdb-input "-environment-pwd" 'gdb-speedbar-timer-fn) - ;; Keep gdb-pending-triggers non-nil till end. - (gdb-add-pending 'gdb-speedbar-timer))) + (gdb-input "-environment-pwd" + 'gdb-speedbar-timer-fn + 'gdb-speedbar-update))) (defun gdb-speedbar-timer-fn () (if gdb-speedbar-auto-raise (raise-frame speedbar-frame)) - (gdb-delete-pending 'gdb-speedbar-timer) (speedbar-timer-fn)) (defun gdb-var-evaluate-expression-handler (varnum changed) @@ -1209,9 +1284,9 @@ With arg, enter name of variable to be watched in the minibuffer." ; Uses "-var-update --all-values". Needs GDB 6.4 onwards. (defun gdb-var-update () - (if (not (gdb-pending-p 'gdb-var-update)) - (gdb-input "-var-update --all-values *" 'gdb-var-update-handler)) - (gdb-add-pending 'gdb-var-update)) + (gdb-input "-var-update --all-values *" + 'gdb-var-update-handler + 'gdb-var-update)) (defun gdb-var-update-handler () (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) @@ -1274,8 +1349,6 @@ With arg, enter name of variable to be watched in the minibuffer." (push var1 var-list)) (setq var1 (pop temp-var-list))) (setq gdb-var-list (nreverse var-list)))))))) - (setq gdb-pending-triggers - (delq 'gdb-var-update gdb-pending-triggers)) (gdb-speedbar-update)) (defun gdb-speedbar-expand-node (text token indent) @@ -1729,18 +1802,25 @@ All embedded quotes, newlines, and backslashes are preceded with a backslash." (setq string (replace-regexp-in-string "\n" "\\n" string t t)) (concat "\"" string "\"")) -(defun gdb-input (command handler-function) +(defun gdb-input (command handler-function &optional trigger-name) "Send COMMAND to GDB via the MI interface. Run the function HANDLER-FUNCTION, with no arguments, once the command is -complete." - (if gdb-enable-debug (push (list 'send-item command handler-function) - gdb-debug-log)) - (setq gdb-token-number (1+ gdb-token-number)) - (setq command (concat (number-to-string gdb-token-number) command)) - (push (cons gdb-token-number handler-function) gdb-handler-alist) - (if gdbmi-debug-mode (message "gdb-input: %s" command)) - (process-send-string (get-buffer-process gud-comint-buffer) - (concat command "\n"))) +complete. Do not send COMMAND to GDB if TRIGGER-NAME is non-nil and +Emacs is still waiting for a reply from another command previously +sent with the same TRIGGER-NAME." + (when (or (not trigger-name) + (not (gdb-pending-handler-p trigger-name))) + (setq gdb-token-number (1+ gdb-token-number)) + (setq command (concat (number-to-string gdb-token-number) command)) + + (if gdb-enable-debug (push (list 'send-item command handler-function) + gdb-debug-log)) + + (gdb-add-handler gdb-token-number handler-function trigger-name) + + (if gdbmi-debug-mode (message "gdb-input: %s" command)) + (process-send-string (get-buffer-process gud-comint-buffer) + (concat command "\n")))) ;; NOFRAME is used for gud execution control commands (defun gdb-current-context-command (command) @@ -1776,7 +1856,7 @@ If `gdb-thread-number' is nil, just wrap NAME in asterisks." (defun gdb-resync() (setq gud-running nil) (setq gdb-output-sink 'user) - (setq gdb-pending-triggers nil)) + (gdb-remove-all-pending-triggers)) (defun gdb-update (&optional no-proc) "Update buffers showing status of debug session. @@ -2149,19 +2229,23 @@ the end of the current result or async record is reached." ;; Search the data stream for the end of the current record: (let* ((newline-pos (string-match "\n" gud-marker-acc gdbmi-bnf-offset)) (is-progressive (equal (cdr class-command) 'progressive)) - (is-complete (not (null newline-pos))) - result-str) + (is-complete (not (null newline-pos))) + result-str) + + (when gdbmi-debug-mode + (message "gdbmi-bnf-incomplete-record-result: %s" + (substring gud-marker-acc gdbmi-bnf-offset newline-pos))) ;; Update the gdbmi-bnf-offset only if the current chunk of data can ;; be processed by the class-command handler: (when (or is-complete is-progressive) - (setq result-str + (setq result-str (substring gud-marker-acc gdbmi-bnf-offset newline-pos)) - (setq gdbmi-bnf-offset (+ 1 newline-pos))) - (if gdbmi-debug-mode - (message "gdbmi-bnf-incomplete-record-result: %s" - (substring gud-marker-acc gdbmi-bnf-offset newline-pos))) + ;; Move gdbmi-bnf-offset past the end of the chunk. + (setq gdbmi-bnf-offset (+ gdbmi-bnf-offset (length result-str))) + (when newline-pos + (setq gdbmi-bnf-offset (1+ gdbmi-bnf-offset)))) ;; Update the parsing state before invoking the handler in class-command ;; to make sure it's not left in an invalid state if the handler was @@ -2253,9 +2337,9 @@ Unset `gdb-thread-number' if current thread exited and update threads list." (if (string= gdb-thread-number thread-id) (gdb-setq-thread-number nil)) ;; When we continue current thread and it quickly exits, - ;; gdb-pending-triggers left after gdb-running disallow us to - ;; properly call -thread-info without --thread option. Thus we - ;; need to use gdb-wait-for-pending. + ;; the pending triggers in gdb-handler-list left after gdb-running + ;; disallow us to properly call -thread-info without --thread option. + ;; Thus we need to use gdb-wait-for-pending. (gdb-wait-for-pending (gdb-emit-signal gdb-buf-publisher 'update-threads)))) @@ -2270,9 +2354,10 @@ Sets `gdb-thread-number' to new id." ;; by `=thread-selected` notification. `^done` causes `gdb-update` ;; as usually. Things happen to fast and second call (from ;; gdb-thread-selected handler) gets cut off by our beloved - ;; gdb-pending-triggers. - ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its - ;; body will get executed when `gdb-pending-triggers` is empty. + ;; pending triggers. + ;; Solution is `gdb-wait-for-pending' macro: it guarantees that its + ;; body will get executed when `gdb-handler-list' if free of + ;; pending triggers. (gdb-wait-for-pending (gdb-update)))) @@ -2291,8 +2376,7 @@ Sets `gdb-thread-number' to new id." (propertize gdb-inferior-status 'face font-lock-type-face)) (when (not gdb-non-stop) (setq gud-running t)) - (setq gdb-active-process t) - (gdb-emit-signal gdb-buf-publisher 'update-threads)) + (setq gdb-active-process t)) (defun gdb-starting (_output-field _result) ;; CLI commands don't emit ^running at the moment so use gdb-running too. @@ -2300,11 +2384,7 @@ Sets `gdb-thread-number' to new id." (gdb-force-mode-line-update (propertize gdb-inferior-status 'face font-lock-type-face)) (setq gdb-active-process t) - (setq gud-running t) - ;; GDB doesn't seem to respond to -thread-info before first stop or - ;; thread exit (even in non-stop mode), so this is useless. - ;; Behavior may change in the future. - (gdb-emit-signal gdb-buf-publisher 'update-threads)) + (setq gud-running t)) ;; -break-insert -t didn't give a reason before gdb 6.9 @@ -2436,10 +2516,7 @@ current thread and update GDB buffers." (when (and token-number is-complete) (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (funcall - (cdr (assoc (string-to-number token-number) gdb-handler-alist)))) - (setq gdb-handler-alist - (assq-delete-all token-number gdb-handler-alist))) + (gdb-handle-reply (string-to-number token-number)))) (when is-complete (gdb-clear-partial-output)))) @@ -2657,27 +2734,23 @@ trigger argument when describing buffer types with (when (or (not ,signal-list) (memq signal ,signal-list)) - (when (not (gdb-pending-p - (cons (current-buffer) ',trigger-name))) - (gdb-input ,gdb-command - (gdb-bind-function-to-buffer ',handler-name (current-buffer))) - (gdb-add-pending (cons (current-buffer) ',trigger-name)))))) + (gdb-input ,gdb-command + (gdb-bind-function-to-buffer ',handler-name (current-buffer)) + (cons (current-buffer) ',trigger-name))))) ;; Used by disassembly buffer only, the rest use ;; def-gdb-trigger-and-handler -(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun +(defmacro def-gdb-auto-update-handler (handler-name custom-defun &optional nopreserve) - "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN. + "Define a handler HANDLER-NAME calling CUSTOM-DEFUN. Handlers are normally called from the buffers they put output in. -Delete ((current-buffer) . TRIGGER-NAME) from -`gdb-pending-triggers', erase current buffer and evaluate -CUSTOM-DEFUN. Then `gdb-update-buffer-name' is called. +Erase current buffer and evaluate CUSTOM-DEFUN. +Then call `gdb-update-buffer-name'. If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN." `(defun ,handler-name () - (gdb-delete-pending (cons (current-buffer) ',trigger-name)) (let* ((inhibit-read-only t) ,@(unless nopreserve '((window (get-buffer-window (current-buffer) 0)) @@ -2705,7 +2778,7 @@ See `def-gdb-auto-update-handler'." ,gdb-command ,handler-name ,signal-list) (def-gdb-auto-update-handler ,handler-name - ,trigger-name ,custom-defun))) + ,custom-defun))) @@ -3622,7 +3695,6 @@ DOC is an optional documentation string." (def-gdb-auto-update-handler gdb-disassembly-handler - gdb-invalidate-disassembly gdb-disassembly-handler-custom t) @@ -4114,21 +4186,19 @@ member." ;; Needs GDB 6.4 onwards (used to fail with no stack). (defun gdb-get-changed-registers () - (when (and (gdb-get-buffer 'gdb-registers-buffer) - (not (gdb-pending-p 'gdb-get-changed-registers))) + (when (gdb-get-buffer 'gdb-registers-buffer) (gdb-input "-data-list-changed-registers" - 'gdb-changed-registers-handler) - (gdb-add-pending 'gdb-get-changed-registers))) + 'gdb-changed-registers-handler + 'gdb-get-changed-registers))) (defun gdb-changed-registers-handler () - (gdb-delete-pending 'gdb-get-changed-registers) (setq gdb-changed-registers nil) (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers)) (push register-number gdb-changed-registers))) (defun gdb-register-names-handler () - ;; Don't use gdb-pending-triggers because this handler is called + ;; Don't use pending triggers because this handler is called ;; only once (in gdb-init-1) (setq gdb-register-names nil) (dolist (register-name @@ -4152,16 +4222,13 @@ is set in them." (defun gdb-get-main-selected-frame () "Trigger for `gdb-frame-handler' which uses main current thread. Called from `gdb-update'." - (if (not (gdb-pending-p 'gdb-get-main-selected-frame)) - (progn - (gdb-input (gdb-current-context-command "-stack-info-frame") - 'gdb-frame-handler) - (gdb-add-pending 'gdb-get-main-selected-frame)))) + (gdb-input (gdb-current-context-command "-stack-info-frame") + 'gdb-frame-handler + 'gdb-get-main-selected-frame)) (defun gdb-frame-handler () "Set `gdb-selected-frame' and `gdb-selected-file' to show overlay arrow in source buffer." - (gdb-delete-pending 'gdb-get-main-selected-frame) (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame))) (when frame (setq gdb-selected-frame (bindat-get-field frame 'func)) |